From 5358f9bf572788b61a475f13bb56eb2097477782 Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Sun, 22 Mar 2020 14:34:40 +0100
Subject: [PATCH] networks: Add tabulate-state and tabulate-state/boolean.

---
 networks-tests.rkt |  2 ++
 networks.rkt       | 26 ++++++++++++++++++++++++++
 2 files changed, 28 insertions(+)

diff --git a/networks-tests.rkt b/networks-tests.rkt
index ee75421..a5ec133 100644
--- a/networks-tests.rkt
+++ b/networks-tests.rkt
@@ -215,6 +215,8 @@
                 '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))
   (check-equal? (tabulate/boolean (lambda (x y) (and x y)))
                 '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))
+  (let ([func (λ (st) (not (hash-ref st 'a)))])
+    (check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f))))
   (check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t)))
   (check-equal? (stream->list (boolean-power/stream 2)) '((#f #f) (#f #t) (#t #f) (#t #t)))
   (let ([negation (table->function '((#t #f) (#f #t)))]
diff --git a/networks.rkt b/networks.rkt
index b847daf..8ea1b13 100644
--- a/networks.rkt
+++ b/networks.rkt
@@ -59,6 +59,10 @@
                [tabulate/domain-list (-> procedure? (listof generic-set?) (listof list?))]
                [tabulate (->* (procedure?) () #:rest (listof generic-set?) (listof list?))]
                [tabulate/boolean (-> procedure-fixed-arity? (listof (listof boolean?)))]
+               [tabulate-state (->* (procedure? domain-mapping/c) (#:headers boolean?)
+                                    (listof (listof any/c)))]
+               [tabulate-state/boolean (->* (procedure? (listof variable?)) (#:headers boolean?)
+                                            (listof (listof any/c)))]
                [table->function (-> (listof (*list/c any/c any/c)) procedure?)]
                [table->function/list (-> (listof (*list/c any/c any/c)) procedure?)]
                [boolean-power (-> number? (listof (listof boolean?)))]
@@ -418,6 +422,28 @@
 (define (tabulate/boolean func)
   (tabulate/domain-list func (make-list (procedure-arity func) '(#f #t))))
 
+;;; Like tabulate, but supposes that the function works on states.
+;;;
+;;; The argument domains defines the domains of each of the component
+;;; of the states.  If headers it true, the resulting list starts with
+;;; a listing the names of the variables of the domain and ending with
+;;; the symbol 'f, which indicates the values of the function.
+(define (tabulate-state func domains #:headers [headers #t])
+  (define (st-vals st) (hash-map st (λ (x y) y) #t))
+  (define tab (for/list ([st (build-all-states domains)])
+                (append (st-vals st) (list (func st)))))
+  (cond
+    [headers
+     (define vars (append (hash-map domains (λ (x y) x) #t) '(f)))
+     (cons vars tab)]
+    [else tab]))
+
+;;; Like tabulate-state, but assumes the function is a Boolean
+;;; function.  args is a list of names of the arguments which can
+;;; appear in the states.
+(define (tabulate-state/boolean func args #:headers [headers #t])
+  (tabulate-state func (make-boolean-domains args) #:headers headers))
+
 ;;; Given a table like the one produced by the tabulate functions,
 ;;; creates a function which has this behaviour.
 ;;;