dds/rs.rkt

#lang racket

;;; dds/rs

;;; Definitions for working with reaction systems.

(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?)))]
               [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
 (contract-out [reaction-system/c contract?])
 ;; Syntax
 unorg-rs org-rs)

;;; =================
;;; Basic definitions
;;; =================

;;; A species is a symbol.
(define species? symbol?)

;;; A reaction is a triple of sets, giving the reactants, the
;;; inhibitors, and the products, respectively.
(struct reaction (reactants inhibitors products) #:transparent)

;;; A reaction is enabled on a set if all of its reactants are in the
;;; set and none of its inhibitors are.
(define/match (enabled? r s)
  [((reaction r i p) s)
   (and (subset? r s) (set-empty? (set-intersect i s)))])

;;; A reaction system is a dictionary mapping reaction names to
;;; reactions.
(define reaction-system/c (hash/c symbol? reaction?))

;;; Returns the list of reaction names enabled on a given set.
(define (list-enabled rs s)
  (for/list ([(name reaction) (in-hash rs)]
             #:when (enabled? reaction s))
    name))

;;; Returns the union of the product sets of the given reactions in a
;;; reaction system.  If no reactions are supplied, returns the empty
;;; set.
;;;
;;; This function can be seen as producing the result of the
;;; application of the given reactions to a set.  Clearly, it does not
;;; 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.
(define (apply-rs rs s)
  (let ([as (list-enabled rs s)])
    (union-products rs as)))


;;; ====================
;;; Org-mode interaction
;;; ====================

;;; This section contains some useful primitives for Org-mode
;;; interoperability.

;;; Reads a list of species from a string.
(define (read-symbol-list str)
  (string->any (string-append "(" str ")")))

;;; Converts a triple of strings to a 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)))])

;;; Converts a hash table mapping reaction names to triples of strings
;;; to a reaction system.
(define (ht-str-triples->rs ht)
  (for/hash ([(a triple) (in-hash ht)])
    (values a (str-triple->reaction triple))))

;;; Chains ht-str-triples->rs with unorg.
(define-syntax-rule (unorg-rs str) (ht-str-triples->rs (unorg str)))

;;; Removes the first and the last symbol of a given string.
(define (drop-first-last str)
  (substring str 1 (- (string-length str) 1)))

;;; Converts a reaction to a triple of strings.
(define/match (reaction->str-triple r)
  [((reaction r i p))
   (map (compose drop-first-last any->string set->list)
        (list r i p))])

;;; Converts a reaction system to a hash table mapping reaction names
;;; to triples of strings.
(define (rs->ht-str-triples rs)
  (for/hash ([(a r) (in-hash rs)])
    (values a (reaction->str-triple r))))

;;; 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 '())])))])