diff --git a/networks-tests.rkt b/networks-tests.rkt deleted file mode 100644 index dd7fdac..0000000 --- a/networks-tests.rkt +++ /dev/null @@ -1,294 +0,0 @@ -#lang racket - -;;; Tests for dds/networks. - -(require rackunit graph "networks.rkt") - -;;; This test case sets up the following Boolean network: -;;; x1 = x1 AND NOT x2 -;;; x2 = NOT x2 -(test-case "Basic definitions" - (let* ([f1 (λ (s) - (let ([x1 (hash-ref s 'x1)] - [x2 (hash-ref s 'x2)]) - (and x1 (not x2))))] - [f2 (λ (s) - (let ([x2 (hash-ref s 'x2)]) - (not x2)))] - [bn (make-network-from-functions `((x1 . ,f1) (x2 . ,f2)))]) - - (test-case "States" - (check-equal? (make-state-booleanize '((a . 0) (b . 1))) - (make-state '((a . #f) (b . #t)))) - (check-equal? (booleanize-state (make-state '((a . 0) (b . 1)))) - (make-state '((a . #f) (b . #t))))) - - (test-case "One-step syncronous update" - (let* ([s (make-state '((x1 . #t) (x2 . #f)))] - [new-s (update bn s '(x2 x1))]) - (check-equal? s #hash((x1 . #t) (x2 . #f))) - (check-equal? new-s #hash((x1 . #t) (x2 . #t))))) - - (test-case "One-step asynchronous update" - (let* ([s (make-state '((x1 . #f) (x2 . #f)))] - [new-s (update bn s '(x2 x1))]) - (check-equal? s #hash((x1 . #f) (x2 . #f))) - (check-equal? new-s #hash((x1 . #f) (x2 . #t))))))) - -(test-case "Syntactic description of Boolean networks" - (let ([s (make-state '((x . #t) (y . #f)))] - [f (update-function-form->update-function '(and x y))]) - (check-equal? (f s) #f)) - (let ([bn1 (network-form->network (make-hash '((a . (and a b)) (b . (not b)))))] - [bn2 (make-network-from-forms '((a . (and a b)) - (b . (not b))))] - [bn3 (network-form->network #hash((a . (and a b)) - (b . (not b))))] - [s (make-state '((a . #t) (b . #t)))]) - (check-equal? ((hash-ref bn1 'a) s) #t) - (check-equal? ((hash-ref bn2 'a) s) #t) - (check-equal? ((hash-ref bn3 'a) s) #t))) - -(test-case "Inferring interaction graphs" - (let* ([n #hash((a . (+ a b c)) - (b . (- b c)))] - [ig (build-interaction-graph n)]) - (check-true (set=? (list-interactions n 'a) '(a b))) - (check-true (set=? (list-interactions n 'b) '(b))) - (check-true (has-vertex? ig 'a)) - (check-true (has-vertex? ig 'b)) - (check-false (has-vertex? ig 'c)) - (check-true (has-edge? ig 'a 'a)) - (check-true (has-edge? ig 'b 'a)) - (check-true (has-edge? ig 'b 'b)) - (check-false (has-edge? ig 'c 'b)) - (check-false (has-edge? ig 'c 'a))) - - (check-equal? (build-all-states #hash((a . (#t #f)) (b . (1 2 3)))) - '(#hash((a . #t) (b . 1)) - #hash((a . #t) (b . 2)) - #hash((a . #t) (b . 3)) - #hash((a . #f) (b . 1)) - #hash((a . #f) (b . 2)) - #hash((a . #f) (b . 3)))) - (check-equal? (make-boolean-domains '(a b)) - #hash((a . (#f #t)) (b . (#f #t)))) - (check-equal? (build-all-boolean-states '(a b)) - '(#hash((a . #f) (b . #f)) - #hash((a . #f) (b . #t)) - #hash((a . #t) (b . #f)) - #hash((a . #t) (b . #t)))) - - (let* ([n #hash((a . (not b)) (b . a))] - [doms (make-boolean-domains '(a b))] - [sig1 (build-signed-interaction-graph/form n doms)] - [sig2 (build-boolean-signed-interaction-graph/form n)] - [sig3 (build-boolean-signed-interaction-graph (network-form->network n))]) - (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-true (has-vertex? sig1 'a)) - (check-true (has-vertex? sig1 'b)) - (check-false (has-vertex? sig1 'c)) - (check-false (has-edge? sig1 'a 'a)) - (check-true (has-edge? sig1 'b 'a)) - (check-false (has-edge? sig1 'b 'b)) - (check-false (has-edge? sig1 'c 'b)) - (check-false (has-edge? sig1 'c 'a)) - (check-equal? (edge-weight sig1 'a 'b) '+) - (check-equal? (edge-weight sig1 'b 'a) '-) - - (check-true (has-vertex? sig2 'a)) - (check-true (has-vertex? sig2 'b)) - (check-false (has-vertex? sig2 'c)) - (check-false (has-edge? sig2 'a 'a)) - (check-true (has-edge? sig2 'b 'a)) - (check-false (has-edge? sig2 'b 'b)) - (check-false (has-edge? sig2 'c 'b)) - (check-false (has-edge? sig2 'c 'a)) - (check-equal? (edge-weight sig2 'a 'b) '+) - (check-equal? (edge-weight sig2 'b 'a) '-) - - (check-true (has-vertex? sig3 'a)) - (check-true (has-vertex? sig3 'b)) - (check-equal? (edge-weight sig3 'a 'a) '+) - (check-equal? (edge-weight sig3 'b 'b) '+) - (check-equal? (edge-weight sig3 'a 'b) '+) - (check-equal? (edge-weight sig3 'b 'a) '-)) - (let* ([n #hash((a . #t) (b . #t))] - [ig (build-interaction-graph n)] - [sig-nf (build-boolean-signed-interaction-graph/form n)] - [sig (build-boolean-signed-interaction-graph (network-form->network n))]) - (check-equal? (get-vertices ig) '(b a)) - (check-true (empty? (get-edges ig))) - (check-equal? (get-vertices sig-nf) '(b a)) - (check-true (empty? (get-edges sig-nf))) - (check-equal? (get-vertices sig) '(b a)))) - -(test-case "Dynamics of networks" - (check-equal? (pretty-print-state (make-state '((a . #f) (b . 3) (c . 4)))) "a:#f b:3 c:4") - (check-equal? (pretty-print-boolean-state (make-state '((a . #f) (b . #t) (c . #t)))) "a:0 b:1 c:1") - (let ([vars '(a b c)]) - (check-equal? (make-asyn vars) (set (set 'a) (set 'b) (set 'c))) - (check-equal? (make-syn vars) (set (set 'a 'b 'c)))) - (let* ([n (network-form->network #hash((a . (not a)) (b . b)))] - [asyn (make-asyn-dynamics n)] - [syn (make-syn-dynamics n)]) - (check-equal? (dynamics-network asyn) n) - (check-equal? (dynamics-mode asyn) (set (set 'a) (set 'b))) - (check-equal? (dynamics-network syn) n) - (check-equal? (dynamics-mode syn) (set (set 'a 'b)))) - (let* ([n (network-form->network #hash((a . (not a)) (b . b)))] - [asyn (make-asyn-dynamics n)] - [syn (make-syn-dynamics n)] - [s (make-state '((a . #t) (b . #f)))] - [ss (set (make-state '((a . #t) (b . #t))) - (make-state '((a . #f) (b . #t))))] - [gr1 (dds-build-n-step-state-graph asyn (set s) 1)] - [gr-full (dds-build-state-graph asyn (set s))] - [gr-full-pp (pretty-print-state-graph gr-full)] - [gr-full-ppb (pretty-print-boolean-state-graph gr-full)] - [gr-complete-bool (build-full-boolean-state-graph asyn)] - [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))) - (make-state '((a . #t) (b . #f))))) - (check-equal? (dds-step-one-annotated asyn s) - (set (cons (set 'b) '#hash((a . #t) (b . #f))) - (cons (set 'a) '#hash((a . #f) (b . #f))))) - (check-equal? (dds-step-one syn s) (set (make-state '((a . #f) (b . #f))))) - (check-equal? (dds-step asyn ss) - (set (make-state '((a . #f) (b . #t))) - (make-state '((a . #t) (b . #t))))) - (check-true (has-vertex? gr1 #hash((a . #t) (b . #f)))) - (check-true (has-vertex? gr1 #hash((a . #f) (b . #f)))) - (check-false (has-vertex? gr1 #hash((a . #t) (b . #t)))) - (check-true (has-edge? gr1 #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))) - (check-true (has-edge? gr1 #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))) - (check-false (has-edge? gr1 #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))) - - (check-true (has-vertex? gr-full #hash((a . #t) (b . #f)))) - (check-true (has-vertex? gr-full #hash((a . #f) (b . #f)))) - (check-false (has-vertex? gr-full #hash((a . #t) (b . #t)))) - (check-true (has-edge? gr-full #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))) - (check-true (has-edge? gr-full #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))) - (check-true (has-edge? gr-full #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))) - (check-true (has-edge? gr-full #hash((a . #f) (b . #f)) #hash((a . #f) (b . #f)))) - - (check-true (has-vertex? gr-full-pp "a:#f b:#f")) - (check-true (has-vertex? gr-full-pp "a:#t b:#f")) - (check-true (has-vertex? gr-full-ppb "a:0 b:0")) - (check-true (has-vertex? gr-full-ppb "a:1 b:0")) - - (check-equal? (get-edges gr-complete-bool) - '((#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))) - (#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))) - (#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))) - (#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))) - (#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t))) - (#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t))) - (#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t))) - (#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t))))) - - (check-equal? (get-edges gr-complete-bool-ann) - '((#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))) - (#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))) - (#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))) - (#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))) - (#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t))) - (#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t))) - (#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t))) - (#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t))))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))) - (set (set 'a))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))) - (set (set 'b))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))) - (set (set 'b))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))) - (set (set 'a))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #t) (b . #t)) #hash((a . #f) (b . #t))) - (set (set 'a))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #t) (b . #t)) #hash((a . #t) (b . #t))) - (set (set 'b))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #f) (b . #t)) #hash((a . #f) (b . #t))) - (set (set 'b))) - (check-equal? (edge-weight gr-complete-bool-ann - #hash((a . #f) (b . #t)) #hash((a . #t) (b . #t))) - (set (set 'a))))) - -(test-case "Tabulating functions and networks" - (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))) - (check-equal? (tabulate (λ (x y) (and x y)) '(#f #t) '(#f #t)) - '((#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))) - (let ([func (λ (st) (not (hash-ref st 'a)))]) - (check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f)))) - (let ([bn (network-form->network #hash((a . (not a)) (b . b)))]) - (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))) - (check-equal? (tabulate-boolean-network bn #:headers #f) - '((#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t))))) - -(test-case "Constructing functions and networks" - (check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t))) - (check-equal? (stream->list (boolean-power/stream 2)) '((#f #f) (#f #t) (#t #f) (#t #t))) - (let ([negation (table->function '((#t #f) (#f #t)))] - [negation/list (table->function/list '((#t #f) (#f #t)))]) - (check-true (negation #f)) (check-false (negation #t)) - (check-true (negation/list '(#f))) (check-false (negation/list '(#t)))) - (let* ([n (table->network '((x1 x2 f1 f2) - (#f #f #f #f) - (#f #t #f #t) - (#t #f #t #f) - (#t #t #t #t)))] - [f1 (hash-ref n 'x1)] - [f2 (hash-ref n 'x2)]) - (check-false (f1 (make-state '((x1 . #f) (x2 . #f))))) - (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 . #t))))) - - (check-false (f2 (make-state '((x1 . #f) (x2 . #f))))) - (check-true (f2 (make-state '((x1 . #f) (x2 . #t))))) - (check-false (f2 (make-state '((x1 . #t) (x2 . #f))))) - (check-true (f2 (make-state '((x1 . #t) (x2 . #t)))))) - (let ([f1 (stream-first (enumerate-boolean-functions 1))] - [f1/list (stream-first (enumerate-boolean-functions/list 1))]) - (check-false (f1 #f)) (check-false (f1 #t)) - (check-false (f1/list '(#f))) (check-false (f1/list '(#t))))) - -(test-case "Random functions and networks" - (random-seed 0) - (check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f))) - (let ([f (random-boolean-function 2)]) - (check-true (f #f #f)) (check-false (f #f #t)) (check-true (f #t #f)) (check-false (f #t #t))) - (let ([f (random-boolean-function/list 2)]) - (check-false (f '(#f #f))) (check-true (f '(#f #t))) - (check-true (f '(#t #f))) (check-false (f '(#t #t)))) - (begin - (random-seed 0) - (define f (random-boolean-function/state '(x1 x2))) - (check-equal? (tabulate-state/boolean f '(x1 x2)) - '((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) - '((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t))) - (define bn (random-boolean-network/vars 3)) - (check-equal? (tabulate-boolean-network bn) - '((x0 x1 x2 f-x0 f-x1 f-x2) - (#f #f #f #f #t #f) - (#f #f #t #t #f #f) - (#f #t #f #f #t #t) - (#f #t #t #t #f #f) - (#t #f #f #t #f #t) - (#t #f #t #f #f #t) - (#t #t #f #f #f #f) - (#t #t #t #t #t #t))))) diff --git a/networks.rkt b/networks.rkt index ee381b0..1706bdd 100644 --- a/networks.rkt +++ b/networks.rkt @@ -97,6 +97,10 @@ [update-function/c contract?] [domain-mapping/c contract?])) +(module+ test + (require rackunit) + (random-seed 0)) + ;;; ================= ;;; Basic definitions @@ -124,6 +128,22 @@ (let ([f (hash-ref network x)]) (hash-set new-s x (f s))))) +(module+ test + (let* ([f1 (λ (s) (let ([x1 (hash-ref s 'x1)] + [x2 (hash-ref s 'x2)]) + (and x1 (not x2))))] + [f2 (λ (s) (let ([x2 (hash-ref s 'x2)]) + (not x2)))] + [bn (make-network-from-functions `((x1 . ,f1) (x2 . ,f2)))] + [s1 (make-state '((x1 . #t) (x2 . #f)))] + [new-s1 (update bn s1 '(x2 x1))] + [s2 (make-state '((x1 . #f) (x2 . #f)))] + [new-s2 (update bn s2 '(x2))]) + (check-equal? s1 #hash((x1 . #t) (x2 . #f))) + (check-equal? new-s1 #hash((x1 . #t) (x2 . #t))) + (check-equal? s2 #hash((x1 . #f) (x2 . #f))) + (check-equal? new-s2 #hash((x1 . #f) (x2 . #t))))) + ;;; A version of make-immutable-hash restricted to creating network ;;; states (see contract). (define (make-state mappings) (make-immutable-hash mappings)) @@ -136,6 +156,12 @@ [(cons var 0) (cons var #f)] [(cons var 1) (cons var #t)])))) +(module+ test + (check-equal? (make-state-booleanize '((a . 0) (b . 1))) + (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. (define (booleanize-state s) (for/hash ([(x val) s]) (match val [0 (values x #f)] [1 (values x #t)]))) @@ -161,15 +187,32 @@ (define (update-function-form->update-function form) (λ (s) (eval-with s form))) +(module+ test + (let ([s (make-state '((x . #t) (y . #f)))] + [f (update-function-form->update-function '(and x y))]) + (check-equal? (f s) #f))) + ;;; Build a network from a network form. (define (network-form->network bnf) (for/hash ([(x form) bnf]) (values x (update-function-form->update-function form)))) +(module+ test + (let ([bn (network-form->network + (make-hash '((a . (and a b)) (b . (not b)))))] + [s (make-state '((a . #t) (b . #t)))]) + (check-equal? ((hash-ref bn 'a) s) #t))) + ;;; Build a network from a list of pairs of forms of update functions. (define (make-network-from-forms forms) (network-form->network (make-immutable-hash forms))) +(module+ test + (let ([bn (make-network-from-forms '((a . (and a b)) + (b . (not b))))] + [s (make-state '((a . #t) (b . #t)))]) + (check-equal? ((hash-ref bn 'a) s) #t))) + ;;; ============================ ;;; Inferring interaction graphs @@ -196,6 +239,12 @@ (extract-symbols (hash-ref nf x)) (hash-keys nf))) +(module+ test + (let* ([n #hash((a . (+ a b c)) + (b . (- b c)))]) + (check-true (set=? (list-interactions n 'a) '(a b))) + (check-true (set=? (list-interactions n 'b) '(b))))) + ;;; Builds the graph in which the vertices are the variables of a ;;; given network, and which contains an arrow from a to b whenever a ;;; appears in (list-interactions a). @@ -204,6 +253,19 @@ (unweighted-graph/adj (for/list ([(var _) n]) (cons var (list-interactions n var)))))) +(module+ test + (let* ([n #hash((a . (+ a b c)) + (b . (- b c)))] + [ig (build-interaction-graph n)]) + (check-true (has-vertex? ig 'a)) + (check-true (has-vertex? ig 'b)) + (check-false (has-vertex? ig 'c)) + (check-true (has-edge? ig 'a 'a)) + (check-true (has-edge? ig 'b 'a)) + (check-true (has-edge? ig 'b 'b)) + (check-false (has-edge? ig 'c 'b)) + (check-false (has-edge? ig 'c 'a)))) + ;;; A domain mapping is a hash set mapping variables to the lists of ;;; values in their domains. (define domain-mapping/c (hash/c variable? list?)) @@ -218,6 +280,15 @@ (make-state (for/list ([var vars] [val s]) (cons var val)))))) +(module+ test + (check-equal? (build-all-states #hash((a . (#t #f)) (b . (1 2 3)))) + '(#hash((a . #t) (b . 1)) + #hash((a . #t) (b . 2)) + #hash((a . #t) (b . 3)) + #hash((a . #f) (b . 1)) + #hash((a . #f) (b . 2)) + #hash((a . #f) (b . 3))))) + ;;; Makes a hash set mapping all variables to a single domain. (define (make-same-domains vars domain) (for/hash ([var vars]) (values var domain))) @@ -226,10 +297,21 @@ (define (make-boolean-domains vars) (make-same-domains vars '(#f #t))) +(module+ test + (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. (define (build-all-boolean-states vars) (build-all-states (make-boolean-domains vars))) +(module+ test + (check-equal? (build-all-boolean-states '(a b)) + '(#hash((a . #f) (b . #f)) + #hash((a . #f) (b . #t)) + #hash((a . #t) (b . #f)) + #hash((a . #t) (b . #t))))) + ;;; Given two interacting variables of a network and the domains ;;; of the variables, returns '+ if the interaction is monotonously ;;; increasing, '- if it is monotonously decreasing, and '0 otherwise. @@ -275,6 +357,12 @@ ;; decreasing. [else '0]))) +(module+ test + (let* ([n #hash((a . (not b)) (b . a))] + [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 'b 'a) '-))) + ;;; Constructs a signed interaction graph of a given network form, ;;; given the ordered domains of its variables. The order on the ;;; domains determines the signs which will appear on the interaction @@ -299,6 +387,21 @@ (add-vertex! sig v)) sig)) +(module+ test + (let* ([n #hash((a . (not b)) (b . a))] + [doms (make-boolean-domains '(a b))] + [sig1 (build-signed-interaction-graph/form n doms)]) + (check-true (has-vertex? sig1 'a)) + (check-true (has-vertex? sig1 'b)) + (check-false (has-vertex? sig1 'c)) + (check-false (has-edge? sig1 'a 'a)) + (check-true (has-edge? sig1 'b 'a)) + (check-false (has-edge? sig1 'b 'b)) + (check-false (has-edge? sig1 'c 'b)) + (check-false (has-edge? sig1 'c 'a)) + (check-equal? (edge-weight sig1 'a 'b) '+) + (check-equal? (edge-weight sig1 'b 'a) '-))) + ;;; Calls build-signed-interaction-graph with the Boolean domain for ;;; all variable. ;;; @@ -309,6 +412,20 @@ network-form (make-boolean-domains (hash-keys network-form)))) +(module+ test + (let* ([n #hash((a . (not b)) (b . a))] + [sig2 (build-boolean-signed-interaction-graph/form n)]) + (check-true (has-vertex? sig2 'a)) + (check-true (has-vertex? sig2 'b)) + (check-false (has-vertex? sig2 'c)) + (check-false (has-edge? sig2 'a 'a)) + (check-true (has-edge? sig2 'b 'a)) + (check-false (has-edge? sig2 'b 'b)) + (check-false (has-edge? sig2 'c 'b)) + (check-false (has-edge? sig2 'c 'a)) + (check-equal? (edge-weight sig2 'a 'b) '+) + (check-equal? (edge-weight sig2 'b 'a) '-))) + ;;; Similar to build-signed-interaction-graph/form, but operates on a ;;; network rather than a form. The resulting graph only includes the ;;; edges for positive or negative interactions. @@ -348,6 +465,30 @@ (define (build-boolean-signed-interaction-graph network) (build-signed-interaction-graph network (make-boolean-domains (hash-keys network)))) +(module+ test + (let* ([n #hash((a . (not b)) (b . a))] + [sig3 (build-boolean-signed-interaction-graph (network-form->network n))]) + (check-true (has-vertex? sig3 'a)) + (check-true (has-vertex? sig3 'b)) + (check-equal? (edge-weight sig3 'a 'a) '+) + (check-equal? (edge-weight sig3 'b 'b) '+) + (check-equal? (edge-weight sig3 'a 'b) '+) + (check-equal? (edge-weight sig3 'b 'a) '-))) + +;;; Interaction graphs for networks without interactions must still +;;; contain all networks. +(module+ test + (let* ([n #hash((a . #t) (b . #t))] + [ig (build-interaction-graph n)] + [sig-nf (build-boolean-signed-interaction-graph/form n)] + [sig (build-boolean-signed-interaction-graph (network-form->network n))]) + (check-equal? (get-vertices ig) '(b a)) + (check-true (empty? (get-edges ig))) + (check-equal? (get-vertices sig-nf) '(b a)) + (check-true (empty? (get-edges sig-nf))) + (check-equal? (get-vertices sig) '(b a)))) + + ;;; ==================== ;;; Dynamics of networks ;;; ==================== @@ -378,6 +519,11 @@ ;;; containing the set of variables). (define (make-syn vars) (set (list->set vars))) +(module+ test + (let ([vars '(a b c)]) + (check-equal? (make-asyn vars) (set (set 'a) (set 'b) (set 'c))) + (check-equal? (make-syn vars) (set (set 'a 'b 'c))))) + ;;; Given a network, applies a function for building a mode to its ;;; variables and returns the corresponding network dynamics. (define (make-dynamics-from-func network mode-func) @@ -391,6 +537,15 @@ (define (make-syn-dynamics network) (make-dynamics-from-func network make-syn)) +(module+ test + (let* ([n (network-form->network #hash((a . (not a)) (b . b)))] + [asyn (make-asyn-dynamics n)] + [syn (make-syn-dynamics n)]) + (check-equal? (dynamics-network asyn) n) + (check-equal? (dynamics-mode asyn) (set (set 'a) (set 'b))) + (check-equal? (dynamics-network syn) n) + (check-equal? (dynamics-mode syn) (set (set 'a 'b))))) + ;;; Reads an Org-mode-produced sexp, converts it into a network, and ;;; builds the asyncronous dynamics out of it. (define read-org-network-make-asyn (compose make-asyn-dynamics network-form->network read-org-variable-mapping)) @@ -403,6 +558,10 @@ (define (pretty-print-state s) (string-join (hash-map s (λ (key val) (format "~a:~a" key val)) #t))) +(module+ test + (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. (define (any->boolean x) (if x 1 0)) @@ -410,6 +569,11 @@ (define (pretty-print-boolean-state s) (string-join (hash-map s (λ (key val) (format "~a:~a" key (any->boolean val))) #t))) +(module+ test + (check-equal? + (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 ;;; state graph with pretty-printed vertices and edges. (define (pretty-print-state-graph-with gr pprinter) @@ -441,6 +605,94 @@ dyn (list->set (build-all-boolean-states (hash-keys (dynamics-network dyn)))))) +(module+ test + (let* ([n (network-form->network #hash((a . (not a)) (b . b)))] + [asyn (make-asyn-dynamics n)] + [syn (make-syn-dynamics n)] + [s (make-state '((a . #t) (b . #f)))] + [ss (set (make-state '((a . #t) (b . #t))) + (make-state '((a . #f) (b . #t))))] + [gr1 (dds-build-n-step-state-graph asyn (set s) 1)] + [gr-full (dds-build-state-graph asyn (set s))] + [gr-full-pp (pretty-print-state-graph gr-full)] + [gr-full-ppb (pretty-print-boolean-state-graph gr-full)] + [gr-complete-bool (build-full-boolean-state-graph asyn)] + [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))) + (make-state '((a . #t) (b . #f))))) + (check-equal? (dds-step-one-annotated asyn s) + (set (cons (set 'b) '#hash((a . #t) (b . #f))) + (cons (set 'a) '#hash((a . #f) (b . #f))))) + (check-equal? (dds-step-one syn s) (set (make-state '((a . #f) (b . #f))))) + (check-equal? (dds-step asyn ss) + (set (make-state '((a . #f) (b . #t))) + (make-state '((a . #t) (b . #t))))) + (check-true (has-vertex? gr1 #hash((a . #t) (b . #f)))) + (check-true (has-vertex? gr1 #hash((a . #f) (b . #f)))) + (check-false (has-vertex? gr1 #hash((a . #t) (b . #t)))) + (check-true (has-edge? gr1 #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))) + (check-true (has-edge? gr1 #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))) + (check-false (has-edge? gr1 #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))) + + (check-true (has-vertex? gr-full #hash((a . #t) (b . #f)))) + (check-true (has-vertex? gr-full #hash((a . #f) (b . #f)))) + (check-false (has-vertex? gr-full #hash((a . #t) (b . #t)))) + (check-true (has-edge? gr-full #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))) + (check-true (has-edge? gr-full #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))) + (check-true (has-edge? gr-full #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))) + (check-true (has-edge? gr-full #hash((a . #f) (b . #f)) #hash((a . #f) (b . #f)))) + + (check-true (has-vertex? gr-full-pp "a:#f b:#f")) + (check-true (has-vertex? gr-full-pp "a:#t b:#f")) + (check-true (has-vertex? gr-full-ppb "a:0 b:0")) + (check-true (has-vertex? gr-full-ppb "a:1 b:0")) + + (check-true (set=? + (get-edges gr-complete-bool) + '((#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))) + (#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))) + (#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))) + (#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))) + (#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t))) + (#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t))) + (#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t))) + (#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t)))))) + + (check-true (set=? + (get-edges gr-complete-bool-ann) + '((#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))) + (#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))) + (#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))) + (#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))) + (#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t))) + (#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t))) + (#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t))) + (#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t)))))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))) + (set (set 'a))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))) + (set (set 'b))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))) + (set (set 'b))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))) + (set (set 'a))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #t) (b . #t)) #hash((a . #f) (b . #t))) + (set (set 'a))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #t) (b . #t)) #hash((a . #t) (b . #t))) + (set (set 'b))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #f) (b . #t)) #hash((a . #f) (b . #t))) + (set (set 'b))) + (check-equal? (edge-weight gr-complete-bool-ann + #hash((a . #f) (b . #t)) #hash((a . #t) (b . #t))) + (set (set 'a))))) + ;;; ================================= ;;; Tabulating functions and networks @@ -453,15 +705,27 @@ (for/list ([xs (apply cartesian-product doms)]) (append xs (list (apply func xs))))) +(module+ test + (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. (define (tabulate func . doms) (tabulate/domain-list func doms)) +(module+ test + (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 ;;; function are Boolean. func must have a fixed arity. It is an ;;; error to supply a function of variable arity. (define (tabulate/boolean func) (tabulate/domain-list func (make-list (procedure-arity func) '(#f #t)))) +(module+ test + (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. ;;; ;;; The argument domains defines the domains of each of the component @@ -484,6 +748,10 @@ (define (tabulate-state/boolean func args #:headers [headers #t]) (tabulate-state func (make-boolean-domains args) #:headers headers)) +(module+ test + (let ([func (λ (st) (not (hash-ref st 'a)))]) + (check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f))))) + ;;; Tabulates a given network. ;;; ;;; For a Boolean network with n variables, returns a table with 2n @@ -510,6 +778,14 @@ (tabulate-network bn (make-boolean-domains (hash-map bn (λ (x y) x) #t)) #:headers headers)) +(module+ test + (let ([bn (network-form->network #hash((a . (not a)) (b . b)))]) + (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))) + (check-equal? (tabulate-boolean-network bn #:headers #f) + '((#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t))))) + + ;;; =================================== ;;; Constructing functions and networks ;;; =================================== @@ -530,6 +806,11 @@ (let ([func (table->function/list table)]) (λ args (func args)))) +(module+ test + (let ([negation (table->function '((#t #f) (#f #t)))]) + (check-true (negation #f)) + (check-false (negation #t)))) + ;;; Like table->function, but the produced function accepts a single ;;; list of arguments instead of individual arguments. (define (table->function/list table) @@ -538,6 +819,11 @@ (let-values ([(x fx) (split-at-right line 1)]) (values x (car fx)))))) +(module+ test + (let ([negation/list (table->function/list '((#t #f) (#f #t)))]) + (check-true (negation/list '(#f))) + (check-false (negation/list '(#t))))) + ;;; Given a table like the one produced by tabulate-network, ;;; constructs a Boolean network having this behaviour. If headers is ;;; #t, considers that the first element of the list are the headers @@ -575,13 +861,37 @@ ;; Construct the network. (make-network-from-functions (map cons var-names funcs))) +(module+ test + (let* ([n (table->network '((x1 x2 f1 f2) + (#f #f #f #f) + (#f #t #f #t) + (#t #f #t #f) + (#t #t #t #t)))] + [f1 (hash-ref n 'x1)] + [f2 (hash-ref n 'x2)]) + (check-false (f1 (make-state '((x1 . #f) (x2 . #f))))) + (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 . #t))))) + + (check-false (f2 (make-state '((x1 . #f) (x2 . #f))))) + (check-true (f2 (make-state '((x1 . #f) (x2 . #t))))) + (check-false (f2 (make-state '((x1 . #t) (x2 . #f))))) + (check-true (f2 (make-state '((x1 . #t) (x2 . #t))))))) + ;;; Returns the n-th Cartesian power of the Boolean domain: {0,1}^n. (define (boolean-power n) (apply cartesian-product (make-list n '(#f #t)))) +(module+ test + (check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t)))) + ;;; Like boolean-power, but returns a stream whose elements the ;;; elements of the Cartesian power. (define (boolean-power/stream n) (apply cartesian-product/stream (make-list n '(#f #t)))) +(module+ test + (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 ;;; a given arity. ;;; @@ -599,6 +909,11 @@ (define (enumerate-boolean-functions n) (stream-map table->function (enumerate-boolean-tables n))) +(module+ test + (let ([f1 (stream-first (enumerate-boolean-functions 1))]) + (check-false (f1 #f)) + (check-false (f1 #t)))) + ;;; Returns the stream of all Boolean functions of a given arity. As ;;; different from the functions returned by ;;; enumerate-boolean-functions, the functions take lists of arguments @@ -608,6 +923,11 @@ (define (enumerate-boolean-functions/list n) (stream-map table->function/list (enumerate-boolean-tables n))) +(module+ test + (let ([f1/list (stream-first (enumerate-boolean-functions/list 1))]) + (check-false (f1/list '(#f))) + (check-false (f1/list '(#t))))) + ;;; ============================= ;;; Random functions and networks @@ -621,13 +941,26 @@ (for/list ([i inputs] [o outputs]) (append i (list (num->bool o))))) +(module+ test + (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. (define random-boolean-function (compose table->function random-boolean-table)) +(module+ test + (let ([f (random-boolean-function 2)]) + (check-true (f #f #f)) (check-false (f #f #t)) + (check-true (f #t #f)) (check-false (f #t #t)))) + ;;; Like random-boolean-function, but the constructed function takes a ;;; list of arguments. (define random-boolean-function/list (compose table->function/list random-boolean-table)) +(module+ test + (let ([f (random-boolean-function/list 2)]) + (check-false (f '(#f #f))) (check-true (f '(#f #t))) + (check-true (f '(#t #f))) (check-false (f '(#t #t))))) + ;;; Generates a random function accepting a state over the domains ;;; given by arg-domains and producing values in func-domain. (define (random-function/state arg-domains func-domain) @@ -640,6 +973,25 @@ (define (random-boolean-function/state args) (random-function/state (make-boolean-domains args) '(#f #t))) +(module+ test + (test-begin + (define f (random-boolean-function/state '(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))) + (check-equal? (tabulate-state/boolean f '(x1 x2) #:headers #f) + '((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #f))) + (define bn (random-boolean-network/vars 3)) + (check-equal? (tabulate-boolean-network bn) + '((x0 x1 x2 f-x0 f-x1 f-x2) + (#f #f #f #t #f #f) + (#f #f #t #t #t #f) + (#f #t #f #f #t #f) + (#f #t #t #t #f #t) + (#t #f #f #t #f #f) + (#t #f #t #f #t #t) + (#t #t #f #t #f #f) + (#t #t #t #f #t #t))))) + ;;; Generates a random network from the given domain mapping. (define (random-network domains) (for/hash ([(x x-dom) (in-hash domains)])