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

networks: Move the tests to the test submodule.

Browse source
This commit is contained in:
Sergiu Ivanov 2020-05-22 23:40:40 +02:00
parent ff9189270e
commit c8d88de6c2
2 changed files with 352 additions and 294 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

294
networks-tests.rkt
View file

@ -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)))))

352
networks.rkt
View file

@ -97,6 +97,10 @@
[update-function/c contract?] [update-function/c contract?]
[domain-mapping/c contract?])) [domain-mapping/c contract?]))
(module+ test
(require rackunit)
(random-seed 0))
;;; ================= ;;; =================
;;; Basic definitions ;;; Basic definitions
@ -124,6 +128,22 @@
(let ([f (hash-ref network x)]) (let ([f (hash-ref network x)])
(hash-set new-s x (f s))))) (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 ;;; A version of make-immutable-hash restricted to creating network
;;; states (see contract). ;;; states (see contract).
(define (make-state mappings) (make-immutable-hash mappings)) (define (make-state mappings) (make-immutable-hash mappings))
@ -136,6 +156,12 @@
[(cons var 0) (cons var #f)] [(cons var 0) (cons var #f)]
[(cons var 1) (cons var #t)])))) [(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. ;;; Booleanizes a given state: replaces 0 with #f and 1 with #t.
(define (booleanize-state s) (define (booleanize-state s)
(for/hash ([(x val) s]) (match val [0 (values x #f)] [1 (values x #t)]))) (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) (define (update-function-form->update-function form)
(λ (s) (eval-with s 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. ;;; Build a network from a network form.
(define (network-form->network bnf) (define (network-form->network bnf)
(for/hash ([(x form) bnf]) (for/hash ([(x form) bnf])
(values x (update-function-form->update-function form)))) (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. ;;; Build a network from a list of pairs of forms of update functions.
(define (make-network-from-forms forms) (define (make-network-from-forms forms)
(network-form->network (make-immutable-hash 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 ;;; Inferring interaction graphs
@ -196,6 +239,12 @@
(extract-symbols (hash-ref nf x)) (extract-symbols (hash-ref nf x))
(hash-keys nf))) (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 ;;; 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 ;;; given network, and which contains an arrow from a to b whenever a
;;; appears in (list-interactions a). ;;; appears in (list-interactions a).
@ -204,6 +253,19 @@
(unweighted-graph/adj (unweighted-graph/adj
(for/list ([(var _) n]) (cons var (list-interactions n var)))))) (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 ;;; A domain mapping is a hash set mapping variables to the lists of
;;; values in their domains. ;;; values in their domains.
(define domain-mapping/c (hash/c variable? list?)) (define domain-mapping/c (hash/c variable? list?))
@ -218,6 +280,15 @@
(make-state (for/list ([var vars] [val s]) (make-state (for/list ([var vars] [val s])
(cons var val)))))) (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. ;;; Makes a hash set mapping all variables to a single domain.
(define (make-same-domains vars domain) (define (make-same-domains vars domain)
(for/hash ([var vars]) (values var domain))) (for/hash ([var vars]) (values var domain)))
@ -226,10 +297,21 @@
(define (make-boolean-domains vars) (define (make-boolean-domains vars)
(make-same-domains vars '(#f #t))) (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. ;;; 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
(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 ;;; 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
;;; increasing, '- if it is monotonously decreasing, and '0 otherwise. ;;; increasing, '- if it is monotonously decreasing, and '0 otherwise.
@ -275,6 +357,12 @@
;; decreasing. ;; decreasing.
[else '0]))) [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, ;;; Constructs a signed interaction graph of a given network form,
;;; given the ordered domains of its variables. The order on the ;;; given the ordered domains of its variables. The order on the
;;; domains determines the signs which will appear on the interaction ;;; domains determines the signs which will appear on the interaction
@ -299,6 +387,21 @@
(add-vertex! sig v)) (add-vertex! sig v))
sig)) 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 ;;; Calls build-signed-interaction-graph with the Boolean domain for
;;; all variable. ;;; all variable.
;;; ;;;
@ -309,6 +412,20 @@
network-form network-form
(make-boolean-domains (hash-keys 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 ;;; Similar to build-signed-interaction-graph/form, but operates on a
;;; network rather than a form. The resulting graph only includes the ;;; network rather than a form. The resulting graph only includes the
;;; edges for positive or negative interactions. ;;; edges for positive or negative interactions.
@ -348,6 +465,30 @@
(define (build-boolean-signed-interaction-graph network) (define (build-boolean-signed-interaction-graph network)
(build-signed-interaction-graph network (make-boolean-domains (hash-keys 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 ;;; Dynamics of networks
;;; ==================== ;;; ====================
@ -378,6 +519,11 @@
;;; containing the set of variables). ;;; containing the set of variables).
(define (make-syn vars) (set (list->set vars))) (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 ;;; Given a network, applies a function for building a mode to its
;;; variables and returns the corresponding network dynamics. ;;; variables and returns the corresponding network dynamics.
(define (make-dynamics-from-func network mode-func) (define (make-dynamics-from-func network mode-func)
@ -391,6 +537,15 @@
(define (make-syn-dynamics network) (define (make-syn-dynamics network)
(make-dynamics-from-func network make-syn)) (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 ;;; Reads an Org-mode-produced sexp, converts it into a network, and
;;; builds the asyncronous dynamics out of it. ;;; builds the asyncronous dynamics out of it.
(define read-org-network-make-asyn (compose make-asyn-dynamics network-form->network read-org-variable-mapping)) (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) (define (pretty-print-state s)
(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
(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))
@ -410,6 +569,11 @@
(define (pretty-print-boolean-state s) (define (pretty-print-boolean-state s)
(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
(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 ;;; 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.
(define (pretty-print-state-graph-with gr pprinter) (define (pretty-print-state-graph-with gr pprinter)
@ -441,6 +605,94 @@
dyn dyn
(list->set (build-all-boolean-states (hash-keys (dynamics-network 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 ;;; Tabulating functions and networks
@ -453,15 +705,27 @@
(for/list ([xs (apply cartesian-product doms)]) (for/list ([xs (apply cartesian-product doms)])
(append xs (list (apply func xs))))) (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. ;;; 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
(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
;;; error to supply a function of variable arity. ;;; error to supply a function of variable arity.
(define (tabulate/boolean func) (define (tabulate/boolean func)
(tabulate/domain-list func (make-list (procedure-arity func) '(#f #t)))) (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. ;;; Like tabulate, but supposes that the function works on states.
;;; ;;;
;;; The argument domains defines the domains of each of the component ;;; The argument domains defines the domains of each of the component
@ -484,6 +748,10 @@
(define (tabulate-state/boolean func args #:headers [headers #t]) (define (tabulate-state/boolean func args #:headers [headers #t])
(tabulate-state func (make-boolean-domains args) #:headers headers)) (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. ;;; Tabulates a given network.
;;; ;;;
;;; For a Boolean network with n variables, returns a table with 2n ;;; 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)) (tabulate-network bn (make-boolean-domains (hash-map bn (λ (x y) x) #t))
#:headers headers)) #: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 ;;; Constructing functions and networks
;;; =================================== ;;; ===================================
@ -530,6 +806,11 @@
(let ([func (table->function/list table)]) (let ([func (table->function/list table)])
(λ args (func args)))) (λ 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 ;;; Like table->function, but the produced function accepts a single
;;; list of arguments instead of individual arguments. ;;; list of arguments instead of individual arguments.
(define (table->function/list table) (define (table->function/list table)
@ -538,6 +819,11 @@
(let-values ([(x fx) (split-at-right line 1)]) (let-values ([(x fx) (split-at-right line 1)])
(values x (car fx)))))) (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, ;;; Given a table like the one produced by tabulate-network,
;;; constructs a Boolean network having this behaviour. If headers is ;;; constructs a Boolean network having this behaviour. If headers is
;;; #t, considers that the first element of the list are the headers ;;; #t, considers that the first element of the list are the headers
@ -575,13 +861,37 @@
;; Construct the network. ;; Construct the network.
(make-network-from-functions (map cons var-names funcs))) (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. ;;; 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)))) (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 ;;; 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
(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.
;;; ;;;
@ -599,6 +909,11 @@
(define (enumerate-boolean-functions n) (define (enumerate-boolean-functions n)
(stream-map table->function (enumerate-boolean-tables 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 ;;; Returns the stream of all Boolean functions of a given arity. As
;;; different from the functions returned by ;;; different from the functions returned by
;;; enumerate-boolean-functions, the functions take lists of arguments ;;; enumerate-boolean-functions, the functions take lists of arguments
@ -608,6 +923,11 @@
(define (enumerate-boolean-functions/list n) (define (enumerate-boolean-functions/list n)
(stream-map table->function/list (enumerate-boolean-tables 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 ;;; Random functions and networks
@ -621,13 +941,26 @@
(for/list ([i inputs] [o outputs]) (for/list ([i inputs] [o outputs])
(append i (list (num->bool o))))) (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. ;;; 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
(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 ;;; Like random-boolean-function, but the constructed function takes a
;;; list of arguments. ;;; list of arguments.
(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
(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 ;;; Generates a random function accepting a state over the domains
;;; given by arg-domains and producing values in func-domain. ;;; given by arg-domains and producing values in func-domain.
(define (random-function/state arg-domains func-domain) (define (random-function/state arg-domains func-domain)
@ -640,6 +973,25 @@
(define (random-boolean-function/state args) (define (random-boolean-function/state args)
(random-function/state (make-boolean-domains args) '(#f #t))) (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. ;;; Generates a random network from the given domain mapping.
(define (random-network domains) (define (random-network domains)
(for/hash ([(x x-dom) (in-hash domains)]) (for/hash ([(x x-dom) (in-hash domains)])