Make rs fully Typed Racket.
This commit is contained in:
Sergiu Ivanov
parent
5a2307ed58
commit
51c033b29c
2 changed files with 275 additions and 608 deletions
877
rs.rkt
877
rs.rkt
|
|
@ -1,688 +1,355 @@
|
||||||
#lang racket
|
#lang typed/racket
|
||||||
|
|
||||||
(module typed typed/racket
|
(require typed/graph "utils.rkt" "dynamics.rkt")
|
||||||
(require typed/graph "utils.rkt" "dynamics.rkt")
|
|
||||||
|
|
||||||
(provide
|
|
||||||
Species (struct-out reaction) Reaction ReactionName ReactionSystem
|
|
||||||
make-reaction enabled? list-enabled union-products apply-rs
|
|
||||||
|
|
||||||
str-triple->reaction ht-str-triples->rs read-org-rs read-context-sequence
|
|
||||||
reaction->str-triple rs->ht-str-triples
|
|
||||||
|
|
||||||
(struct-out state) State dynamics% Dynamics% build-interactive-process-graph
|
|
||||||
build-interactive-process-graph/simple-states
|
|
||||||
pretty-print-state-graph/simple-states build-interactive-process
|
|
||||||
build-interactive-process/org pretty-print-state pretty-print-state-graph
|
|
||||||
)
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(require typed/rackunit))
|
|
||||||
|
|
||||||
(define-type Species Symbol)
|
|
||||||
|
|
||||||
(struct reaction ([reactants : (Setof Species)]
|
|
||||||
[inhibitors : (Setof Species)]
|
|
||||||
[products : (Setof Species)])
|
|
||||||
#:transparent
|
|
||||||
#:type-name Reaction)
|
|
||||||
|
|
||||||
(define-type ReactionName Symbol)
|
|
||||||
|
|
||||||
(: make-reaction (-> (Listof Species) (Listof Species) (Listof Species) Reaction))
|
|
||||||
(define (make-reaction r i p) (reaction (list->set r)
|
|
||||||
(list->set i)
|
|
||||||
(list->set p)))
|
|
||||||
(module+ test
|
|
||||||
(test-case "make-reaction"
|
|
||||||
(check-equal? (make-reaction '(a b) '(c d) '(e f))
|
|
||||||
(reaction (set 'b 'a) (set 'c 'd) (set 'f 'e)))))
|
|
||||||
|
|
||||||
(: enabled? (-> Reaction (Setof Species) Boolean))
|
|
||||||
(define/match (enabled? r s)
|
|
||||||
[((reaction r i _) s)
|
|
||||||
(and (subset? r s) (set-empty? (set-intersect i s)))])
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "enabled?"
|
|
||||||
(check-true (enabled? (make-reaction '(a b) '(c d) '())
|
|
||||||
(set 'a 'b 'e)))
|
|
||||||
(check-false (enabled? (make-reaction '(a b) '(c d) '())
|
|
||||||
(set 'a 'b 'c)))
|
|
||||||
(check-false (enabled? (make-reaction '(a b) '(c d) '())
|
|
||||||
(set 'b 'e)))))
|
|
||||||
|
|
||||||
(define-type ReactionSystem (HashTable ReactionName Reaction))
|
|
||||||
|
|
||||||
(: list-enabled (-> ReactionSystem (Setof Species) (Listof ReactionName)))
|
|
||||||
(define (list-enabled rs s)
|
|
||||||
(for/list ([(name reaction) (in-hash rs)]
|
|
||||||
#:when (enabled? reaction s))
|
|
||||||
name))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "list-enabled"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(z))))
|
|
||||||
(check-equal? (list-enabled rs (set 'x 'y)) '(b))
|
|
||||||
(check-equal? (list-enabled rs (set 'x)) '(a))))
|
|
||||||
|
|
||||||
(: union-products (-> ReactionSystem (Listof ReactionName) (Setof Species)))
|
|
||||||
(define (union-products rs as)
|
|
||||||
(cond
|
|
||||||
[(empty? as) (set)]
|
|
||||||
[else (define products (for/list : (Listof (Setof Species))
|
|
||||||
([a as])
|
|
||||||
(reaction-products (hash-ref rs a))))
|
|
||||||
(apply set-union (assert-type products (NonemptyListof (Setof Species))))]))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "union-products"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(t))))
|
|
||||||
(check-equal? (union-products rs '(a b))
|
|
||||||
(set 't 'z))
|
|
||||||
(check-equal? (union-products rs '(a))
|
|
||||||
(set 'z))
|
|
||||||
(check-equal? (union-products rs '())
|
|
||||||
(set))))
|
|
||||||
|
|
||||||
(: apply-rs (-> ReactionSystem (Setof Species) (Setof Species)))
|
|
||||||
(define (apply-rs rs s)
|
|
||||||
(let ([as (list-enabled rs s)])
|
|
||||||
(union-products rs as)))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "apply-rs"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(t))))
|
|
||||||
(check-equal? (apply-rs rs (set 'x 'y))
|
|
||||||
(set 't))
|
|
||||||
(check-equal? (apply-rs rs (set 'x))
|
|
||||||
(set 'z))))
|
|
||||||
|
|
||||||
(: str-triple->reaction (-> (List String String String) Reaction))
|
|
||||||
(define/match (str-triple->reaction lst)
|
|
||||||
[((list str-reactants str-inhibitors str-products))
|
|
||||||
(reaction (list->set (read-symbol-list str-reactants))
|
|
||||||
(list->set (read-symbol-list str-inhibitors))
|
|
||||||
(list->set (read-symbol-list str-products)))])
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "str-triple->reaction"
|
|
||||||
(check-equal? (str-triple->reaction '("a b" "c d" "e f"))
|
|
||||||
(reaction (set 'b 'a) (set 'c 'd) (set 'f 'e)))))
|
|
||||||
|
|
||||||
(: ht-str-triples->rs (-> (HashTable ReactionName (List String String String))
|
|
||||||
ReactionSystem))
|
|
||||||
(define (ht-str-triples->rs ht)
|
|
||||||
(for/hash : (HashTable ReactionName Reaction)
|
|
||||||
([(a triple) (in-hash ht)])
|
|
||||||
(values a (str-triple->reaction triple))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "ht-str-triples->rs"
|
|
||||||
(check-equal? (ht-str-triples->rs (hash 'a (list "x y" "" "k i")
|
|
||||||
'b (list "" "x y" "t j")))
|
|
||||||
(hash 'a (reaction (set 'y 'x) (set) (set 'k 'i))
|
|
||||||
'b (reaction (set) (set 'y 'x) (set 't 'j))))))
|
|
||||||
|
|
||||||
(: read-org-rs (-> String ReactionSystem))
|
|
||||||
(define (read-org-rs str)
|
|
||||||
(ht-str-triples->rs
|
|
||||||
(assert-type (read-org-variable-mapping str)
|
|
||||||
(Immutable-HashTable ReactionName (List String String String)))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "read-org-rs"
|
|
||||||
(check-equal?
|
|
||||||
(read-org-rs "((\"a\" \"x t\" \"y\" \"z\") (\"b\" \"x\" \"q\" \"z\"))")
|
|
||||||
(hash 'a (reaction (set 't 'x) (set 'y) (set 'z))
|
|
||||||
'b (reaction (set 'x) (set 'q) (set 'z))))))
|
|
||||||
|
|
||||||
(: read-context-sequence (-> String (Listof (Setof Species))))
|
|
||||||
(define (read-context-sequence str)
|
|
||||||
(for/list ([sexp (in-list (flatten (string->any str)))])
|
|
||||||
(list->set (read-symbol-list (assert-type sexp String)))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "read-context-sequence"
|
|
||||||
(check-equal? (read-context-sequence "((\"x y\") (\"z\") (\"\") (\"t\"))")
|
|
||||||
(list (set 'x 'y) (set 'z) (set) (set 't)))))
|
|
||||||
|
|
||||||
(: reaction->str-triple (-> Reaction (Listof String)))
|
|
||||||
(define/match (reaction->str-triple r)
|
|
||||||
[((reaction r i p))
|
|
||||||
(for/list ([c (in-list (list r i p))])
|
|
||||||
(drop-first-last (any->string (set->list c))))])
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "reaction->str-triple"
|
|
||||||
(check-equal? (reaction->str-triple (make-reaction '(x y) '(z t) '(k i)))
|
|
||||||
'("x y" "z t" "i k"))))
|
|
||||||
|
|
||||||
(: rs->ht-str-triples (-> ReactionSystem (HashTable ReactionName (Listof String))))
|
|
||||||
(define (rs->ht-str-triples rs)
|
|
||||||
(for/hash : (HashTable ReactionName (Listof String))
|
|
||||||
([(a r) (in-hash rs)])
|
|
||||||
(values a (reaction->str-triple r))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "rs->ht-str-triples"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(t))))
|
|
||||||
(check-equal? (rs->ht-str-triples rs)
|
|
||||||
(hash 'a (list "x" "y" "z")
|
|
||||||
'b (list "x y" "" "t")))))
|
|
||||||
|
|
||||||
(struct state ([result : (Setof Species)]
|
|
||||||
[rest-contexts : (Listof (Setof Species))])
|
|
||||||
#:transparent
|
|
||||||
#:type-name State)
|
|
||||||
|
|
||||||
(define dynamics%
|
|
||||||
(class (inst dds% State (Listof ReactionName))
|
|
||||||
(super-new)
|
|
||||||
(init-field [rs : ReactionSystem])
|
|
||||||
(: step/annotated (-> State (Listof (Pairof (Listof ReactionName) State))))
|
|
||||||
(define/override (step/annotated s)
|
|
||||||
(match s
|
|
||||||
[(state res (cons ctx rest-ctx))
|
|
||||||
(define full-s (set-union ctx res))
|
|
||||||
(define en (list-enabled rs full-s))
|
|
||||||
(list (cons en (state (union-products rs en) rest-ctx)))]
|
|
||||||
[(state _'()) '()]))))
|
|
||||||
|
|
||||||
(define-type Dynamics%
|
|
||||||
(Instance (Class
|
|
||||||
(init (rs ReactionSystem))
|
|
||||||
(field (rs ReactionSystem))
|
|
||||||
(build-state-graph (-> (Listof State) Graph))
|
|
||||||
(build-state-graph*
|
|
||||||
(-> (Listof State) (U 'full Exact-Positive-Integer) Graph))
|
|
||||||
(build-state-graph*/annotated
|
|
||||||
(-> (Listof State) (U 'full Exact-Positive-Integer) Graph))
|
|
||||||
(build-state-graph/annotated (-> (Listof State) Graph))
|
|
||||||
(step (-> State (Listof State)))
|
|
||||||
(step* (-> (Listof State) (Listof State)))
|
|
||||||
(step/annotated (-> State (Listof (Pairof (Listof Variable) State)))))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "dynamics%:step/annotated"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define dyn (new dynamics% [rs rs]))
|
|
||||||
(define s0 (state (set 'x 'y)
|
|
||||||
(list (set) (set) (set 'x))))
|
|
||||||
(define-values (_ 3-steps)
|
|
||||||
(for/fold ([last-s : State s0]
|
|
||||||
[trace : (Listof (Pairof (Listof ReactionName) State)) '()])
|
|
||||||
([_ (in-range 1 4)])
|
|
||||||
(define trans (send dyn step/annotated last-s))
|
|
||||||
(values (cdar trans) (append trace trans))))
|
|
||||||
(check-equal? 3-steps
|
|
||||||
(list
|
|
||||||
(cons '(b) (state (set 'x) (list (set) (set 'x))))
|
|
||||||
(cons '(a) (state (set 'z) (list (set 'x))))
|
|
||||||
(cons '(a) (state (set 'z) '()))))))
|
|
||||||
|
|
||||||
(: build-interactive-process-graph (-> ReactionSystem (Listof (Setof Species)) Graph))
|
|
||||||
(define (build-interactive-process-graph rs contexts)
|
|
||||||
(send (new dynamics% [rs rs])
|
|
||||||
build-state-graph/annotated
|
|
||||||
(list (state (set) contexts))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "build-interactive-process-graph"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
|
||||||
(check-equal? (graphviz (build-interactive-process-graph rs ctx))
|
|
||||||
"digraph G {\n\tnode0 [label=\"(state (set) '(#<set: x>))\"];\n\tnode1 [label=\"(state (set 'z) '())\"];\n\tnode2 [label=\"(state (set) '(#<set:> #<set: x>))\"];\n\tnode3 [label=\"(state (set) '(#<set:> #<set:> #<set: x>))\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"'(a)\"];\n\t\tnode2 -> node0 [label=\"'()\"];\n\t\tnode3 -> node2 [label=\"'()\"];\n\t}\n}\n")))
|
|
||||||
|
|
||||||
(: build-interactive-process-graph/simple-states (-> ReactionSystem (Listof (Setof Species)) Graph))
|
|
||||||
(define (build-interactive-process-graph/simple-states rs contexts)
|
|
||||||
(define sgr (build-interactive-process-graph rs contexts))
|
|
||||||
(weighted-graph/directed
|
|
||||||
(for/list ([e (in-edges sgr)])
|
|
||||||
(define u (assert-type (car e) State))
|
|
||||||
(define v (assert-type (cadr e) State))
|
|
||||||
(list (edge-weight sgr u v) (state-result u) (state-result v)))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "build-interactive-process-graph/simple-states"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
|
||||||
(check-equal? (graphviz (build-interactive-process-graph/simple-states rs ctx))
|
|
||||||
"digraph G {\n\tnode0 [label=\"(set)\"];\n\tnode1 [label=\"(set 'z)\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"'()\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"'(a)\"];\n\t}\n}\n")))
|
|
||||||
|
|
||||||
(: pretty-print-state-graph/simple-states (-> Graph Graph))
|
|
||||||
(define (pretty-print-state-graph/simple-states sgr)
|
|
||||||
(update-graph
|
|
||||||
sgr
|
|
||||||
#:v-func
|
|
||||||
(λ (st) (~a "{" (pretty-print-set (assert-type st (Setof Species))) "}"))
|
|
||||||
#:e-func
|
|
||||||
(λ (e) (pretty-print-set (assert-type e (Listof ReactionName))))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "pretty-print-state-graph/simple-states"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
|
||||||
(check-equal?
|
|
||||||
(graphviz (pretty-print-state-graph/simple-states
|
|
||||||
(build-interactive-process-graph/simple-states rs ctx)))
|
|
||||||
"digraph G {\n\tnode0 [label=\"{}\"];\n\tnode1 [label=\"{z}\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"a\"];\n\t}\n}\n")
|
|
||||||
))
|
|
||||||
|
|
||||||
(: build-interactive-process (-> ReactionSystem (Listof (Setof Species))
|
|
||||||
(Listof (Pairof (Setof Species) (Setof Species)))))
|
|
||||||
(define (build-interactive-process rs contexts)
|
|
||||||
(define dyn (new dynamics% [rs rs]))
|
|
||||||
(define padded-contexts
|
|
||||||
(append contexts (list (assert-type (set) (Setof Species)))))
|
|
||||||
(for/fold ([proc : (Listof (Pairof (Setof Species) (Setof Species))) '()]
|
|
||||||
[st : State (state (set) padded-contexts)]
|
|
||||||
#:result (reverse proc))
|
|
||||||
([c padded-contexts])
|
|
||||||
(define res (state-result st))
|
|
||||||
(define ctx (state-rest-contexts st))
|
|
||||||
(values
|
|
||||||
((inst cons (Pairof (Setof Species) (Setof Species)))
|
|
||||||
(cons (if (empty? ctx) (assert-type (set) (Setof Species)) (car ctx)) res)
|
|
||||||
proc)
|
|
||||||
(set-first (send dyn step st)))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "build-interactive-process"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define ctx : (Listof (Setof Species)) (list (set 'x 'y) (set) (set 'x) (set)))
|
|
||||||
(check-equal? (build-interactive-process rs ctx)
|
|
||||||
(list
|
|
||||||
(cons (set 'y 'x) (set))
|
|
||||||
(cons (set) (set 'x))
|
|
||||||
(cons (set 'x) (set 'z))
|
|
||||||
(cons (set) (set 'z))
|
|
||||||
(cons (set) (set))))))
|
|
||||||
|
|
||||||
(: build-interactive-process/org (-> ReactionSystem (Listof (Setof Species))
|
|
||||||
(Listof (Listof (Setof Species)))))
|
|
||||||
(define (build-interactive-process/org rs context)
|
|
||||||
(for/list : (Listof (Listof (Setof Species)))
|
|
||||||
([p (build-interactive-process rs context)])
|
|
||||||
(list (car p) (cdr p))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "build-interactive-process/org"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define ctx : (Listof (Setof Species)) (list (set 'x 'y) (set) (set 'x) (set)))
|
|
||||||
(check-equal? (build-interactive-process/org rs ctx)
|
|
||||||
(list
|
|
||||||
(list (set 'y 'x) (set))
|
|
||||||
(list (set) (set 'x))
|
|
||||||
(list (set 'x) (set 'z))
|
|
||||||
(list (set) (set 'z))
|
|
||||||
(list (set) (set))))))
|
|
||||||
|
|
||||||
(: pretty-print-state (-> State String))
|
|
||||||
(define/match (pretty-print-state st)
|
|
||||||
[((state res ctx))
|
|
||||||
(format "C:~a\nD:{~a}" (pretty-print-set-sets ctx) (pretty-print-set res))])
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "pretty-print-state"
|
|
||||||
(check-equal? (pretty-print-state
|
|
||||||
(state (set 'x 'y) (list (set 'z) (set) (set 'x))))
|
|
||||||
"C:{z}{}{x}\nD:{x y}")))
|
|
||||||
|
|
||||||
(: pretty-print-state-graph (-> Graph Graph))
|
|
||||||
(define (pretty-print-state-graph sgr)
|
|
||||||
(update-graph
|
|
||||||
sgr
|
|
||||||
#:v-func (λ (st) (pretty-print-state (assert-type st State)))
|
|
||||||
#:e-func (λ (e) (pretty-print-set (assert-type e (Listof ReactionName))))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(test-case "pretty-print-state-graph"
|
|
||||||
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
|
||||||
'b (make-reaction '(x y) '() '(x))))
|
|
||||||
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
|
||||||
(check-equal? (graphviz (build-interactive-process-graph rs ctx))
|
|
||||||
"digraph G {\n\tnode0 [label=\"(state (set) '(#<set: x>))\"];\n\tnode1 [label=\"(state (set 'z) '())\"];\n\tnode2 [label=\"(state (set) '(#<set:> #<set: x>))\"];\n\tnode3 [label=\"(state (set) '(#<set:> #<set:> #<set: x>))\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"'(a)\"];\n\t\tnode2 -> node0 [label=\"'()\"];\n\t\tnode3 -> node2 [label=\"'()\"];\n\t}\n}\n")
|
|
||||||
))
|
|
||||||
)
|
|
||||||
|
|
||||||
(require graph "utils.rkt" "generic.rkt")
|
|
||||||
|
|
||||||
(provide
|
(provide
|
||||||
;; Structures
|
Species (struct-out reaction) Reaction ReactionName ReactionSystem
|
||||||
(struct-out reaction)
|
make-reaction enabled? list-enabled union-products apply-rs
|
||||||
(struct-out state)
|
|
||||||
(struct-out dynamics)
|
str-triple->reaction ht-str-triples->rs read-org-rs read-context-sequence
|
||||||
;; Functions
|
reaction->str-triple rs->ht-str-triples
|
||||||
(contract-out [enabled? (-> reaction? (set/c symbol?) boolean?)]
|
|
||||||
[list-enabled (-> reaction-system/c (set/c species?) (listof symbol?))]
|
(struct-out state) State dynamics% Dynamics% build-interactive-process-graph
|
||||||
[union-products (-> reaction-system/c (listof symbol?) (set/c species?))]
|
build-interactive-process-graph/simple-states
|
||||||
[apply-rs (-> reaction-system/c (set/c species?) (set/c species?))]
|
pretty-print-state-graph/simple-states build-interactive-process
|
||||||
[ht-str-triples->rs (-> (hash/c symbol? (list/c string? string? string?)) reaction-system/c)]
|
build-interactive-process/org pretty-print-state pretty-print-state-graph
|
||||||
[read-org-rs (-> string? reaction-system/c)]
|
)
|
||||||
[read-context-sequence (-> string? (listof (set/c species?)))]
|
|
||||||
[rs->ht-str-triples (-> reaction-system/c (hash/c symbol? (list/c string? string? string?)))]
|
|
||||||
[dds-step-one (-> dynamics? state? (set/c state?))]
|
|
||||||
[dds-step-one-annotated (-> dynamics? state? (set/c (cons/c (set/c symbol?) state?)))]
|
|
||||||
[dds-step (-> dynamics? (set/c state? #:kind 'dont-care) (set/c state?))]
|
|
||||||
[dds-build-state-graph (-> dynamics? (set/c state? #:kind 'dont-care) graph?)]
|
|
||||||
[dds-build-n-step-state-graph (-> dynamics? (set/c state? #:kind 'dont-care) number? graph?)]
|
|
||||||
[dds-build-state-graph-annotated (-> dynamics? (set/c state? #:kind 'dont-care) graph?)]
|
|
||||||
[dds-build-n-step-state-graph-annotated (-> dynamics? (set/c state? #:kind 'dont-care) number? graph?)]
|
|
||||||
[build-interactive-process-graph (-> reaction-system/c (listof (set/c species?)) graph?)]
|
|
||||||
[build-reduced-state-graph (-> reaction-system/c (listof (set/c species?)) graph?)]
|
|
||||||
[pretty-print-reduced-state-graph (-> graph? graph?)]
|
|
||||||
[build-interactive-process (-> reaction-system/c (listof (set/c species?)) (listof (list/c (set/c species?) (set/c species?))))]
|
|
||||||
[pretty-print-state-graph (-> graph? graph?)])
|
|
||||||
;; Predicates
|
|
||||||
(contract-out [species? (-> any/c boolean?)])
|
|
||||||
;; Contracts
|
|
||||||
(contract-out [reaction-system/c contract?]))
|
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(require rackunit))
|
(require typed/rackunit))
|
||||||
|
|
||||||
|
(define-type Species Symbol)
|
||||||
|
|
||||||
;;; =================
|
(struct reaction ([reactants : (Setof Species)]
|
||||||
;;; Basic definitions
|
[inhibitors : (Setof Species)]
|
||||||
;;; =================
|
[products : (Setof Species)])
|
||||||
|
#:transparent
|
||||||
|
#:type-name Reaction)
|
||||||
|
|
||||||
;;; A species is a symbol.
|
(define-type ReactionName Symbol)
|
||||||
(define species? symbol?)
|
|
||||||
|
|
||||||
;;; A reaction is a triple of sets, giving the reactants, the
|
(: make-reaction (-> (Listof Species) (Listof Species) (Listof Species) Reaction))
|
||||||
;;; inhibitors, and the products, respectively.
|
(define (make-reaction r i p) (reaction (list->set r)
|
||||||
(struct reaction (reactants inhibitors products) #:transparent)
|
(list->set i)
|
||||||
|
(list->set p)))
|
||||||
|
(module+ test
|
||||||
|
(test-case "make-reaction"
|
||||||
|
(check-equal? (make-reaction '(a b) '(c d) '(e f))
|
||||||
|
(reaction (set 'b 'a) (set 'c 'd) (set 'f 'e)))))
|
||||||
|
|
||||||
;;; A reaction is enabled on a set if all of its reactants are in the
|
(: enabled? (-> Reaction (Setof Species) Boolean))
|
||||||
;;; set and none of its inhibitors are.
|
|
||||||
(define/match (enabled? r s)
|
(define/match (enabled? r s)
|
||||||
[((reaction r i p) s)
|
[((reaction r i _) s)
|
||||||
(and (subset? r s) (set-empty? (set-intersect i s)))])
|
(and (subset? r s) (set-empty? (set-intersect i s)))])
|
||||||
|
|
||||||
;;; A reaction system is a dictionary mapping reaction names to
|
(module+ test
|
||||||
;;; reactions.
|
(test-case "enabled?"
|
||||||
(define reaction-system/c (hash/c symbol? reaction?))
|
(check-true (enabled? (make-reaction '(a b) '(c d) '())
|
||||||
|
(set 'a 'b 'e)))
|
||||||
|
(check-false (enabled? (make-reaction '(a b) '(c d) '())
|
||||||
|
(set 'a 'b 'c)))
|
||||||
|
(check-false (enabled? (make-reaction '(a b) '(c d) '())
|
||||||
|
(set 'b 'e)))))
|
||||||
|
|
||||||
;;; Returns the list of reaction names enabled on a given set.
|
(define-type ReactionSystem (HashTable ReactionName Reaction))
|
||||||
|
|
||||||
|
(: list-enabled (-> ReactionSystem (Setof Species) (Listof ReactionName)))
|
||||||
(define (list-enabled rs s)
|
(define (list-enabled rs s)
|
||||||
(for/list ([(name reaction) (in-hash rs)]
|
(for/list ([(name reaction) (in-hash rs)]
|
||||||
#:when (enabled? reaction s))
|
#:when (enabled? reaction s))
|
||||||
name))
|
name))
|
||||||
|
|
||||||
;;; Returns the union of the product sets of the given reactions in a
|
(module+ test
|
||||||
;;; reaction system. If no reactions are supplied, returns the empty
|
(test-case "list-enabled"
|
||||||
;;; set.
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
;;;
|
'b (make-reaction '(x y) '() '(z))))
|
||||||
;;; This function can be seen as producing the result of the
|
(check-equal? (list-enabled rs (set 'x 'y)) '(b))
|
||||||
;;; application of the given reactions to a set. Clearly, it does not
|
(check-equal? (list-enabled rs (set 'x)) '(a))))
|
||||||
;;; check whether the reactions are actually enabled.
|
|
||||||
(define (union-products rs as)
|
|
||||||
(if (empty? as)
|
|
||||||
(set)
|
|
||||||
(apply set-union
|
|
||||||
(for/list ([a as])
|
|
||||||
(reaction-products (hash-ref rs a))))))
|
|
||||||
|
|
||||||
;;; Applies a reaction system to a set.
|
(: union-products (-> ReactionSystem (Listof ReactionName) (Setof Species)))
|
||||||
|
(define (union-products rs as)
|
||||||
|
(cond
|
||||||
|
[(empty? as) (set)]
|
||||||
|
[else (define products (for/list : (Listof (Setof Species))
|
||||||
|
([a as])
|
||||||
|
(reaction-products (hash-ref rs a))))
|
||||||
|
(apply set-union (assert-type products (NonemptyListof (Setof Species))))]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(test-case "union-products"
|
||||||
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
|
'b (make-reaction '(x y) '() '(t))))
|
||||||
|
(check-equal? (union-products rs '(a b))
|
||||||
|
(set 't 'z))
|
||||||
|
(check-equal? (union-products rs '(a))
|
||||||
|
(set 'z))
|
||||||
|
(check-equal? (union-products rs '())
|
||||||
|
(set))))
|
||||||
|
|
||||||
|
(: apply-rs (-> ReactionSystem (Setof Species) (Setof Species)))
|
||||||
(define (apply-rs rs s)
|
(define (apply-rs rs s)
|
||||||
(let ([as (list-enabled rs s)])
|
(let ([as (list-enabled rs s)])
|
||||||
(union-products rs as)))
|
(union-products rs as)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "Basic definitions"
|
(test-case "apply-rs"
|
||||||
(define r1 (reaction (set 'x) (set 'y) (set 'z)))
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
(define r2 (reaction (set 'x) (set) (set 'y)))
|
'b (make-reaction '(x y) '() '(t))))
|
||||||
(define rs (make-immutable-hash (list (cons 'a r1) (cons 'b r2))))
|
(check-equal? (apply-rs rs (set 'x 'y))
|
||||||
(define s1 (set 'x 'z))
|
(set 't))
|
||||||
(define s2 (set 'x 'y))
|
(check-equal? (apply-rs rs (set 'x))
|
||||||
(check-true (enabled? r1 s1))
|
(set 'z))))
|
||||||
(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))))
|
|
||||||
|
|
||||||
|
(: str-triple->reaction (-> (List String String String) Reaction))
|
||||||
;;; ====================
|
|
||||||
;;; Org-mode interaction
|
|
||||||
;;; ====================
|
|
||||||
|
|
||||||
;;; This section contains some useful primitives for Org-mode
|
|
||||||
;;; interoperability.
|
|
||||||
|
|
||||||
;;; Converts a triple of strings to a reaction.
|
|
||||||
(define/match (str-triple->reaction lst)
|
(define/match (str-triple->reaction lst)
|
||||||
[((list str-reactants str-inhibitors str-products))
|
[((list str-reactants str-inhibitors str-products))
|
||||||
(reaction (list->set (read-symbol-list str-reactants))
|
(reaction (list->set (read-symbol-list str-reactants))
|
||||||
(list->set (read-symbol-list str-inhibitors))
|
(list->set (read-symbol-list str-inhibitors))
|
||||||
(list->set (read-symbol-list str-products)))])
|
(list->set (read-symbol-list str-products)))])
|
||||||
|
|
||||||
;;; Converts a hash table mapping reaction names to triples of strings
|
(module+ test
|
||||||
;;; to a reaction system.
|
(test-case "str-triple->reaction"
|
||||||
|
(check-equal? (str-triple->reaction '("a b" "c d" "e f"))
|
||||||
|
(reaction (set 'b 'a) (set 'c 'd) (set 'f 'e)))))
|
||||||
|
|
||||||
|
(: ht-str-triples->rs (-> (HashTable ReactionName (List String String String))
|
||||||
|
ReactionSystem))
|
||||||
(define (ht-str-triples->rs ht)
|
(define (ht-str-triples->rs ht)
|
||||||
(for/hash ([(a triple) (in-hash ht)])
|
(for/hash : (HashTable ReactionName Reaction)
|
||||||
|
([(a triple) (in-hash ht)])
|
||||||
(values a (str-triple->reaction triple))))
|
(values a (str-triple->reaction triple))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "ht-str-triples->rs"
|
(test-case "ht-str-triples->rs"
|
||||||
(check-equal?
|
(check-equal? (ht-str-triples->rs (hash 'a (list "x y" "" "k i")
|
||||||
(ht-str-triples->rs #hash((a . ("x t" "y" "z"))))
|
'b (list "" "x y" "t j")))
|
||||||
(make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z))))))))
|
(hash 'a (reaction (set 'y 'x) (set) (set 'k 'i))
|
||||||
|
'b (reaction (set) (set 'y 'x) (set 't 'j))))))
|
||||||
|
|
||||||
;;; Reads a reaction system from an Org-mode style string.
|
(: read-org-rs (-> String ReactionSystem))
|
||||||
(define read-org-rs (compose ht-str-triples->rs read-org-variable-mapping))
|
(define (read-org-rs str)
|
||||||
|
(ht-str-triples->rs
|
||||||
|
(assert-type (read-org-variable-mapping str)
|
||||||
|
(Immutable-HashTable ReactionName (List String String String)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "read-org-rs"
|
(test-case "read-org-rs"
|
||||||
(check-equal? (read-org-rs "((\"a\" \"x t\" \"y\" \"z\") (\"b\" \"x\" \"q\" \"z\"))")
|
(check-equal?
|
||||||
(hash
|
(read-org-rs "((\"a\" \"x t\" \"y\" \"z\") (\"b\" \"x\" \"q\" \"z\"))")
|
||||||
'a
|
(hash 'a (reaction (set 't 'x) (set 'y) (set 'z))
|
||||||
(reaction (set 'x 't) (set 'y) (set 'z))
|
'b (reaction (set 'x) (set 'q) (set 'z))))))
|
||||||
'b
|
|
||||||
(reaction (set 'x) (set 'q) (set 'z))))))
|
|
||||||
|
|
||||||
;;; Reads a context sequence from an Org sexp corresponding to a list.
|
(: read-context-sequence (-> String (Listof (Setof Species))))
|
||||||
(define (read-context-sequence str)
|
(define (read-context-sequence str)
|
||||||
(map (compose list->set read-symbol-list) (flatten (string->any str))))
|
(for/list ([sexp (in-list (flatten (string->any str)))])
|
||||||
|
(list->set (read-symbol-list (assert-type sexp String)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "read-context-sequence"
|
(test-case "read-context-sequence"
|
||||||
(check-equal? (read-context-sequence "((\"x y\") (\"z\") (\"\") (\"t\"))")
|
(check-equal? (read-context-sequence "((\"x y\") (\"z\") (\"\") (\"t\"))")
|
||||||
(list (set 'x 'y) (set 'z) (set) (set 't)))))
|
(list (set 'x 'y) (set 'z) (set) (set 't)))))
|
||||||
|
|
||||||
;;; Converts a reaction to a triple of strings.
|
(: reaction->str-triple (-> Reaction (Listof String)))
|
||||||
(define/match (reaction->str-triple r)
|
(define/match (reaction->str-triple r)
|
||||||
[((reaction r i p))
|
[((reaction r i p))
|
||||||
(map (compose drop-first-last any->string set->list)
|
(for/list ([c (in-list (list r i p))])
|
||||||
(list r i p))])
|
(drop-first-last (any->string (set->list c))))])
|
||||||
|
|
||||||
;;; Converts a reaction system to a hash table mapping reaction names
|
(module+ test
|
||||||
;;; to triples of strings.
|
(test-case "reaction->str-triple"
|
||||||
|
(check-equal? (reaction->str-triple (make-reaction '(x y) '(z t) '(k i)))
|
||||||
|
'("x y" "z t" "i k"))))
|
||||||
|
|
||||||
|
(: rs->ht-str-triples (-> ReactionSystem (HashTable ReactionName (Listof String))))
|
||||||
(define (rs->ht-str-triples rs)
|
(define (rs->ht-str-triples rs)
|
||||||
(for/hash ([(a r) (in-hash rs)])
|
(for/hash : (HashTable ReactionName (Listof String))
|
||||||
|
([(a r) (in-hash rs)])
|
||||||
(values a (reaction->str-triple r))))
|
(values a (reaction->str-triple r))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "rs->ht-str-triples"
|
(test-case "rs->ht-str-triples"
|
||||||
(check-equal?
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
(rs->ht-str-triples (make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z))))))
|
'b (make-reaction '(x y) '() '(t))))
|
||||||
#hash((a . ("t x" "y" "z"))))))
|
(check-equal? (rs->ht-str-triples rs)
|
||||||
|
(hash 'a (list "x" "y" "z")
|
||||||
|
'b (list "x y" "" "t")))))
|
||||||
|
|
||||||
|
(struct state ([result : (Setof Species)]
|
||||||
|
[rest-contexts : (Listof (Setof Species))])
|
||||||
|
#:transparent
|
||||||
|
#:type-name State)
|
||||||
|
|
||||||
;;; ============================
|
(define dynamics%
|
||||||
;;; Dynamics of reaction systems
|
(class (inst dds% State (Listof ReactionName))
|
||||||
;;; ============================
|
(super-new)
|
||||||
|
(init-field [rs : ReactionSystem])
|
||||||
|
(: step/annotated (-> State (Listof (Pairof (Listof ReactionName) State))))
|
||||||
|
(define/override (step/annotated s)
|
||||||
|
(match s
|
||||||
|
[(state res (cons ctx rest-ctx))
|
||||||
|
(define full-s (set-union ctx res))
|
||||||
|
(define en (list-enabled rs full-s))
|
||||||
|
(list (cons en (state (union-products rs en) rest-ctx)))]
|
||||||
|
[(state _'()) '()]))))
|
||||||
|
|
||||||
;;; An interactive process of a reaction system is a sequence of
|
(define-type Dynamics%
|
||||||
;;; states driven by a sequence of contexts in the following way.
|
(Instance (Class
|
||||||
;;; The reaction system starts with the initial context. Then, at
|
(init (rs ReactionSystem))
|
||||||
;;; every step, the result of applying the reaction system is merged
|
(field (rs ReactionSystem))
|
||||||
;;; with the next element of the context sequence, and the reaction
|
(build-state-graph (-> (Listof State) Graph))
|
||||||
;;; system is then applied to the result of the union. If the
|
(build-state-graph*
|
||||||
;;; sequence of contexts is empty, the reaction system cannot evolve.
|
(-> (Listof State) (U 'full Exact-Positive-Integer) Graph))
|
||||||
|
(build-state-graph*/annotated
|
||||||
|
(-> (Listof State) (U 'full Exact-Positive-Integer) Graph))
|
||||||
|
(build-state-graph/annotated (-> (Listof State) Graph))
|
||||||
|
(step (-> State (Listof State)))
|
||||||
|
(step* (-> (Listof State) (Listof State)))
|
||||||
|
(step/annotated (-> State (Listof (Pairof (Listof Variable) State)))))))
|
||||||
|
|
||||||
;;; A state of a reaction system is a set of species representing the
|
(module+ test
|
||||||
;;; result of the application of the reactions from the previous
|
(test-case "dynamics%:step/annotated"
|
||||||
;;; steps, plus the rest of the context sequence. When the context
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
;;; sequence is empty, nothing is added to the current state.
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
(struct state (result rest-contexts) #:transparent)
|
(define dyn (new dynamics% [rs rs]))
|
||||||
|
(define s0 (state (set 'x 'y)
|
||||||
|
(list (set) (set) (set 'x))))
|
||||||
|
(define-values (_ 3-steps)
|
||||||
|
(for/fold ([last-s : State s0]
|
||||||
|
[trace : (Listof (Pairof (Listof ReactionName) State)) '()])
|
||||||
|
([_ (in-range 1 4)])
|
||||||
|
(define trans (send dyn step/annotated last-s))
|
||||||
|
(values (cdar trans) (append trace trans))))
|
||||||
|
(check-equal? 3-steps
|
||||||
|
(list
|
||||||
|
(cons '(b) (state (set 'x) (list (set) (set 'x))))
|
||||||
|
(cons '(a) (state (set 'z) (list (set 'x))))
|
||||||
|
(cons '(a) (state (set 'z) '()))))))
|
||||||
|
|
||||||
;;; The dynamics of the reaction system only stores the reaction
|
(: build-interactive-process-graph (-> ReactionSystem (Listof (Setof Species)) Graph))
|
||||||
;;; system itself.
|
|
||||||
(struct dynamics (rs) #:transparent
|
|
||||||
#:methods gen:dds
|
|
||||||
[;; Since reaction systems are deterministic, a singleton set is
|
|
||||||
;; produced, unless the context sequence is empty, in which case an
|
|
||||||
;; empty set of states is generated. This transition is annotated
|
|
||||||
;; by the list of rules which were enabled in the current step.
|
|
||||||
(define (dds-step-one-annotated dyn st)
|
|
||||||
(define rs (dynamics-rs dyn))
|
|
||||||
(define (apply-rs-annotate s rest-ctx)
|
|
||||||
(define en (list-enabled rs s))
|
|
||||||
(set (cons (list->set en)
|
|
||||||
(state (union-products rs en) rest-ctx))))
|
|
||||||
(match st
|
|
||||||
[(state res (cons ctx rest-ctx))
|
|
||||||
(apply-rs-annotate (set-union res ctx) rest-ctx)]
|
|
||||||
[(state res '()) (set)]))])
|
|
||||||
|
|
||||||
;;; Builds the state graph of a reaction system driven by a given
|
|
||||||
;;; context sequence.
|
|
||||||
(define (build-interactive-process-graph rs contexts)
|
(define (build-interactive-process-graph rs contexts)
|
||||||
(dds-build-state-graph-annotated (dynamics rs)
|
(send (new dynamics% [rs rs])
|
||||||
(set (state (set) contexts))))
|
build-state-graph/annotated
|
||||||
|
(list (state (set) contexts))))
|
||||||
|
|
||||||
;;; Builds the reduced state graph of a reaction system driven by
|
(module+ test
|
||||||
;;; a given context sequence. Unlike build-interactive-process-graph,
|
(test-case "build-interactive-process-graph"
|
||||||
;;; the nodes of this state graph do not contain the context sequence.
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
(define (build-reduced-state-graph rs contexts)
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
|
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
||||||
|
(check-equal? (graphviz (build-interactive-process-graph rs ctx))
|
||||||
|
"digraph G {\n\tnode0 [label=\"(state (set) '(#<set: x>))\"];\n\tnode1 [label=\"(state (set 'z) '())\"];\n\tnode2 [label=\"(state (set) '(#<set:> #<set: x>))\"];\n\tnode3 [label=\"(state (set) '(#<set:> #<set:> #<set: x>))\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"'(a)\"];\n\t\tnode2 -> node0 [label=\"'()\"];\n\t\tnode3 -> node2 [label=\"'()\"];\n\t}\n}\n")))
|
||||||
|
|
||||||
|
(: build-interactive-process-graph/simple-states (-> ReactionSystem (Listof (Setof Species)) Graph))
|
||||||
|
(define (build-interactive-process-graph/simple-states rs contexts)
|
||||||
(define sgr (build-interactive-process-graph rs contexts))
|
(define sgr (build-interactive-process-graph rs contexts))
|
||||||
(weighted-graph/directed
|
(weighted-graph/directed
|
||||||
(for/list ([e (in-edges sgr)])
|
(for/list ([e (in-edges sgr)])
|
||||||
(define u (car e)) (define v (cadr e))
|
(define u (assert-type (car e) State))
|
||||||
|
(define v (assert-type (cadr e) State))
|
||||||
(list (edge-weight sgr u v) (state-result u) (state-result v)))))
|
(list (edge-weight sgr u v) (state-result u) (state-result v)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "build-reduced-state-graph"
|
(test-case "build-interactive-process-graph/simple-states"
|
||||||
(define rs (hash 'a (reaction (set 'x) (set 'y) (set 'z))
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
'b (reaction (set 'x) (set) (set 'y))))
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
(define ctx (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))
|
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
||||||
(check-equal? (graphviz (build-reduced-state-graph rs ctx))
|
(check-equal? (graphviz (build-interactive-process-graph/simple-states rs ctx))
|
||||||
"digraph G {\n\tnode0 [label=\"(set)\\n\"];\n\tnode1 [label=\"(set 'y 'z)\\n\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"#<set: #<set:>>\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"#<set: #<set: a b>>\"];\n\t\tnode1 -> node0 [label=\"#<set: #<set:>>\"];\n\t}\n}\n")))
|
"digraph G {\n\tnode0 [label=\"(set)\"];\n\tnode1 [label=\"(set 'z)\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"'()\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"'(a)\"];\n\t}\n}\n")))
|
||||||
|
|
||||||
(define (pretty-print-reduced-state-graph sgr)
|
(: pretty-print-state-graph/simple-states (-> Graph Graph))
|
||||||
(update-graph sgr
|
(define (pretty-print-state-graph/simple-states sgr)
|
||||||
#:v-func (λ (st) (~a "{" (pretty-print-set st) "}"))
|
(update-graph
|
||||||
#:e-func pretty-print-set-sets))
|
sgr
|
||||||
|
#:v-func
|
||||||
|
(λ (st) (~a "{" (pretty-print-set (assert-type st (Setof Species))) "}"))
|
||||||
|
#:e-func
|
||||||
|
(λ (e) (pretty-print-set (assert-type e (Listof ReactionName))))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "pretty-print-reduced-graph"
|
(test-case "pretty-print-state-graph/simple-states"
|
||||||
(define rs (hash 'a (reaction (set 'x) (set 'y) (set 'z))
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
'b (reaction (set 'x) (set) (set 'y))))
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
(define ctx (list (set 'x) (set 'y) (set 'z) (set) (set 'z)))
|
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
||||||
(define sgr (build-reduced-state-graph rs ctx))
|
(check-equal?
|
||||||
(graphviz (pretty-print-reduced-state-graph sgr))))
|
(graphviz (pretty-print-state-graph/simple-states
|
||||||
|
(build-interactive-process-graph/simple-states rs ctx)))
|
||||||
|
"digraph G {\n\tnode0 [label=\"{}\"];\n\tnode1 [label=\"{z}\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"a\"];\n\t}\n}\n")
|
||||||
|
))
|
||||||
|
|
||||||
|
(: build-interactive-process (-> ReactionSystem (Listof (Setof Species))
|
||||||
;;; Builds the interactive process driven by the given context
|
(Listof (Pairof (Setof Species) (Setof Species)))))
|
||||||
;;; sequence. The output is a list of pairs of lists in which the
|
|
||||||
;;; first element is the current context and the second element is the
|
|
||||||
;;; result of the application of reactions to the previous state. The
|
|
||||||
;;; interactive process stops one step after the end of the context
|
|
||||||
;;; sequence, to show the effect of the last context.
|
|
||||||
(define (build-interactive-process rs contexts)
|
(define (build-interactive-process rs contexts)
|
||||||
(let ([dyn (dynamics rs)]
|
(define dyn (new dynamics% [rs rs]))
|
||||||
[padded-contexts (append contexts (list (set)))])
|
(define padded-contexts
|
||||||
(for/fold ([proc '()]
|
(append contexts (list (assert-type (set) (Setof Species)))))
|
||||||
[st (state (set) padded-contexts)]
|
(for/fold ([proc : (Listof (Pairof (Setof Species) (Setof Species))) '()]
|
||||||
#:result (reverse proc))
|
[st : State (state (set) padded-contexts)]
|
||||||
([c padded-contexts])
|
#:result (reverse proc))
|
||||||
(values
|
([c padded-contexts])
|
||||||
(cons (match st
|
(define res (state-result st))
|
||||||
[(state res ctx)
|
(define ctx (state-rest-contexts st))
|
||||||
(list (if (empty? ctx) (set) (car ctx)) res)])
|
(values
|
||||||
proc)
|
((inst cons (Pairof (Setof Species) (Setof Species)))
|
||||||
(set-first (dds-step-one dyn st))))))
|
(cons (if (empty? ctx) (assert-type (set) (Setof Species)) (car ctx)) res)
|
||||||
|
proc)
|
||||||
|
(set-first (send dyn step st)))))
|
||||||
|
|
||||||
;;; Pretty-prints the context sequence and the current result of a
|
(module+ test
|
||||||
;;; state of the reaction system. Note that we need to keep the full
|
(test-case "build-interactive-process"
|
||||||
;;; context sequence in the name of each state to avoid confusion
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
;;; between the states at different steps of the evolution.
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
|
(define ctx : (Listof (Setof Species)) (list (set 'x 'y) (set) (set 'x) (set)))
|
||||||
|
(check-equal? (build-interactive-process rs ctx)
|
||||||
|
(list
|
||||||
|
(cons (set 'y 'x) (set))
|
||||||
|
(cons (set) (set 'x))
|
||||||
|
(cons (set 'x) (set 'z))
|
||||||
|
(cons (set) (set 'z))
|
||||||
|
(cons (set) (set))))))
|
||||||
|
|
||||||
|
(: build-interactive-process/org (-> ReactionSystem (Listof (Setof Species))
|
||||||
|
(Listof (Listof (Setof Species)))))
|
||||||
|
(define (build-interactive-process/org rs context)
|
||||||
|
(for/list : (Listof (Listof (Setof Species)))
|
||||||
|
([p (build-interactive-process rs context)])
|
||||||
|
(list (car p) (cdr p))))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(test-case "build-interactive-process/org"
|
||||||
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
|
(define ctx : (Listof (Setof Species)) (list (set 'x 'y) (set) (set 'x) (set)))
|
||||||
|
(check-equal? (build-interactive-process/org rs ctx)
|
||||||
|
(list
|
||||||
|
(list (set 'y 'x) (set))
|
||||||
|
(list (set) (set 'x))
|
||||||
|
(list (set 'x) (set 'z))
|
||||||
|
(list (set) (set 'z))
|
||||||
|
(list (set) (set))))))
|
||||||
|
|
||||||
|
(: pretty-print-state (-> State String))
|
||||||
(define/match (pretty-print-state st)
|
(define/match (pretty-print-state st)
|
||||||
[((state res ctx))
|
[((state res ctx))
|
||||||
(format "C:~a\nD:{~a}" (pretty-print-set-sets ctx) (pretty-print-set res))])
|
(format "C:~a\nD:{~a}" (pretty-print-set-sets ctx) (pretty-print-set res))])
|
||||||
|
|
||||||
;;; Pretty prints the state graph of a reaction system.
|
(module+ test
|
||||||
|
(test-case "pretty-print-state"
|
||||||
|
(check-equal? (pretty-print-state
|
||||||
|
(state (set 'x 'y) (list (set 'z) (set) (set 'x))))
|
||||||
|
"C:{z}{}{x}\nD:{x y}")))
|
||||||
|
|
||||||
|
(: pretty-print-state-graph (-> Graph Graph))
|
||||||
(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 (λ (st) (pretty-print-state (assert-type st State)))
|
||||||
|
#:e-func (λ (e) (pretty-print-set (assert-type e (Listof ReactionName))))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(test-case "Dynamics of reaction systems"
|
(test-case "pretty-print-state-graph"
|
||||||
(define r1 (reaction (set 'x) (set 'y) (set 'z)))
|
(define rs (hash 'a (make-reaction '(x) '(y) '(z))
|
||||||
(define r2 (reaction (set 'x) (set) (set 'y)))
|
'b (make-reaction '(x y) '() '(x))))
|
||||||
(define rs (make-immutable-hash (list (cons 'a r1) (cons 'b r2))))
|
(define ctx : (Listof (Setof Species)) (list (set) (set) (set 'x)))
|
||||||
(define dyn (dynamics rs))
|
(check-equal? (graphviz (build-interactive-process-graph rs ctx))
|
||||||
(define state1 (state (set) (list (set 'x) (set 'y) (set 'z) (set) (set 'z))))
|
"digraph G {\n\tnode0 [label=\"(state (set) '(#<set: x>))\"];\n\tnode1 [label=\"(state (set 'z) '())\"];\n\tnode2 [label=\"(state (set) '(#<set:> #<set: x>))\"];\n\tnode3 [label=\"(state (set) '(#<set:> #<set:> #<set: x>))\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"'(a)\"];\n\t\tnode2 -> node0 [label=\"'()\"];\n\t\tnode3 -> node2 [label=\"'()\"];\n\t}\n}\n")
|
||||||
(define sgr (dds-build-state-graph-annotated dyn (set state1)))
|
))
|
||||||
(define 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-false (has-edge? sgr
|
|
||||||
(state (set) '())
|
|
||||||
(state (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))))))
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
#lang scribble/manual
|
#lang scribble/manual
|
||||||
@(require scribble/example racket/sandbox
|
@(require scribble/example racket/sandbox
|
||||||
(for-label typed/racket/base
|
(for-label typed/racket/base
|
||||||
(submod "../rs.rkt" typed)
|
"../rs.rkt"
|
||||||
"../utils.rkt"
|
"../utils.rkt"
|
||||||
"../dynamics.rkt"))
|
"../dynamics.rkt"))
|
||||||
|
|
||||||
|
|
@ -10,7 +10,7 @@
|
||||||
[sandbox-error-output 'string]
|
[sandbox-error-output 'string]
|
||||||
[sandbox-memory-limit 500])
|
[sandbox-memory-limit 500])
|
||||||
(make-evaluator 'typed/racket
|
(make-evaluator 'typed/racket
|
||||||
#:requires '((submod "rs.rkt" typed) "utils.rkt"))))
|
#:requires '("rs.rkt" "utils.rkt"))))
|
||||||
|
|
||||||
@(define-syntax-rule (ex . args)
|
@(define-syntax-rule (ex . args)
|
||||||
(examples #:eval rs-evaluator . args))
|
(examples #:eval rs-evaluator . args))
|
||||||
|
|
@ -23,7 +23,7 @@
|
||||||
|
|
||||||
@title[#:tag "rs"]{dds/rs: Reaction Systems}
|
@title[#:tag "rs"]{dds/rs: Reaction Systems}
|
||||||
|
|
||||||
@defmodule[(submod dds/rs typed)]
|
@defmodule[dds/rs]
|
||||||
|
|
||||||
This module defines reaction systems and various tools for working with them.
|
This module defines reaction systems and various tools for working with them.
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue