rs: Add the dynamics.

rs-tests.rkt

@@ -2,7 +2,7 @@
 
 ;;; Tests for dds/rs.
 
-(require rackunit "rs.rkt")
+(require rackunit graph "rs.rkt" "utils.rkt")
 
 (test-case "Basic definitions"
   (let* ([r1 (reaction (set 'x) (set 'y) (set 'z))]
@@ -23,3 +23,49 @@
                 (make-immutable-hash (list (cons 'a (reaction (set 'x 't) (set 'y) (set 'z))))))
   (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")))))
+
+(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))])
+    (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)))))

rs.rkt

@@ -4,18 +4,27 @@
 
 ;;; Definitions for working with reaction systems.
 
-(require "utils.rkt")
+(require graph "utils.rkt" "generic.rkt")
 
 (provide
  ;; Structures
  (struct-out reaction)
+ (struct-out state)
+ (struct-out dynamics)
  ;; Functions
  (contract-out [enabled? (-> reaction? (set/c symbol?) boolean?)]
                [list-enabled (-> reaction-system/c (set/c species?) (listof symbol?))]
                [union-products (-> reaction-system/c (listof symbol?) (set/c species?))]
                [apply-rs (-> reaction-system/c (set/c species?) (set/c species?))]
                [ht-str-triples->rs (-> (hash/c symbol? (list/c string? string? string?)) reaction-system/c)]
-               [rs->ht-str-triples (-> reaction-system/c (hash/c symbol? (list/c string? string? string?)))])
+               [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?)])
  ;; Predicates
  (contract-out [species? (-> any/c boolean?)])
  ;; Contracts
@@ -115,3 +124,40 @@
 
 ;;; A shortcut for rs->ht-str-triples.
 (define-syntax-rule (org-rs rs) (rs->ht-str-triples rs))
+
+
+;;; ============================
+;;; Dynamics of reaction systems
+;;; ============================
+
+;;; An interactive process of a reaction system is a sequence of
+;;; states driven by a sequence of contexts in the following way.  The
+;;; reaction system starts with the initial context.  Then, at every
+;;; step, the result of applying the reaction system is merged with
+;;; the next element of the context sequence, and the reaction system
+;;; is then applied to the result of the union.
+
+;;; A state of a reaction system is a set of species representing the
+;;; result of the application of the reactions from the previous
+;;; steps, plus the rest of the context sequence.
+(struct state (result rest-contexts) #:transparent)
+
+;;; The dynamics of the reaction system only stores the reaction
+;;; system itself.
+(struct dynamics (rs) #:transparent
+  #:methods gen:dds
+  [;; Since reaction systems are deterministic, a singleton set is
+   ;; always produced.  It is annotated by the list of rules which
+   ;; were enabled in the current step.
+   (define (dds-step-one-annotated dyn st)
+     (let* ([rs (dynamics-rs dyn)]
+            [apply-rs-annotate
+             (λ (s rest-ctx)
+               (let ([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 '())
+          (apply-rs-annotate res '())])))])