scolobb/dds
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

networks: Factor parse-org-tbn out from read-org-tbn.

Browse source
This commit is contained in:
Sergiu Ivanov 2020-10-22 00:52:06 +02:00
parent 20b3357910
commit a3f3a5616d
1 changed files with 60 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

72
networks.rkt
View file

@ -108,6 +108,9 @@
[make-tbn (-> (listof (cons/c variable? tbf/state?)) tbn?)] [make-tbn (-> (listof (cons/c variable? tbf/state?)) tbn?)]
[tbn->network (-> tbn? network?)] [tbn->network (-> tbn? network?)]
[make-sbn (-> (listof (cons/c variable? tbf/state?)) sbn?)] [make-sbn (-> (listof (cons/c variable? tbf/state?)) sbn?)]
[parse-org-tbn (->* ((listof any/c))
(#:headers boolean? #:func-names boolean?)
tbn?)]
[read-org-tbn (->* (string?) [read-org-tbn (->* (string?)
(#:headers boolean? #:func-names boolean?) (#:headers boolean? #:func-names boolean?)
tbn?)]) tbn?)])
@ -1333,6 +1336,40 @@
(check-equal? (update sn s2 '(a b)) (check-equal? (update sn s2 '(a b))
(make-state '((a . 0) (b . 1)))))) (make-state '((a . 0) (b . 1))))))
;;; A helper function for read-org-tbn and read-org-sbn. It reads a
;;; TBN from an Org-mode 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 (parse-org-tbn sexp
#:headers [headers #t]
#:func-names [func-names #t])
(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))]))
;;; Reads a TBN from an Org-mode string containing a sexp, containing ;;; 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 ;;; 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 ;;; element of each list is taken to be the threshold of the TBFs, and
@ -1354,19 +1391,30 @@
(define (read-org-tbn str (define (read-org-tbn str
#:headers [headers #t] #:headers [headers #t]
#:func-names [func-names #t]) #:func-names [func-names #t])
(define sexp (read-org-sexp str)) (parse-org-tbn (read-org-sexp str)
(cond #:headers headers
[(eq? func-names #t) #:func-names func-names))
(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, parse-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)))))
(module+ test (module+ test
(test-case "read-org-tbn" (test-case "read-org-tbn"
(check-equal? (read-org-tbn "((\"-\" \"x\" \"y\" \"θ\") (\"y\" -1 0 -1) (\"x\" 0 -1 -1))") (check-equal? (read-org-tbn "((\"-\" \"x\" \"y\" \"θ\") (\"y\" -1 0 -1) (\"x\" 0 -1 -1))")