From ac7f9287379ac1216a0b2405f773e016b6ac6684 Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Tue, 8 Aug 2023 08:46:43 +0200
Subject: [PATCH] Type tbn-interaction-graph.

---
 scribblings/tbn.scrbl | 19 +++++++++++++++++++
 tbn.rkt               | 27 +++++++++++++++++++++++++++
 2 files changed, 46 insertions(+)

diff --git a/scribblings/tbn.scrbl b/scribblings/tbn.scrbl
index 4ae9356..e1fe23f 100644
--- a/scribblings/tbn.scrbl
+++ b/scribblings/tbn.scrbl
@@ -417,6 +417,25 @@ are not variables of the network.
                    'b (tbf/state (hash 'a -1 'b 1) -1)))
 ]}
 
+@defproc[(tbn-interaction-graph [tbn TBN]
+				[#:zero-edges zero-edges Boolean #t])
+				Graph]{
+
+Constructs the interaction graph of @racket[tbn].  The nodes of this
+graph are labeled with pairs (variable name, threshold), while the
+edges are labeled with the weights.
+
+If @racket[#:zero-edges] is @racket[#t], the edges with zero weights
+will also appear in the interaction graph.
+
+@ex[
+(dotit (tbn-interaction-graph (hash 'a (tbf/state (hash 'b 1) 0)
+                                    'b (tbf/state (hash 'a -1) -1))))
+(dotit (tbn-interaction-graph (hash 'a (tbf/state (hash 'b 1) 0)
+                                    'b (tbf/state (hash 'a -1) -1))
+                              #:zero-edges #f))
+]}
+
 @section{Reading and printing TBNs and SBNs}
 
 @defproc[(parse-org-tbn [tab (Listof (Listof (U Symbol Real)))]
diff --git a/tbn.rkt b/tbn.rkt
index 76f65a2..d7728c6 100644
--- a/tbn.rkt
+++ b/tbn.rkt
@@ -48,6 +48,7 @@
 
    TBN sbn? tbn->network
    build-tbn-state-graph normalized-tbn? normalize-tbn compact-tbn
+   tbn-interaction-graph
    parse-org-tbn read-org-tbn read-org-sbn tbn->lists sbn->lists
    )
 
@@ -497,6 +498,32 @@
         'b
         (tbf/state '#hash((a . -1) (b . 1)) -1)))))
 
+  (: tbn-interaction-graph (->* (TBN) (#:zero-edges Boolean) 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 : (Listof (List Real Variable Variable))
+                               ([(tar tbf) (in-hash ntbn)]
+                                [(src w) (in-hash (tbf/state-w tbf))])
+                      (list w src tar))
+                    (for*/list  : (Listof (List Real Variable Variable))
+                                ([(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 (assert-type x Variable)))))))
+
+  (module+ test
+    (test-case "tbn-interaction-graph"
+      (define tbn (hash 'a (tbf/state (hash 'b 1) 0)
+                        'b (tbf/state (hash 'a -1) -1)))
+      (check-equal? (graphviz (tbn-interaction-graph tbn))
+                    "digraph G {\n\tnode0 [label=\"'(b . -1)\"];\n\tnode1 [label=\"'(a . 0)\"];\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\tnode1 [label=\"'(a . 0)\"];\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")))
+
   (: parse-org-tbn (->* ((Listof (Listof (U Symbol Real))))
                         (#:headers Boolean
                          #:func-names Boolean)