networks: Add read-org-tbn.

networks.rkt

@@ -103,7 +103,10 @@
                                         (listof (listof (or/c symbol? number?))))]
                [make-tbn (-> (listof (cons/c variable? tbf/state?)) tbn?)]
                [tbn->network (-> tbn? network?)]
-               [make-sbn (-> (listof (cons/c variable? tbf/state?)) sbn?)])
+               [make-sbn (-> (listof (cons/c variable? tbf/state?)) sbn?)]
+               [read-org-tbn (->* (string?)
+                                  (#:headers boolean? #:func-names boolean?)
+                                  tbn?)])
  ;; Predicates
  (contract-out [variable? (-> any/c boolean?)]
                [state? (-> any/c boolean?)]
@@ -1288,3 +1291,58 @@
     (define s2 (make-state '((a . 1) (b . 1))))
     (check-equal? (update sn s2 '(a b))
                   (make-state '((a . 0) (b . 1))))))
+
+;;; Reads a TBN from an Org-mode string containing a sexp, containing
+;;; a list of lists of numbers.  As in lists->tbfs/state, the last
+;;; element of each list is taken to be the threshold of the TBFs, and
+;;; the rest of the elements are taken to be the weights.
+;;;
+;;; As in read-org-tbfs/state, if headers is #t, the names of the
+;;; variables to appear as the inputs of the TBF are taken from the
+;;; first list.  The last element of this list is discarded.
+;;; If headers is #f, the names of the variables are generated as xi,
+;;; where i is the index of the variable.
+;;;
+;;; If func-names is #t, the first element in every row except the
+;;; first one, are taken to be the name of the variable to which the
+;;; TBF should be associated.  If func-names is #f, the functions are
+;;; assigned to variables in alphabetical order.
+;;;
+;;; func-names cannot be #t if headers is #f.  The function does not
+;;; check this condition.
+(define (read-org-tbn str
+                      #:headers [headers #t]
+                      #:func-names [func-names #t])
+  (define sexp (read-org-sexp str))
+  (cond
+    [(eq? func-names #t)
+     (define-values (vars rows) (multi-split-at sexp 1))
+     (define tbfs (lists->tbfs/state rows #:headers headers))
+     (for/hash ([tbf (in-list tbfs)] [var (in-list (cdr vars))])
+       (values (car var) tbf))]
+    [else
+     (define tbfs (lists->tbfs/state sexp #:headers headers))
+     (define vars (hash-map (tbf/state-w (car tbfs)) (λ (x _) x) #t))
+     (for/hash ([tbf (in-list tbfs)] [var (in-list vars)])
+       (values var tbf))]))
+
+(module+ test
+  (test-case "read-org-tbn"
+    (check-equal? (read-org-tbn "((\"-\" \"x\" \"y\" \"θ\") (\"y\" -1 0 -1) (\"x\" 0 -1 -1))")
+                  (hash
+                   'x
+                   (tbf/state '#hash((x . 0) (y . -1)) -1)
+                   'y
+                   (tbf/state '#hash((x . -1) (y . 0)) -1)))
+    (check-equal? (read-org-tbn "((\"x\" \"y\" \"θ\") (-1 0 -1) (0 -1 -1))" #:func-names #f)
+                  (hash
+                   'x
+                   (tbf/state '#hash((x . -1) (y . 0)) -1)
+                   'y
+                   (tbf/state '#hash((x . 0) (y . -1)) -1)))
+    (check-equal? (read-org-tbn "((-1 0 -1) (0 -1 -1))" #:headers #f #:func-names #f)
+                  (hash
+                   'x0
+                   (tbf/state '#hash((x0 . -1) (x1 . 0)) -1)
+                   'x1
+                   (tbf/state '#hash((x0 . 0) (x1 . -1)) -1)))))