dds/rs.rkt

356 lines
15 KiB
Racket
Raw Normal View History

2023-08-24 23:37:17 +02:00
#lang typed/racket
(require typed/graph "utils.rkt" "dynamics.rkt")
2020-03-01 19:05:28 +01:00
(provide
2023-08-24 23:37:17 +02:00
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
)
2020-03-01 19:05:28 +01:00
(module+ test
2023-08-24 23:37:17 +02:00
(require typed/rackunit))
2023-08-24 23:37:17 +02:00
(define-type Species Symbol)
2023-08-24 23:37:17 +02:00
(struct reaction ([reactants : (Setof Species)]
[inhibitors : (Setof Species)]
[products : (Setof Species)])
#:transparent
#:type-name Reaction)
2020-03-01 19:05:28 +01:00
2023-08-24 23:37:17 +02:00
(define-type ReactionName Symbol)
2020-03-01 19:05:28 +01:00
2023-08-24 23:37:17 +02:00
(: 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)))))
2020-03-01 19:05:28 +01:00
2023-08-24 23:37:17 +02:00
(: enabled? (-> Reaction (Setof Species) Boolean))
2020-03-01 19:05:28 +01:00
(define/match (enabled? r s)
2023-08-24 23:37:17 +02:00
[((reaction r i _) s)
2020-03-01 19:05:28 +01:00
(and (subset? r s) (set-empty? (set-intersect i s)))])
2020-03-01 19:19:58 +01:00
2023-08-24 23:37:17 +02:00
(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))
2020-03-01 19:20:24 +01:00
2023-08-24 23:37:17 +02:00
(: list-enabled (-> ReactionSystem (Setof Species) (Listof ReactionName)))
2020-03-01 19:20:24 +01:00
(define (list-enabled rs s)
(for/list ([(name reaction) (in-hash rs)]
#:when (enabled? reaction s))
name))
2020-03-01 19:47:38 +01:00
2023-08-24 23:37:17 +02:00
(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)))
2020-03-01 19:47:38 +01:00
(define (union-products rs as)
2023-08-24 23:37:17 +02:00
(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))))]))
2020-03-01 19:51:53 +01:00
2023-08-24 23:37:17 +02:00
(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)))
2020-03-01 19:51:53 +01:00
(define (apply-rs rs s)
(let ([as (list-enabled rs s)])
(union-products rs as)))
(module+ test
2023-08-24 23:37:17 +02:00
(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)))])
2023-08-24 23:37:17 +02:00
(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)
2023-08-24 23:37:17 +02:00
(for/hash : (HashTable ReactionName Reaction)
([(a triple) (in-hash ht)])
(values a (str-triple->reaction triple))))
(module+ test
(test-case "ht-str-triples->rs"
2023-08-24 23:37:17 +02:00
(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))))))
2023-08-24 23:37:17 +02:00
(: 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"
2023-08-24 23:37:17 +02:00
(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))))
2020-03-02 23:03:10 +01:00
(define (read-context-sequence str)
2023-08-24 23:37:17 +02:00
(for/list ([sexp (in-list (flatten (string->any str)))])
(list->set (read-symbol-list (assert-type sexp String)))))
2020-03-02 23:03:10 +01:00
(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)))))
2023-08-24 23:37:17 +02:00
(: reaction->str-triple (-> Reaction (Listof String)))
(define/match (reaction->str-triple r)
[((reaction r i p))
2023-08-24 23:37:17 +02:00
(for/list ([c (in-list (list r i p))])
(drop-first-last (any->string (set->list c))))])
2023-08-24 23:37:17 +02:00
(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)
2023-08-24 23:37:17 +02:00
(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"
2023-08-24 23:37:17 +02:00
(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)
2023-08-24 23:37:17 +02:00
(send (new dynamics% [rs rs])
build-state-graph/annotated
(list (state (set) contexts))))
2020-03-03 00:12:45 +01:00
2023-08-24 23:37:17 +02:00
(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)
2020-11-10 09:42:50 +01:00
(define sgr (build-interactive-process-graph rs contexts))
(weighted-graph/directed
(for/list ([e (in-edges sgr)])
2023-08-24 23:37:17 +02:00
(define u (assert-type (car e) State))
(define v (assert-type (cadr e) State))
2020-11-10 09:42:50 +01:00
(list (edge-weight sgr u v) (state-result u) (state-result v)))))
(module+ test
2023-08-24 23:37:17 +02:00
(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
2023-08-24 23:37:17 +02:00
(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)))))
2020-03-03 00:51:53 +01:00
(define (build-interactive-process rs contexts)
2023-08-24 23:37:17 +02:00
(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))])
2023-08-24 23:37:17 +02:00
(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))
2020-03-03 00:12:45 +01:00
(define (pretty-print-state-graph sgr)
2023-08-24 23:37:17 +02:00
(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
2023-08-24 23:37:17 +02:00
(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")
))