diff --git a/example/example.org b/example/example.org index 13edb12..6241521 100644 --- a/example/example.org +++ b/example/example.org @@ -1107,6 +1107,38 @@ tab | C | -1 | 2 | -1 | :end: + =dds= also defines functions to draw the interaction graphs + of TBNs: + + #+NAME: tbfs-nots-ig + #+BEGIN_SRC racket :results silent drawer :var tbfs-nots=munch-sexp(tbfs-nots) +(dotit (tbn-interaction-graph (read-org-tbn tbfs-nots))) + #+END_SRC + + #+BEGIN_SRC dot :file dots/exampletCklZa.svg :results raw drawer :cmd dot :noweb yes +<> + #+END_SRC + + #+RESULTS: + :results: + [[file:dots/exampletCklZa.svg]] + :end: + + =tbn-interaction-graph= can optionally omit edges with zero weight: + + #+NAME: tbfs-nots-ig-no0 + #+BEGIN_SRC racket :results silent drawer :var tbfs-nots=munch-sexp(tbfs-nots) +(dotit (tbn-interaction-graph (read-org-tbn tbfs-nots) #:zero-edges #f)) + #+END_SRC + + #+BEGIN_SRC dot :file dots/exampleudm6jn.svg :results raw drawer :cmd dot :noweb yes +<> + #+END_SRC + + #+RESULTS: + :results: + [[file:dots/exampleudm6jn.svg]] + :end: * Reaction systems :PROPERTIES: diff --git a/networks.rkt b/networks.rkt index 235121e..0483474 100644 --- a/networks.rkt +++ b/networks.rkt @@ -126,7 +126,9 @@ [print-org-tbn (->* (tbn?) (#:headers boolean? #:func-names boolean?) (listof (listof (or/c number? symbol?))))] [print-org-sbn (->* (sbn?) (#:headers boolean? #:func-names boolean?) - (listof (listof (or/c number? symbol?))))]) + (listof (listof (or/c number? symbol?))))] + [tbn-interaction-graph (->* (tbn?) (#:zero-edges boolean?) + graph?)]) ;; Predicates (contract-out [variable? (-> any/c boolean?)] [state? (-> any/c boolean?)] @@ -1633,3 +1635,32 @@ (tbf/state (hash 'a 2) 0))) (check-equal? (print-org-sbn sbn) '((- a b) (a 0 2) (b 2 0))))) + +;;; Given a TBN, constructs its interaction graph. The nodes of this +;;; graph are labeled with pairs (variable name . threshold), while +;;; the edges are labelled with the weights. +;;; +;;; If #:zero-edges is #t, the edges with zero weights will appear in +;;; the interaction graph. +(define (tbn-interaction-graph tbn + #:zero-edges [zero-edges #t]) + (define ntbn (normalize-tbn tbn)) + (define ig (weighted-graph/directed + (if zero-edges + (for*/list ([(tar tbf) (in-hash ntbn)] + [(src w) (in-hash (tbf/state-w tbf))]) + (list w src tar)) + (for*/list ([(tar tbf) (in-hash ntbn)] + [(src w) (in-hash (tbf/state-w tbf))] + #:unless (zero? w)) + (list w src tar))))) + (update-graph ig #:v-func (λ (x) (cons x (tbf/state-θ (hash-ref ntbn x)))))) + +(module+ test + (test-case "tbn-interaction-graph" + (define tbn (make-tbn `((a . ,(make-sbf/state '((b . 1)))) + (b . ,(make-tbf/state '((a . -1)) -1))))) + (check-equal? (graphviz (tbn-interaction-graph tbn)) + "digraph G {\n\tnode0 [label=\"'(b . -1)\\n\"];\n\tnode1 [label=\"'(a . 0)\\n\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"0\"];\n\t\tnode1 -> node1 [label=\"0\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"1\"];\n\t\tnode1 -> node0 [label=\"-1\"];\n\t}\n}\n") + (check-equal? (graphviz (tbn-interaction-graph tbn #:zero-edges #f)) + "digraph G {\n\tnode0 [label=\"'(b . -1)\\n\"];\n\tnode1 [label=\"'(a . 0)\\n\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"1\"];\n\t\tnode1 -> node0 [label=\"-1\"];\n\t}\n}\n")))