dds/rs.rkt

#lang typed/racket

(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")
    ))