rs: Move the tests to the test submodule.
This commit is contained in:
Sergiu Ivanov
parent
c8d88de6c2
commit
e7d4ff88cf
2 changed files with 100 additions and 91 deletions
91
rs-tests.rkt
91
rs-tests.rkt
|
|
@ -1,91 +0,0 @@
|
||||||
#lang racket
|
|
||||||
|
|
||||||
;;; Tests for dds/rs.
|
|
||||||
|
|
||||||
(require rackunit graph "rs.rkt" "utils.rkt")
|
|
||||||
|
|
||||||
(test-case "Basic definitions"
|
|
||||||
(let* ([r1 (reaction (set 'x) (set 'y) (set 'z))]
|
|
||||||
[r2 (reaction (set 'x) (set) (set 'y))]
|
|
||||||
[rs (make-immutable-hash (list (cons 'a r1) (cons 'b r2)))]
|
|
||||||
[s1 (set 'x 'z)]
|
|
||||||
[s2 (set 'x 'y)])
|
|
||||||
(check-true (enabled? r1 s1))
|
|
||||||
(check-false (enabled? r1 s2))
|
|
||||||
(check-equal? (list-enabled rs s1) '(a b))
|
|
||||||
(check-equal? (list-enabled rs s2) '(b))
|
|
||||||
(check-equal? (union-products rs '(a b)) (set 'y 'z))
|
|
||||||
(check-equal? (apply-rs rs s1) (set 'y 'z))
|
|
||||||
(check-equal? (apply-rs rs s2) (set 'y))))
|
|
||||||
|
|
||||||
(test-case "Org-mode interaction"
|
|
||||||
(check-equal? (ht-str-triples->rs #hash((a . ("x t" "y" "z"))))
|
|
||||||
(make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z))))))
|
|
||||||
(check-equal? (read-context-sequence "((\"x y\") (\"z\") (\"\") (\"t\"))")
|
|
||||||
(list (set 'x 'y) (set 'z) (set) (set 't)))
|
|
||||||
(check-equal? (rs->ht-str-triples (make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z))))))
|
|
||||||
#hash((a . ("t x" "y" "z"))))
|
|
||||||
(check-equal? (read-org-rs "((\"a\" \"x t\" \"y\" \"z\") (\"b\" \"x\" \"q\" \"z\"))")
|
|
||||||
(hash
|
|
||||||
'a
|
|
||||||
(reaction (set 'x 't) (set 'y) (set 'z))
|
|
||||||
'b
|
|
||||||
(reaction (set 'x) (set 'q) (set 'z)))))
|
|
||||||
|
|
||||||
(test-case "Dynamics of reaction systems"
|
|
||||||
(let* ([r1 (reaction (set 'x) (set 'y) (set 'z))]
|
|
||||||
[r2 (reaction (set 'x) (set) (set 'y))]
|
|
||||||
[rs (make-immutable-hash (list (cons 'a r1) (cons 'b r2)))]
|
|
||||||
[dyn (dynamics rs)]
|
|
||||||
[state1 (state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))]
|
|
||||||
[sgr (dds-build-state-graph-annotated dyn (set state1))]
|
|
||||||
[ip (build-interactive-process-graph rs (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))])
|
|
||||||
(check-equal? (dds-step-one-annotated dyn state1)
|
|
||||||
(set (cons
|
|
||||||
(set 'a 'b)
|
|
||||||
(state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z))))))
|
|
||||||
(check-equal? (dds-step-one dyn state1)
|
|
||||||
(set (state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z)))))
|
|
||||||
|
|
||||||
(check-true (has-vertex? sgr (state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z)))))
|
|
||||||
(check-true (has-vertex? sgr (state (set) (list (set 'z) (set) (set 'z)))))
|
|
||||||
(check-true (has-vertex? sgr (state (set) (list (set) (set 'z)))))
|
|
||||||
(check-true (has-vertex? sgr (state (set) (list (set 'z)))))
|
|
||||||
(check-true (has-vertex? sgr (state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))))
|
|
||||||
(check-true (has-vertex? sgr (state (set) '())))
|
|
||||||
|
|
||||||
(check-equal? (edge-weight sgr
|
|
||||||
(state (set) '())
|
|
||||||
(state (set) '()))
|
|
||||||
(set (set)))
|
|
||||||
(check-equal? (edge-weight sgr
|
|
||||||
(state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z)))
|
|
||||||
(state (set) (list (set 'z) (set) (set 'z))))
|
|
||||||
(set (set)))
|
|
||||||
(check-equal? (edge-weight sgr
|
|
||||||
(state (set) (list (set 'z) (set) (set 'z)))
|
|
||||||
(state (set) (list (set) (set 'z))))
|
|
||||||
(set (set)))
|
|
||||||
(check-equal? (edge-weight sgr
|
|
||||||
(state (set) (list (set) (set 'z)))
|
|
||||||
(state (set) (list (set 'z))))
|
|
||||||
(set (set)))
|
|
||||||
(check-equal? (edge-weight sgr
|
|
||||||
(state (set) (list (set 'z)))
|
|
||||||
(state (set) '()))
|
|
||||||
(set (set)))
|
|
||||||
(check-equal? (edge-weight sgr
|
|
||||||
(state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))
|
|
||||||
(state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z))))
|
|
||||||
(set (set 'a 'b)))
|
|
||||||
|
|
||||||
(check-equal? sgr ip)
|
|
||||||
|
|
||||||
(check-equal? (build-interactive-process rs (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))
|
|
||||||
(list
|
|
||||||
(list (set 'x) (set))
|
|
||||||
(list (set 'y) (set 'y 'z))
|
|
||||||
(list (set 'z) (set))
|
|
||||||
(list (set) (set))
|
|
||||||
(list (set 'z) (set))
|
|
||||||
(list (set) (set))))))
|
|
||||||
100
rs.rkt
100
rs.rkt
|
|
@ -35,6 +35,10 @@
|
||||||
;; Contracts
|
;; Contracts
|
||||||
(contract-out [reaction-system/c contract?]))
|
(contract-out [reaction-system/c contract?]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit))
|
||||||
|
|
||||||
|
|
||||||
;;; =================
|
;;; =================
|
||||||
;;; Basic definitions
|
;;; Basic definitions
|
||||||
;;; =================
|
;;; =================
|
||||||
|
|
@ -81,6 +85,21 @@
|
||||||
(let ([as (list-enabled rs s)])
|
(let ([as (list-enabled rs s)])
|
||||||
(union-products rs as)))
|
(union-products rs as)))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(test-case "Basic definitions"
|
||||||
|
(let* ([r1 (reaction (set 'x) (set 'y) (set 'z))]
|
||||||
|
[r2 (reaction (set 'x) (set) (set 'y))]
|
||||||
|
[rs (make-immutable-hash (list (cons 'a r1) (cons 'b r2)))]
|
||||||
|
[s1 (set 'x 'z)]
|
||||||
|
[s2 (set 'x 'y)])
|
||||||
|
(check-true (enabled? r1 s1))
|
||||||
|
(check-false (enabled? r1 s2))
|
||||||
|
(check-equal? (list-enabled rs s1) '(a b))
|
||||||
|
(check-equal? (list-enabled rs s2) '(b))
|
||||||
|
(check-equal? (union-products rs '(a b)) (set 'y 'z))
|
||||||
|
(check-equal? (apply-rs rs s1) (set 'y 'z))
|
||||||
|
(check-equal? (apply-rs rs s2) (set 'y)))))
|
||||||
|
|
||||||
|
|
||||||
;;; ====================
|
;;; ====================
|
||||||
;;; Org-mode interaction
|
;;; Org-mode interaction
|
||||||
|
|
@ -102,13 +121,30 @@
|
||||||
(for/hash ([(a triple) (in-hash ht)])
|
(for/hash ([(a triple) (in-hash ht)])
|
||||||
(values a (str-triple->reaction triple))))
|
(values a (str-triple->reaction triple))))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-equal?
|
||||||
|
(ht-str-triples->rs #hash((a . ("x t" "y" "z"))))
|
||||||
|
(make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z)))))))
|
||||||
|
|
||||||
;;; Reads a reaction system from an Org-mode style string.
|
;;; Reads a reaction system from an Org-mode style string.
|
||||||
(define read-org-rs (compose ht-str-triples->rs read-org-variable-mapping))
|
(define read-org-rs (compose ht-str-triples->rs read-org-variable-mapping))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-equal? (read-org-rs "((\"a\" \"x t\" \"y\" \"z\") (\"b\" \"x\" \"q\" \"z\"))")
|
||||||
|
(hash
|
||||||
|
'a
|
||||||
|
(reaction (set 'x 't) (set 'y) (set 'z))
|
||||||
|
'b
|
||||||
|
(reaction (set 'x) (set 'q) (set 'z)))))
|
||||||
|
|
||||||
;;; Reads a context sequence from an Org sexp corresponding to a list.
|
;;; Reads a context sequence from an Org sexp corresponding to a list.
|
||||||
(define (read-context-sequence str)
|
(define (read-context-sequence str)
|
||||||
(map (compose list->set read-symbol-list) (flatten (string->any str))))
|
(map (compose list->set read-symbol-list) (flatten (string->any str))))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-equal? (read-context-sequence "((\"x y\") (\"z\") (\"\") (\"t\"))")
|
||||||
|
(list (set 'x 'y) (set 'z) (set) (set 't))))
|
||||||
|
|
||||||
;;; Converts a reaction to a triple of strings.
|
;;; Converts a reaction to a triple of strings.
|
||||||
(define/match (reaction->str-triple r)
|
(define/match (reaction->str-triple r)
|
||||||
[((reaction r i p))
|
[((reaction r i p))
|
||||||
|
|
@ -121,6 +157,11 @@
|
||||||
(for/hash ([(a r) (in-hash rs)])
|
(for/hash ([(a r) (in-hash rs)])
|
||||||
(values a (reaction->str-triple r))))
|
(values a (reaction->str-triple r))))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(check-equal?
|
||||||
|
(rs->ht-str-triples (make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z))))))
|
||||||
|
#hash((a . ("t x" "y" "z")))))
|
||||||
|
|
||||||
|
|
||||||
;;; ============================
|
;;; ============================
|
||||||
;;; Dynamics of reaction systems
|
;;; Dynamics of reaction systems
|
||||||
|
|
@ -198,3 +239,62 @@
|
||||||
;;; Pretty prints the state graph of a reaction system.
|
;;; Pretty prints the state graph of a reaction system.
|
||||||
(define (pretty-print-state-graph sgr)
|
(define (pretty-print-state-graph sgr)
|
||||||
(update-graph sgr #:v-func pretty-print-state #:e-func pretty-print-set-sets))
|
(update-graph sgr #:v-func pretty-print-state #:e-func pretty-print-set-sets))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(test-case "Dynamics of reaction systems"
|
||||||
|
(let* ([r1 (reaction (set 'x) (set 'y) (set 'z))]
|
||||||
|
[r2 (reaction (set 'x) (set) (set 'y))]
|
||||||
|
[rs (make-immutable-hash (list (cons 'a r1) (cons 'b r2)))]
|
||||||
|
[dyn (dynamics rs)]
|
||||||
|
[state1 (state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))]
|
||||||
|
[sgr (dds-build-state-graph-annotated dyn (set state1))]
|
||||||
|
[ip (build-interactive-process-graph rs (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))])
|
||||||
|
(check-equal? (dds-step-one-annotated dyn state1)
|
||||||
|
(set (cons
|
||||||
|
(set 'a 'b)
|
||||||
|
(state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z))))))
|
||||||
|
(check-equal? (dds-step-one dyn state1)
|
||||||
|
(set (state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z)))))
|
||||||
|
|
||||||
|
(check-true (has-vertex? sgr (state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z)))))
|
||||||
|
(check-true (has-vertex? sgr (state (set) (list (set 'z) (set) (set 'z)))))
|
||||||
|
(check-true (has-vertex? sgr (state (set) (list (set) (set 'z)))))
|
||||||
|
(check-true (has-vertex? sgr (state (set) (list (set 'z)))))
|
||||||
|
(check-true (has-vertex? sgr (state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))))
|
||||||
|
(check-true (has-vertex? sgr (state (set) '())))
|
||||||
|
|
||||||
|
(check-equal? (edge-weight sgr
|
||||||
|
(state (set) '())
|
||||||
|
(state (set) '()))
|
||||||
|
(set (set)))
|
||||||
|
(check-equal? (edge-weight sgr
|
||||||
|
(state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z)))
|
||||||
|
(state (set) (list (set 'z) (set) (set 'z))))
|
||||||
|
(set (set)))
|
||||||
|
(check-equal? (edge-weight sgr
|
||||||
|
(state (set) (list (set 'z) (set) (set 'z)))
|
||||||
|
(state (set) (list (set) (set 'z))))
|
||||||
|
(set (set)))
|
||||||
|
(check-equal? (edge-weight sgr
|
||||||
|
(state (set) (list (set) (set 'z)))
|
||||||
|
(state (set) (list (set 'z))))
|
||||||
|
(set (set)))
|
||||||
|
(check-equal? (edge-weight sgr
|
||||||
|
(state (set) (list (set 'z)))
|
||||||
|
(state (set) '()))
|
||||||
|
(set (set)))
|
||||||
|
(check-equal? (edge-weight sgr
|
||||||
|
(state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))
|
||||||
|
(state (set 'y 'z) (list (set 'y) (set 'z) (set) (set 'z))))
|
||||||
|
(set (set 'a 'b)))
|
||||||
|
|
||||||
|
(check-equal? sgr ip)
|
||||||
|
|
||||||
|
(check-equal? (build-interactive-process rs (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))
|
||||||
|
(list
|
||||||
|
(list (set 'x) (set))
|
||||||
|
(list (set 'y) (set 'y 'z))
|
||||||
|
(list (set 'z) (set))
|
||||||
|
(list (set) (set))
|
||||||
|
(list (set 'z) (set))
|
||||||
|
(list (set) (set)))))))
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue