From af5a9d07a99036e45f07783ae8ee6abd10ca0d64 Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Mon, 2 Nov 2020 17:58:45 +0100
Subject: [PATCH] networks: Add print-org-tbn.

---
 networks.rkt | 40 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 39 insertions(+), 1 deletion(-)

diff --git a/networks.rkt b/networks.rkt
index cd19b9f..7a29777 100644
--- a/networks.rkt
+++ b/networks.rkt
@@ -122,7 +122,9 @@
                [normalized-tbn? (-> tbn? boolean?)]
                [normalize-tbn (-> tbn? normalized-tbn?)]
                [compact-tbf (-> tbf/state? tbf/state?)]
-               [compact-tbn (-> tbn? tbn?)])
+               [compact-tbn (-> tbn? tbn?)]
+               [print-org-tbn (->* (tbn?) (#:headers boolean? #:func-names boolean?)
+                                   (listof (listof (or/c number? symbol?))))])
  ;; Predicates
  (contract-out [variable? (-> any/c boolean?)]
                [state? (-> any/c boolean?)]
@@ -1560,3 +1562,39 @@
       (tbf/state '#hash((b . 1)) 0)
       'b
       (tbf/state '#hash((a . -1) (b . 1)) -1)))))
+
+;;; Given TBN, produces a sexp containing the description of the
+;;; functions of the TBN that Org-mode can interpret as a table.
+;;;
+;;; Like print-org-tbfs/state, if #:headers is #f, does not print the
+;;; names of the inputs of the TBFs.  If #:headers is #t, the output
+;;; starts by a list giving the names of the variables, as well as the
+;;; symbol 'θ to represent the column giving the thresholds of the
+;;; TBF.
+;;;
+;;; If #:func-names is #t, the first column of the table gives the
+;;; variable which the corresponding TBF updates.
+;;;
+;;; If both #:func-names and #:headers are #t, the first cell of the
+;;; first column contains the symbol '-.
+(define (print-org-tbn tbn
+                       #:headers [headers #t]
+                       #:func-names [func-names #t])
+  (define ntbn (normalize-tbn tbn))
+  (define vars-tbfs (hash-map ntbn (λ (x tbf) (cons x tbf)) #t))
+  (define tbfs (map cdr vars-tbfs))
+  (define tbfs-table (print-org-tbfs/state tbfs #:headers headers))
+  (cond
+    [(eq? func-names #t)
+     (define vars (map car vars-tbfs))
+     (define col-1 (if headers (cons '- vars) vars))
+     (for/list ([var (in-list col-1)] [row (in-list tbfs-table)])
+       (cons var row))]
+    [else
+     tbfs-table]))
+
+(module+ test
+  (test-case "print-org-tbn"
+    (define tbn (make-tbn `((a . ,(make-sbf/state '((b . 1))))
+                            (b . ,(make-tbf/state '((a . -1)) -1)))))
+    (print-org-tbn tbn)))