networks: Use test-case and define instead of let.
This commit is contained in:
parent
48394daa7a
commit
b98d00320c
1 changed files with 151 additions and 113 deletions
264
networks.rkt
264
networks.rkt
|
@ -98,8 +98,7 @@
|
||||||
[domain-mapping/c contract?]))
|
[domain-mapping/c contract?]))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(require rackunit)
|
(require rackunit))
|
||||||
(random-seed 0))
|
|
||||||
|
|
||||||
|
|
||||||
;;; =================
|
;;; =================
|
||||||
|
@ -129,16 +128,18 @@
|
||||||
(hash-set new-s x (f s)))))
|
(hash-set new-s x (f s)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([f1 (λ (s) (let ([x1 (hash-ref s 'x1)]
|
(test-case "basic definitions"
|
||||||
[x2 (hash-ref s 'x2)])
|
(define f1 (λ (s) (let ([x1 (hash-ref s 'x1)]
|
||||||
(and x1 (not x2))))]
|
[x2 (hash-ref s 'x2)])
|
||||||
[f2 (λ (s) (let ([x2 (hash-ref s 'x2)])
|
(and x1 (not x2)))))
|
||||||
(not x2)))]
|
(define f2 (λ (s) (let ([x2 (hash-ref s 'x2)])
|
||||||
[bn (make-network-from-functions `((x1 . ,f1) (x2 . ,f2)))]
|
(not x2))))
|
||||||
[s1 (make-state '((x1 . #t) (x2 . #f)))]
|
(define bn (make-network-from-functions `((x1 . ,f1) (x2 . ,f2))))
|
||||||
[new-s1 (update bn s1 '(x2 x1))]
|
(define s1 (make-state '((x1 . #t) (x2 . #f))))
|
||||||
[s2 (make-state '((x1 . #f) (x2 . #f)))]
|
(define new-s1 (update bn s1 '(x2 x1)))
|
||||||
[new-s2 (update bn s2 '(x2))])
|
(define s2 (make-state '((x1 . #f) (x2 . #f))))
|
||||||
|
(define new-s2 (update bn s2 '(x2)))
|
||||||
|
|
||||||
(check-equal? s1 #hash((x1 . #t) (x2 . #f)))
|
(check-equal? s1 #hash((x1 . #t) (x2 . #f)))
|
||||||
(check-equal? new-s1 #hash((x1 . #t) (x2 . #t)))
|
(check-equal? new-s1 #hash((x1 . #t) (x2 . #t)))
|
||||||
(check-equal? s2 #hash((x1 . #f) (x2 . #f)))
|
(check-equal? s2 #hash((x1 . #f) (x2 . #f)))
|
||||||
|
@ -157,10 +158,11 @@
|
||||||
[(cons var 1) (cons var #t)]))))
|
[(cons var 1) (cons var #t)]))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (make-state-booleanize '((a . 0) (b . 1)))
|
(test-case "make-state, make-state-booleanize, booleanize-state"
|
||||||
(make-state '((a . #f) (b . #t))))
|
(check-equal? (make-state-booleanize '((a . 0) (b . 1)))
|
||||||
(check-equal? (booleanize-state (make-state '((a . 0) (b . 1))))
|
(make-state '((a . #f) (b . #t))))
|
||||||
(make-state '((a . #f) (b . #t)))))
|
(check-equal? (booleanize-state (make-state '((a . 0) (b . 1))))
|
||||||
|
(make-state '((a . #f) (b . #t))))))
|
||||||
|
|
||||||
;;; Booleanizes a given state: replaces 0 with #f and 1 with #t.
|
;;; Booleanizes a given state: replaces 0 with #f and 1 with #t.
|
||||||
(define (booleanize-state s)
|
(define (booleanize-state s)
|
||||||
|
@ -188,8 +190,9 @@
|
||||||
(λ (s) (eval-with s form)))
|
(λ (s) (eval-with s form)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([s (make-state '((x . #t) (y . #f)))]
|
(test-case "update-function-form->update-function"
|
||||||
[f (update-function-form->update-function '(and x y))])
|
(define s (make-state '((x . #t) (y . #f))))
|
||||||
|
(define f (update-function-form->update-function '(and x y)))
|
||||||
(check-equal? (f s) #f)))
|
(check-equal? (f s) #f)))
|
||||||
|
|
||||||
;;; Build a network from a network form.
|
;;; Build a network from a network form.
|
||||||
|
@ -198,9 +201,10 @@
|
||||||
(values x (update-function-form->update-function form))))
|
(values x (update-function-form->update-function form))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([bn (network-form->network
|
(test-case "network-form->network"
|
||||||
(make-hash '((a . (and a b)) (b . (not b)))))]
|
(define bn (network-form->network
|
||||||
[s (make-state '((a . #t) (b . #t)))])
|
(make-hash '((a . (and a b)) (b . (not b))))))
|
||||||
|
(define s (make-state '((a . #t) (b . #t))))
|
||||||
(check-equal? ((hash-ref bn 'a) s) #t)))
|
(check-equal? ((hash-ref bn 'a) s) #t)))
|
||||||
|
|
||||||
;;; Build a network from a list of pairs of forms of update functions.
|
;;; Build a network from a list of pairs of forms of update functions.
|
||||||
|
@ -208,9 +212,10 @@
|
||||||
(network-form->network (make-immutable-hash forms)))
|
(network-form->network (make-immutable-hash forms)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([bn (make-network-from-forms '((a . (and a b))
|
(test-case "make-network-from-forms"
|
||||||
(b . (not b))))]
|
(define bn (make-network-from-forms '((a . (and a b))
|
||||||
[s (make-state '((a . #t) (b . #t)))])
|
(b . (not b)))))
|
||||||
|
(define s (make-state '((a . #t) (b . #t))))
|
||||||
(check-equal? ((hash-ref bn 'a) s) #t)))
|
(check-equal? ((hash-ref bn 'a) s) #t)))
|
||||||
|
|
||||||
|
|
||||||
|
@ -240,8 +245,9 @@
|
||||||
(hash-keys nf)))
|
(hash-keys nf)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . (+ a b c))
|
(test-case "list-interactions"
|
||||||
(b . (- b c)))])
|
(define n #hash((a . (+ a b c))
|
||||||
|
(b . (- b c))))
|
||||||
(check-true (set=? (list-interactions n 'a) '(a b)))
|
(check-true (set=? (list-interactions n 'a) '(a b)))
|
||||||
(check-true (set=? (list-interactions n 'b) '(b)))))
|
(check-true (set=? (list-interactions n 'b) '(b)))))
|
||||||
|
|
||||||
|
@ -254,9 +260,10 @@
|
||||||
(for/list ([(var _) n]) (cons var (list-interactions n var))))))
|
(for/list ([(var _) n]) (cons var (list-interactions n var))))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . (+ a b c))
|
(test-case "build-interaction-graph"
|
||||||
(b . (- b c)))]
|
(define n #hash((a . (+ a b c))
|
||||||
[ig (build-interaction-graph n)])
|
(b . (- b c))))
|
||||||
|
(define ig (build-interaction-graph n))
|
||||||
(check-true (has-vertex? ig 'a))
|
(check-true (has-vertex? ig 'a))
|
||||||
(check-true (has-vertex? ig 'b))
|
(check-true (has-vertex? ig 'b))
|
||||||
(check-false (has-vertex? ig 'c))
|
(check-false (has-vertex? ig 'c))
|
||||||
|
@ -281,13 +288,14 @@
|
||||||
(cons var val))))))
|
(cons var val))))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (build-all-states #hash((a . (#t #f)) (b . (1 2 3))))
|
(test-case "build-all-states"
|
||||||
'(#hash((a . #t) (b . 1))
|
(check-equal? (build-all-states #hash((a . (#t #f)) (b . (1 2 3))))
|
||||||
#hash((a . #t) (b . 2))
|
'(#hash((a . #t) (b . 1))
|
||||||
#hash((a . #t) (b . 3))
|
#hash((a . #t) (b . 2))
|
||||||
#hash((a . #f) (b . 1))
|
#hash((a . #t) (b . 3))
|
||||||
#hash((a . #f) (b . 2))
|
#hash((a . #f) (b . 1))
|
||||||
#hash((a . #f) (b . 3)))))
|
#hash((a . #f) (b . 2))
|
||||||
|
#hash((a . #f) (b . 3))))))
|
||||||
|
|
||||||
;;; Makes a hash set mapping all variables to a single domain.
|
;;; Makes a hash set mapping all variables to a single domain.
|
||||||
(define (make-same-domains vars domain)
|
(define (make-same-domains vars domain)
|
||||||
|
@ -298,19 +306,21 @@
|
||||||
(make-same-domains vars '(#f #t)))
|
(make-same-domains vars '(#f #t)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (make-boolean-domains '(a b))
|
(test-case "make-same-domains, make-boolean-domains"
|
||||||
#hash((a . (#f #t)) (b . (#f #t)))))
|
(check-equal? (make-boolean-domains '(a b))
|
||||||
|
#hash((a . (#f #t)) (b . (#f #t))))))
|
||||||
|
|
||||||
;;; Builds all boolean states possible over a given set of variables.
|
;;; Builds all boolean states possible over a given set of variables.
|
||||||
(define (build-all-boolean-states vars)
|
(define (build-all-boolean-states vars)
|
||||||
(build-all-states (make-boolean-domains vars)))
|
(build-all-states (make-boolean-domains vars)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (build-all-boolean-states '(a b))
|
(test-case "build-all-boolean-states"
|
||||||
'(#hash((a . #f) (b . #f))
|
(check-equal? (build-all-boolean-states '(a b))
|
||||||
#hash((a . #f) (b . #t))
|
'(#hash((a . #f) (b . #f))
|
||||||
#hash((a . #t) (b . #f))
|
#hash((a . #f) (b . #t))
|
||||||
#hash((a . #t) (b . #t)))))
|
#hash((a . #t) (b . #f))
|
||||||
|
#hash((a . #t) (b . #t))))))
|
||||||
|
|
||||||
;;; Given two interacting variables of a network and the domains
|
;;; Given two interacting variables of a network and the domains
|
||||||
;;; of the variables, returns '+ if the interaction is monotonously
|
;;; of the variables, returns '+ if the interaction is monotonously
|
||||||
|
@ -358,8 +368,9 @@
|
||||||
[else '0])))
|
[else '0])))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . (not b)) (b . a))]
|
(test-case "get-interaction-sign"
|
||||||
[doms (make-boolean-domains '(a b))])
|
(define n #hash((a . (not b)) (b . a)))
|
||||||
|
(define doms (make-boolean-domains '(a b)))
|
||||||
(check-equal? (get-interaction-sign (network-form->network n) doms 'a 'b) '+)
|
(check-equal? (get-interaction-sign (network-form->network n) doms 'a 'b) '+)
|
||||||
(check-equal? (get-interaction-sign (network-form->network n) doms 'b 'a) '-)))
|
(check-equal? (get-interaction-sign (network-form->network n) doms 'b 'a) '-)))
|
||||||
|
|
||||||
|
@ -388,9 +399,10 @@
|
||||||
sig))
|
sig))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . (not b)) (b . a))]
|
(test-case "build-signed-interaction-graph/form"
|
||||||
[doms (make-boolean-domains '(a b))]
|
(define n #hash((a . (not b)) (b . a)))
|
||||||
[sig1 (build-signed-interaction-graph/form n doms)])
|
(define doms (make-boolean-domains '(a b)))
|
||||||
|
(define sig1 (build-signed-interaction-graph/form n doms))
|
||||||
(check-true (has-vertex? sig1 'a))
|
(check-true (has-vertex? sig1 'a))
|
||||||
(check-true (has-vertex? sig1 'b))
|
(check-true (has-vertex? sig1 'b))
|
||||||
(check-false (has-vertex? sig1 'c))
|
(check-false (has-vertex? sig1 'c))
|
||||||
|
@ -413,8 +425,9 @@
|
||||||
(make-boolean-domains (hash-keys network-form))))
|
(make-boolean-domains (hash-keys network-form))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . (not b)) (b . a))]
|
(test-case "build-boolean-signed-interaction-graph/form"
|
||||||
[sig2 (build-boolean-signed-interaction-graph/form n)])
|
(define n #hash((a . (not b)) (b . a)))
|
||||||
|
(define sig2 (build-boolean-signed-interaction-graph/form n))
|
||||||
(check-true (has-vertex? sig2 'a))
|
(check-true (has-vertex? sig2 'a))
|
||||||
(check-true (has-vertex? sig2 'b))
|
(check-true (has-vertex? sig2 'b))
|
||||||
(check-false (has-vertex? sig2 'c))
|
(check-false (has-vertex? sig2 'c))
|
||||||
|
@ -466,8 +479,9 @@
|
||||||
(build-signed-interaction-graph network (make-boolean-domains (hash-keys network))))
|
(build-signed-interaction-graph network (make-boolean-domains (hash-keys network))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . (not b)) (b . a))]
|
(test-case "build-signed-interaction-graph, build-boolean-signed-interaction-graph"
|
||||||
[sig3 (build-boolean-signed-interaction-graph (network-form->network n))])
|
(define n #hash((a . (not b)) (b . a)))
|
||||||
|
(define sig3 (build-boolean-signed-interaction-graph (network-form->network n)))
|
||||||
(check-true (has-vertex? sig3 'a))
|
(check-true (has-vertex? sig3 'a))
|
||||||
(check-true (has-vertex? sig3 'b))
|
(check-true (has-vertex? sig3 'b))
|
||||||
(check-equal? (edge-weight sig3 'a 'a) '+)
|
(check-equal? (edge-weight sig3 'a 'a) '+)
|
||||||
|
@ -476,12 +490,13 @@
|
||||||
(check-equal? (edge-weight sig3 'b 'a) '-)))
|
(check-equal? (edge-weight sig3 'b 'a) '-)))
|
||||||
|
|
||||||
;;; Interaction graphs for networks without interactions must still
|
;;; Interaction graphs for networks without interactions must still
|
||||||
;;; contain all networks.
|
;;; contain all nodes.
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n #hash((a . #t) (b . #t))]
|
(test-case "Interaction must graphs always contain all nodes."
|
||||||
[ig (build-interaction-graph n)]
|
(define n #hash((a . #t) (b . #t)))
|
||||||
[sig-nf (build-boolean-signed-interaction-graph/form n)]
|
(define ig (build-interaction-graph n))
|
||||||
[sig (build-boolean-signed-interaction-graph (network-form->network n))])
|
(define sig-nf (build-boolean-signed-interaction-graph/form n))
|
||||||
|
(define sig (build-boolean-signed-interaction-graph (network-form->network n)))
|
||||||
(check-equal? (get-vertices ig) '(b a))
|
(check-equal? (get-vertices ig) '(b a))
|
||||||
(check-true (empty? (get-edges ig)))
|
(check-true (empty? (get-edges ig)))
|
||||||
(check-equal? (get-vertices sig-nf) '(b a))
|
(check-equal? (get-vertices sig-nf) '(b a))
|
||||||
|
@ -520,7 +535,8 @@
|
||||||
(define (make-syn vars) (set (list->set vars)))
|
(define (make-syn vars) (set (list->set vars)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([vars '(a b c)])
|
(test-case "make-asyn, make-syn"
|
||||||
|
(define vars '(a b c))
|
||||||
(check-equal? (make-asyn vars) (set (set 'a) (set 'b) (set 'c)))
|
(check-equal? (make-asyn vars) (set (set 'a) (set 'b) (set 'c)))
|
||||||
(check-equal? (make-syn vars) (set (set 'a 'b 'c)))))
|
(check-equal? (make-syn vars) (set (set 'a 'b 'c)))))
|
||||||
|
|
||||||
|
@ -538,9 +554,10 @@
|
||||||
(make-dynamics-from-func network make-syn))
|
(make-dynamics-from-func network make-syn))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n (network-form->network #hash((a . (not a)) (b . b)))]
|
(test-case "make-asyn-dynamics, make-syn-dynamics"
|
||||||
[asyn (make-asyn-dynamics n)]
|
(define n (network-form->network #hash((a . (not a)) (b . b))))
|
||||||
[syn (make-syn-dynamics n)])
|
(define asyn (make-asyn-dynamics n))
|
||||||
|
(define syn (make-syn-dynamics n))
|
||||||
(check-equal? (dynamics-network asyn) n)
|
(check-equal? (dynamics-network asyn) n)
|
||||||
(check-equal? (dynamics-mode asyn) (set (set 'a) (set 'b)))
|
(check-equal? (dynamics-mode asyn) (set (set 'a) (set 'b)))
|
||||||
(check-equal? (dynamics-network syn) n)
|
(check-equal? (dynamics-network syn) n)
|
||||||
|
@ -559,8 +576,9 @@
|
||||||
(string-join (hash-map s (λ (key val) (format "~a:~a" key val)) #t)))
|
(string-join (hash-map s (λ (key val) (format "~a:~a" key val)) #t)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (pretty-print-state (make-state '((a . #f) (b . 3) (c . 4))))
|
(test-case "pretty-print-state"
|
||||||
"a:#f b:3 c:4"))
|
(check-equal? (pretty-print-state (make-state '((a . #f) (b . 3) (c . 4))))
|
||||||
|
"a:#f b:3 c:4")))
|
||||||
|
|
||||||
;;; Converts any non-#f value to 1 and #f to 0.
|
;;; Converts any non-#f value to 1 and #f to 0.
|
||||||
(define (any->boolean x) (if x 1 0))
|
(define (any->boolean x) (if x 1 0))
|
||||||
|
@ -570,9 +588,10 @@
|
||||||
(string-join (hash-map s (λ (key val) (format "~a:~a" key (any->boolean val))) #t)))
|
(string-join (hash-map s (λ (key val) (format "~a:~a" key (any->boolean val))) #t)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal?
|
(test-case "pretty-print-boolean-state"
|
||||||
(pretty-print-boolean-state (make-state '((a . #f) (b . #t) (c . #t))))
|
(check-equal?
|
||||||
"a:0 b:1 c:1"))
|
(pretty-print-boolean-state (make-state '((a . #f) (b . #t) (c . #t))))
|
||||||
|
"a:0 b:1 c:1")))
|
||||||
|
|
||||||
;;; Given a state graph and a pretty-printer for states build a new
|
;;; Given a state graph and a pretty-printer for states build a new
|
||||||
;;; state graph with pretty-printed vertices and edges.
|
;;; state graph with pretty-printed vertices and edges.
|
||||||
|
@ -606,18 +625,19 @@
|
||||||
(list->set (build-all-boolean-states (hash-keys (dynamics-network dyn))))))
|
(list->set (build-all-boolean-states (hash-keys (dynamics-network dyn))))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n (network-form->network #hash((a . (not a)) (b . b)))]
|
(test-case "Dynamics of networks"
|
||||||
[asyn (make-asyn-dynamics n)]
|
(define n (network-form->network #hash((a . (not a)) (b . b))))
|
||||||
[syn (make-syn-dynamics n)]
|
(define asyn (make-asyn-dynamics n))
|
||||||
[s (make-state '((a . #t) (b . #f)))]
|
(define syn (make-syn-dynamics n))
|
||||||
[ss (set (make-state '((a . #t) (b . #t)))
|
(define s (make-state '((a . #t) (b . #f))))
|
||||||
(make-state '((a . #f) (b . #t))))]
|
(define ss (set (make-state '((a . #t) (b . #t)))
|
||||||
[gr1 (dds-build-n-step-state-graph asyn (set s) 1)]
|
(make-state '((a . #f) (b . #t)))))
|
||||||
[gr-full (dds-build-state-graph asyn (set s))]
|
(define gr1 (dds-build-n-step-state-graph asyn (set s) 1))
|
||||||
[gr-full-pp (pretty-print-state-graph gr-full)]
|
(define gr-full (dds-build-state-graph asyn (set s)))
|
||||||
[gr-full-ppb (pretty-print-boolean-state-graph gr-full)]
|
(define gr-full-pp (pretty-print-state-graph gr-full))
|
||||||
[gr-complete-bool (build-full-boolean-state-graph asyn)]
|
(define gr-full-ppb (pretty-print-boolean-state-graph gr-full))
|
||||||
[gr-complete-bool-ann (build-full-boolean-state-graph-annotated asyn)])
|
(define gr-complete-bool (build-full-boolean-state-graph asyn))
|
||||||
|
(define gr-complete-bool-ann (build-full-boolean-state-graph-annotated asyn))
|
||||||
(check-equal? (dds-step-one asyn s) (set (make-state '((a . #f) (b . #f)))
|
(check-equal? (dds-step-one asyn s) (set (make-state '((a . #f) (b . #f)))
|
||||||
(make-state '((a . #t) (b . #f)))))
|
(make-state '((a . #t) (b . #f)))))
|
||||||
(check-equal? (dds-step-one-annotated asyn s)
|
(check-equal? (dds-step-one-annotated asyn s)
|
||||||
|
@ -706,15 +726,17 @@
|
||||||
(append xs (list (apply func xs)))))
|
(append xs (list (apply func xs)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (tabulate/domain-list (λ (x y) (and x y)) '((#f #t) (#f #t)))
|
(test-case "tabulate/domain-list"
|
||||||
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))
|
(check-equal? (tabulate/domain-list (λ (x y) (and x y)) '((#f #t) (#f #t)))
|
||||||
|
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
|
||||||
|
|
||||||
;;; Like tabulate, but the domains are given as a rest argument.
|
;;; Like tabulate, but the domains are given as a rest argument.
|
||||||
(define (tabulate func . doms) (tabulate/domain-list func doms))
|
(define (tabulate func . doms) (tabulate/domain-list func doms))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (tabulate (λ (x y) (and x y)) '(#f #t) '(#f #t))
|
(test-case "tabulate"
|
||||||
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))
|
(check-equal? (tabulate (λ (x y) (and x y)) '(#f #t) '(#f #t))
|
||||||
|
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
|
||||||
|
|
||||||
;;; Like tabulate, but assumes the domains of all variables of the
|
;;; Like tabulate, but assumes the domains of all variables of the
|
||||||
;;; function are Boolean. func must have a fixed arity. It is an
|
;;; function are Boolean. func must have a fixed arity. It is an
|
||||||
|
@ -723,8 +745,9 @@
|
||||||
(tabulate/domain-list func (make-list (procedure-arity func) '(#f #t))))
|
(tabulate/domain-list func (make-list (procedure-arity func) '(#f #t))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (tabulate/boolean (lambda (x y) (and x y)))
|
(test-case "tabulate/boolean"
|
||||||
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))
|
(check-equal? (tabulate/boolean (lambda (x y) (and x y)))
|
||||||
|
'((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))
|
||||||
|
|
||||||
;;; Like tabulate, but supposes that the function works on states.
|
;;; Like tabulate, but supposes that the function works on states.
|
||||||
;;;
|
;;;
|
||||||
|
@ -749,7 +772,8 @@
|
||||||
(tabulate-state func (make-boolean-domains args) #:headers headers))
|
(tabulate-state func (make-boolean-domains args) #:headers headers))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([func (λ (st) (not (hash-ref st 'a)))])
|
(test-case "tabulate-state/boolean"
|
||||||
|
(define func (λ (st) (not (hash-ref st 'a))))
|
||||||
(check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f)))))
|
(check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f)))))
|
||||||
|
|
||||||
;;; Tabulates a given network.
|
;;; Tabulates a given network.
|
||||||
|
@ -779,7 +803,8 @@
|
||||||
#:headers headers))
|
#:headers headers))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([bn (network-form->network #hash((a . (not a)) (b . b)))])
|
(test-case "tabulate-boolean-network"
|
||||||
|
(define bn (network-form->network #hash((a . (not a)) (b . b))))
|
||||||
(check-equal? (tabulate-boolean-network bn)
|
(check-equal? (tabulate-boolean-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-boolean-network bn #:headers #f)
|
||||||
|
@ -807,7 +832,8 @@
|
||||||
(λ args (func args))))
|
(λ args (func args))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([negation (table->function '((#t #f) (#f #t)))])
|
(test-case "table->function"
|
||||||
|
(define negation (table->function '((#t #f) (#f #t))))
|
||||||
(check-true (negation #f))
|
(check-true (negation #f))
|
||||||
(check-false (negation #t))))
|
(check-false (negation #t))))
|
||||||
|
|
||||||
|
@ -820,7 +846,8 @@
|
||||||
(values x (car fx))))))
|
(values x (car fx))))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([negation/list (table->function/list '((#t #f) (#f #t)))])
|
(test-case "table->function/list"
|
||||||
|
(define negation/list (table->function/list '((#t #f) (#f #t))))
|
||||||
(check-true (negation/list '(#f)))
|
(check-true (negation/list '(#f)))
|
||||||
(check-false (negation/list '(#t)))))
|
(check-false (negation/list '(#t)))))
|
||||||
|
|
||||||
|
@ -862,13 +889,15 @@
|
||||||
(make-network-from-functions (map cons var-names funcs)))
|
(make-network-from-functions (map cons var-names funcs)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let* ([n (table->network '((x1 x2 f1 f2)
|
(test-case "table->network"
|
||||||
(#f #f #f #f)
|
(define n (table->network '((x1 x2 f1 f2)
|
||||||
(#f #t #f #t)
|
(#f #f #f #f)
|
||||||
(#t #f #t #f)
|
(#f #t #f #t)
|
||||||
(#t #t #t #t)))]
|
(#t #f #t #f)
|
||||||
[f1 (hash-ref n 'x1)]
|
(#t #t #t #t))))
|
||||||
[f2 (hash-ref n 'x2)])
|
(define f1 (hash-ref n 'x1))
|
||||||
|
(define f2 (hash-ref n 'x2))
|
||||||
|
|
||||||
(check-false (f1 (make-state '((x1 . #f) (x2 . #f)))))
|
(check-false (f1 (make-state '((x1 . #f) (x2 . #f)))))
|
||||||
(check-false (f1 (make-state '((x1 . #f) (x2 . #t)))))
|
(check-false (f1 (make-state '((x1 . #f) (x2 . #t)))))
|
||||||
(check-true (f1 (make-state '((x1 . #t) (x2 . #f)))))
|
(check-true (f1 (make-state '((x1 . #t) (x2 . #f)))))
|
||||||
|
@ -883,14 +912,16 @@
|
||||||
(define (boolean-power n) (apply cartesian-product (make-list n '(#f #t))))
|
(define (boolean-power n) (apply cartesian-product (make-list n '(#f #t))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t))))
|
(test-case "boolean-power"
|
||||||
|
(check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t)))))
|
||||||
|
|
||||||
;;; Like boolean-power, but returns a stream whose elements the
|
;;; Like boolean-power, but returns a stream whose elements the
|
||||||
;;; elements of the Cartesian power.
|
;;; elements of the Cartesian power.
|
||||||
(define (boolean-power/stream n) (apply cartesian-product/stream (make-list n '(#f #t))))
|
(define (boolean-power/stream n) (apply cartesian-product/stream (make-list n '(#f #t))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (stream->list (boolean-power/stream 2)) '((#f #f) (#f #t) (#t #f) (#t #t))))
|
(test-case "boolean-power/stream"
|
||||||
|
(check-equal? (stream->list (boolean-power/stream 2)) '((#f #f) (#f #t) (#t #f) (#t #t)))))
|
||||||
|
|
||||||
;;; Returns the stream of the truth tables of all Boolean functions of
|
;;; Returns the stream of the truth tables of all Boolean functions of
|
||||||
;;; a given arity.
|
;;; a given arity.
|
||||||
|
@ -910,7 +941,8 @@
|
||||||
(stream-map table->function (enumerate-boolean-tables n)))
|
(stream-map table->function (enumerate-boolean-tables n)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([f1 (stream-first (enumerate-boolean-functions 1))])
|
(test-case "enumerate-boolean-tables"
|
||||||
|
(define f1 (stream-first (enumerate-boolean-functions 1)))
|
||||||
(check-false (f1 #f))
|
(check-false (f1 #f))
|
||||||
(check-false (f1 #t))))
|
(check-false (f1 #t))))
|
||||||
|
|
||||||
|
@ -924,7 +956,8 @@
|
||||||
(stream-map table->function/list (enumerate-boolean-tables n)))
|
(stream-map table->function/list (enumerate-boolean-tables n)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([f1/list (stream-first (enumerate-boolean-functions/list 1))])
|
(test-case "enumerate-boolean-functions/list"
|
||||||
|
(define f1/list (stream-first (enumerate-boolean-functions/list 1)))
|
||||||
(check-false (f1/list '(#f)))
|
(check-false (f1/list '(#f)))
|
||||||
(check-false (f1/list '(#t)))))
|
(check-false (f1/list '(#t)))))
|
||||||
|
|
||||||
|
@ -942,13 +975,16 @@
|
||||||
(append i (list (num->bool o)))))
|
(append i (list (num->bool o)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f))))
|
(test-case "random-boolean-table"
|
||||||
|
(random-seed 0)
|
||||||
|
(check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f)))))
|
||||||
|
|
||||||
;;; Generates a random Boolean function of arity n.
|
;;; Generates a random Boolean function of arity n.
|
||||||
(define random-boolean-function (compose table->function random-boolean-table))
|
(define random-boolean-function (compose table->function random-boolean-table))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([f (random-boolean-function 2)])
|
(test-case "random-boolean-function"
|
||||||
|
(define f (random-boolean-function 2))
|
||||||
(check-true (f #f #f)) (check-false (f #f #t))
|
(check-true (f #f #f)) (check-false (f #f #t))
|
||||||
(check-true (f #t #f)) (check-false (f #t #t))))
|
(check-true (f #t #f)) (check-false (f #t #t))))
|
||||||
|
|
||||||
|
@ -957,7 +993,8 @@
|
||||||
(define random-boolean-function/list (compose table->function/list random-boolean-table))
|
(define random-boolean-function/list (compose table->function/list random-boolean-table))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ([f (random-boolean-function/list 2)])
|
(test-case "random-boolean-function/list"
|
||||||
|
(define f (random-boolean-function/list 2))
|
||||||
(check-false (f '(#f #f))) (check-true (f '(#f #t)))
|
(check-false (f '(#f #f))) (check-true (f '(#f #t)))
|
||||||
(check-true (f '(#t #f))) (check-false (f '(#t #t)))))
|
(check-true (f '(#t #f))) (check-false (f '(#t #t)))))
|
||||||
|
|
||||||
|
@ -974,23 +1011,24 @@
|
||||||
(random-function/state (make-boolean-domains args) '(#f #t)))
|
(random-function/state (make-boolean-domains args) '(#f #t)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-begin
|
(test-case "random-boolean-function/state"
|
||||||
|
(random-seed 0)
|
||||||
(define f (random-boolean-function/state '(x1 x2)))
|
(define f (random-boolean-function/state '(x1 x2)))
|
||||||
(check-equal? (tabulate-state/boolean f '(x1 x2))
|
(check-equal? (tabulate-state/boolean f '(x1 x2))
|
||||||
'((x1 x2 f) (#f #f #f) (#f #t #f) (#t #f #t) (#t #t #f)))
|
'((x1 x2 f) (#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t)))
|
||||||
(check-equal? (tabulate-state/boolean f '(x1 x2) #:headers #f)
|
(check-equal? (tabulate-state/boolean f '(x1 x2) #:headers #f)
|
||||||
'((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #f)))
|
'((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t)))
|
||||||
(define bn (random-boolean-network/vars 3))
|
(define bn (random-boolean-network/vars 3))
|
||||||
(check-equal? (tabulate-boolean-network bn)
|
(check-equal? (tabulate-boolean-network bn)
|
||||||
'((x0 x1 x2 f-x0 f-x1 f-x2)
|
'((x0 x1 x2 f-x0 f-x1 f-x2)
|
||||||
(#f #f #f #t #f #f)
|
(#f #f #f #f #t #f)
|
||||||
(#f #f #t #t #t #f)
|
(#f #f #t #t #f #f)
|
||||||
(#f #t #f #f #t #f)
|
(#f #t #f #f #t #t)
|
||||||
(#f #t #t #t #f #t)
|
(#f #t #t #t #f #f)
|
||||||
(#t #f #f #t #f #f)
|
(#t #f #f #t #f #t)
|
||||||
(#t #f #t #f #t #t)
|
(#t #f #t #f #f #t)
|
||||||
(#t #t #f #t #f #f)
|
(#t #t #f #f #f #f)
|
||||||
(#t #t #t #f #t #t)))))
|
(#t #t #t #t #t #t)))))
|
||||||
|
|
||||||
;;; Generates a random network from the given domain mapping.
|
;;; Generates a random network from the given domain mapping.
|
||||||
(define (random-network domains)
|
(define (random-network domains)
|
||||||
|
|
Loading…
Reference in a new issue