rs: Move the tests to the test submodule.

This commit is contained in:
Sergiu Ivanov 2020-05-23 00:00:28 +02:00
parent c8d88de6c2
commit e7d4ff88cf
2 changed files with 100 additions and 91 deletions

View file

@ -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
View file

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