dds/networks-tests.rkt

#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)))
                    (st '((a . #f) (b . #t))))
      (check-equal? (stb #hash((a . 0) (b . 1)))
                    (st '((a . #f) (b . #t))))
      (check-equal? (booleanize-state (st '((a . 0) (b . 1))))
                    (st '((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 (nn #hash((a . (and a b))
                       (b . (not b))))]
        [s (st '((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)])
    (check-equal? (get-interaction-sign (nn n) doms 'a 'b) '+)
    (check-equal? (get-interaction-sign (nn 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) '-)))

(test-case "Dynamics of networks"
  (check-equal? (pretty-print-state (st '((a . #f) (b . 3) (c . 4)))) "a:#f b:3 c:4")
  (check-equal? (pretty-print-boolean-state (st '((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 (nn #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 (nn #hash((a . (not a)) (b . b)))]
         [asyn (make-asyn-dynamics n)]
         [syn (make-syn-dynamics n)]
         [s (st '((a . #t) (b . #f)))]
         [ss (set (st '((a . #t) (b . #t)))
                  (st '((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 (ppsg gr-full)]
         [gr-full-ppb (ppsgb 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 (st '((a . #f) (b . #f)))
                                             (st '((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 (st '((a . #f) (b . #f)))))
    (check-equal? (dds-step asyn ss)
                  (set (st '((a . #f) (b . #t)))
                       (st '((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 (nn #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"
  (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 ([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)))))