From daf2e079ae1237095128124aecf0f410a6c66c5d Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Sun, 23 Feb 2020 01:00:09 +0100
Subject: [PATCH] networks: Add build-signed-interaction-graph.

---
 networks-tests.rkt | 18 +++++++++++++++---
 networks.rkt       | 20 +++++++++++++++++++-
 2 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/networks-tests.rkt b/networks-tests.rkt
index 48ec170..449fc09 100644
--- a/networks-tests.rkt
+++ b/networks-tests.rkt
@@ -75,7 +75,19 @@
   (check-equal? (hash->list (make-boolean-domains '(a b)))
                 '((a . (#f #t)) (b . (#f #t))))
 
-  (let ([n #hash((a . (not b)) (b . a))]
-        [doms (make-boolean-domains '(a b))])
+  (let* ([n #hash((a . (not b)) (b . a))]
+         [doms (make-boolean-domains '(a b))]
+         [sig (build-signed-interaction-graph n doms)])
     (check-equal? (get-interaction-sign n doms 'a 'b) '+)
-    (check-equal? (get-interaction-sign n doms 'b 'a) '-)))
+    (check-equal? (get-interaction-sign n doms 'b 'a) '-)
+
+    (check-true (has-vertex? sig 'a))
+    (check-true (has-vertex? sig 'b))
+    (check-false (has-vertex? sig 'c))
+    (check-false (has-edge? sig 'a 'a))
+    (check-true (has-edge? sig 'b 'a))
+    (check-false (has-edge? sig 'b 'b))
+    (check-false (has-edge? sig 'c 'b))
+    (check-false (has-edge? sig 'c 'a))
+    (check-equal? (edge-weight sig 'a 'b) 1)
+    (check-equal? (edge-weight sig 'b 'a) -1)))
diff --git a/networks.rkt b/networks.rkt
index 49726e5..040a6ae 100644
--- a/networks.rkt
+++ b/networks.rkt
@@ -27,7 +27,8 @@
                [build-all-states-same-domain (-> (listof variable?) generic-set? (listof state?))]
                [make-same-domains (-> (listof variable?) generic-set? (hash/c variable? generic-set?))]
                [make-boolean-domains (-> (listof variable?) (hash/c variable? (list/c #f #t)))]
-               [get-interaction-sign (-> network-form? (hash/c variable? generic-set?) variable? variable? (or/c '+ '- '0))])
+               [get-interaction-sign (-> network-form? (hash/c variable? generic-set?) variable? variable? (or/c '+ '- '0))]
+               [build-signed-interaction-graph (-> network-form? (hash/c variable? generic-set?) graph?)])
  ;; Predicates
  (contract-out [variable? (-> any/c boolean?)]
                [state? (-> any/c boolean?)]
@@ -214,3 +215,20 @@
       ;; Otherwise the interaction is neither increasing nor
       ;; decreasing.
       [else '0])))
+
+;;; Constructs a signed interaction graph of a given network form,
+;;; given the ordered domains of its variables.  The order on the
+;;; domains determines the signs which will appear on the interaction
+;;; graph.
+;;;
+;;; /!\ This function iterates through almost all states of the
+;;; network for every arrow in the unsigned interaction graph, so its
+;;; performance decreases very quickly with the size of the network.
+(define (build-signed-interaction-graph network-form doms)
+  (let ([ig (build-interaction-graph network-form)])
+    (weighted-graph/directed
+     (for/list ([e (in-edges ig)])
+       (match-let ([(list x y) e])
+         (list (match (get-interaction-sign network-form doms x y)
+                 ['+ 1] ['- -1] ['0 0])
+               x y))))))