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

networks: Fix tabulating functions and networks.

Browse source
This commit is contained in:
Sergiu Ivanov 2020-11-22 21:41:06 +01:00
parent fd651ba4cc
commit 3a2453c92e
1 changed files with 8 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
networks.rkt
View file

@ -78,9 +78,7 @@
(listof (listof any/c)))] (listof (listof any/c)))]
[tabulate-state*/boolean (->* ((non-empty-listof procedure?) (listof variable?)) (#:headers boolean?) [tabulate-state*/boolean (->* ((non-empty-listof procedure?) (listof variable?)) (#:headers boolean?)
(listof (listof any/c)))] (listof (listof any/c)))]
[tabulate-network (->* (network? domain-mapping/c) (#:headers boolean?) [tabulate-network (->* (network?) (#:headers boolean?)
(listof (listof any/c)))]
[tabulate-boolean-network (->* (network?) (#:headers boolean?)
(listof (listof any/c)))] (listof (listof any/c)))]
[table->network (->* ((listof (*list/c any/c any/c))) (#:headers boolean?) network?)] [table->network (->* ((listof (*list/c any/c any/c))) (#:headers boolean?) network?)]
[random-function/state (domain-mapping/c generic-set? . -> . procedure?)] [random-function/state (domain-mapping/c generic-set? . -> . procedure?)]
@ -921,13 +919,13 @@
;;; network. If headers is #t, prepends a list of variable names and ;;; network. If headers is #t, prepends a list of variable names and
;;; update functions (f-x, where x is the name of the corresponding ;;; update functions (f-x, where x is the name of the corresponding
;;; variable) to the result. ;;; variable) to the result.
(define (tabulate-network network domains #:headers [headers #t]) (define (tabulate-network network #:headers [headers #t])
;; I use hash-map with try-order? set to #t to ask the hash table to ;; I use hash-map with try-order? set to #t to ask the hash table to
;; sort the keys for me. ;; sort the keys for me.
(define-values (vars funcs) (for/lists (l1 l2) (define-values (vars funcs) (for/lists (l1 l2)
([pair (hash-map network cons #t)]) ([pair (hash-map (network-functions network) cons #t)])
(values (car pair) (cdr pair)))) (values (car pair) (cdr pair))))
(define tab (tabulate-state* funcs domains #:headers headers)) (define tab (tabulate-state* funcs (network-domains network) #:headers headers))
(cond (cond
[headers [headers
;; Replace the names of the functions tabulate-state* gave us by ;; Replace the names of the functions tabulate-state* gave us by
@ -938,17 +936,12 @@
(cons (append (take hdrs (length vars)) fnames) vals)])] (cons (append (take hdrs (length vars)) fnames) vals)])]
[else tab])) [else tab]))
;;; Like tabulate-network, but assumes all the variables are Boolean.
(define (tabulate-boolean-network bn #:headers [headers #t])
(tabulate-network bn (make-boolean-domains (hash-map bn (λ (x y) x) #t))
#:headers headers))
(module+ test (module+ test
(test-case "tabulate-boolean-network" (test-case "tabulate-network"
(define bn (network-form->network #hash((a . (not a)) (b . b)))) (define bn (forms->boolean-network #hash((a . (not a)) (b . b))))
(check-equal? (tabulate-boolean-network bn) (check-equal? (tabulate-network bn)
'((a b f-a f-b) (#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t))) '((a b f-a f-b) (#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t)))
(check-equal? (tabulate-boolean-network bn #:headers #f) (check-equal? (tabulate-network bn #:headers #f)
'((#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t))))) '((#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t)))))