Add sbfs/state->lists+headers.

scribblings/tbn.scrbl

@@ -228,6 +228,34 @@ corresponds to the column giving the thresholds of the TBFs.
        (tbf/state (hash 'a -2 'b 1) 1)))
 ]}
 
+@defproc[(sbfs/state->lists [sbfs (Listof TBF/State)])
+			    (Listof (Listof Real))]{
+
+Like @racket[tbfs/state->lists], but the thresholds are omitted.
+
+@ex[
+(sbfs/state->lists (list (tbf/state (hash 'a 1 'b 2) 0)
+                         (tbf/state (hash 'a -2 'b 1) 0)))
+]
+
+Note that this function just drops the threshold, without checking
+whether it is actually 0:
+
+@ex[
+(sbfs/state->lists (list (tbf/state (hash 'a 1 'b 2) 3)))
+]}
+
+@defproc[(sbfs/state->lists+headers [sbfs (Listof TBF/State)])
+				    (Pairof (Listof Variable) (Listof (Listof Real)))]{
+
+Like @racket[sbfs/state->lists], but also shows the names of the
+variables as column headers.
+
+@ex[
+(sbfs/state->lists+headers (list (tbf/state (hash 'a 1 'b 2) 0)
+                      	   	 (tbf/state (hash 'a -2 'b 1) 0)))
+]}
+
 @section{Tabulating TBFs and SBFs}
 
 @defproc[(tabulate-tbfs/state [tbfs (Listof TBF/State)]) (Listof (Listof Real))]{
@@ -263,3 +291,73 @@ the list.
  (list (tbf/state (hash 'a 1 'b 2) 2)
        (tbf/state (hash 'a -2 'b 2) 1)))
 ]}
+
+@deftogether[(@defproc[(tabulate-tbf/state [tbf TBF/State])
+		       (Listof (Listof Real))]
+	      @defproc[(tabulate-tbf/state+headers [tbf TBF/State])
+	               (Pairof (Listof Variable) (Listof (Listof Real)))])]{
+
+Like @racket[tabulate-tbfs/state] and
+@racket[tabulate-tbfs/state+headers], but only tabulate single TBFs.
+
+@ex[
+(tabulate-tbf/state (tbf/state (hash 'a 1 'b 2) 2))
+(tabulate-tbf/state+headers (tbf/state (hash 'a 1 'b 2) 2))
+]}
+
+@section{TBNs and SBNs}
+
+@deftype[TBN]{
+
+The type of a TBN, i.e. a mapping assigning to each variable
+a @racket[TBF/State].
+
+}
+
+@defproc[(sbn? [tbn TBN]) Boolean]{
+
+A SBN is a @racket[TBN] in which all @racket[TBF/State]s satisfy
+@racket[sbf/state?].
+
+All functions in @racket[tbn] must only reference variables appearing
+in the network.  This function does not check this condition.
+
+@ex[
+(let ([f1 (tbf/state (hash 'a -1 'b 1) 0)]
+      [f2 (tbf/state (hash 'a -1 'b 1) 1)])
+  (values (sbn? (hash 'a f1 'b f1))
+          (sbn? (hash 'a f1 'b f2))))
+]}
+
+@defproc[(tbn->network [tbn TBN]) (Network (U Zero One))]{
+
+Constructs a @racket[Network] out of the given @racket[tbn].
+
+@ex[
+(require (only-in "networks.rkt" update))
+(let* ([tbn-form (hash 'a (tbf/state (hash 'a -1 'b 1) 0)
+                       'b (tbf/state (hash 'a -1 'b 1) 1))]
+       [tbn (tbn->network tbn-form)]
+       [s (hash 'a 0 'b 1)])
+  (update tbn s '(a b)))
+]}
+
+@section{Miscellaneous utilities}
+
+@defproc[(group-truth-table-by-nai [tt (Listof (Listof Integer))])
+				   (Listof (Listof (Listof Integer)))]{
+
+Given the truth table @racket[tt] of a Boolean function, groups the
+lines by the @italic{N}umber of @italic{A}ctivated @italic{I}nputs—the
+number of inputs which are 1 in the input vector.
+
+@ex[
+(group-truth-table-by-nai '((0 0 0 1)
+                            (0 0 1 1)
+                            (0 1 0 0)
+                            (0 1 1 1)
+                            (1 0 0 0)
+                            (1 0 1 0)
+                            (1 1 0 1)
+                            (1 1 1 0)))
+]}

tbn.rkt

@@ -29,8 +29,14 @@
    lists+vars->sbfs/state lists+headers->sbfs/state lists->sbfs/state
    read-org-tbfs/state read-org-tbfs/state+headers
    tbfs/state->lists tbfs/state->lists+headers
+   sbfs/state->lists sbfs/state->lists+headers
 
    tabulate-tbfs/state tabulate-tbfs/state+headers
+   tabulate-tbf/state tabulate-tbf/state+headers
+
+   group-truth-table-by-nai
+
+   TBN sbn? tbn->network
    )
 
   (: apply-tbf-to-state (-> TBF (State (U Zero One)) (U Zero One)))
@@ -219,15 +225,31 @@
   (: sbfs/state->lists (-> (Listof TBF/State) (Listof (Listof Real))))
   (define (sbfs/state->lists tbfs)
     (for/list ([tbf (in-list tbfs)])
-      (append (hash-map (tbf/state-w tbf) (λ (_ [w : Real]) w) #t)
-              (list (tbf/state-θ tbf)))))
+      (hash-map (tbf/state-w tbf) (λ (_ [w : Real]) w) #t)))
 
   (module+ test
-    (test-case "tbfs/state->lists"
+    (test-case "sbfs/state->lists"
       (check-equal?
-       (tbfs/state->lists (list (tbf/state (hash 'a 1 'b 2) 3)
-                                   (tbf/state (hash 'a -2 'b 1) 1)))
-       '((1 2 3) (-2 1 1)))))
+       (sbfs/state->lists (list (tbf/state (hash 'a 1 'b 2) 0)
+                                (tbf/state (hash 'a -2 'b 1) 0)))
+       '((1 2) (-2 1)))))
+
+  (: sbfs/state->lists+headers (-> (Listof TBF/State)
+                                   (Pairof (Listof Variable)
+                                           (Listof (Listof Real)))))
+  (define (sbfs/state->lists+headers tbfs)
+    (cons (hash-map (tbf/state-w (car tbfs))
+                    (λ ([x : Symbol] _) x) #t)
+          (sbfs/state->lists tbfs)))
+
+  (module+ test
+    (test-case "sbfs/state->list+headers"
+      (check-equal?
+       (sbfs/state->lists+headers (list (tbf/state (hash 'a 1 'b 2) 0)
+                                        (tbf/state (hash 'a -2 'b 1) 0)))
+       '((a b)
+         (1 2)
+         (-2 1)))))
 
   (: tabulate-tbfs/state (-> (Listof TBF/State) (Listof (Listof Real))))
   (define (tabulate-tbfs/state tbfs)
@@ -262,6 +284,90 @@
                       (0 1 0 1)
                       (1 0 0 0)
                       (1 1 1 0)))))
+
+  (: tabulate-tbf/state (-> TBF/State (Listof (Listof Real))))
+  (define (tabulate-tbf/state tbf)
+    (tabulate-tbfs/state (list tbf)))
+
+  (module+ test
+    (test-case "tabulate-tbf/state"
+      (check-equal? (tabulate-tbf/state (tbf/state (hash 'a 1 'b 2) 2))
+                    '((0 0 0)
+                      (0 1 0)
+                      (1 0 0)
+                      (1 1 1)))))
+
+  (: tabulate-tbf/state+headers (-> TBF/State (Pairof (Listof Variable)
+                                                      (Listof (Listof Real)))))
+  (define (tabulate-tbf/state+headers tbf)
+    (tabulate-tbfs/state+headers (list tbf)))
+
+  (module+ test
+    (test-case "tabulate-tbf/state+headers"
+      (check-equal? (tabulate-tbf/state+headers (tbf/state (hash 'a 1 'b 2) 2))
+                    '((a b f1)
+                      (0 0 0)
+                      (0 1 0)
+                      (1 0 0)
+                      (1 1 1)))))
+
+  (: group-truth-table-by-nai (-> (Listof (Listof Integer))
+                                  (Listof (Listof (Listof Integer)))))
+  (define (group-truth-table-by-nai tt)
+    (: sum (-> (Listof Integer) Integer))
+    (define (sum xs) (foldl + 0 xs))
+    (group-by (λ ([row : (Listof Integer)])
+                (drop-right row 1))
+              tt
+              (λ ([in1 : (Listof Integer)] [in2 : (Listof Integer)])
+                (= (sum in1) (sum in2)))))
+
+  (module+ test
+    (test-case "group-truth-table-by-nai"
+      (check-equal? (group-truth-table-by-nai '((0 0 0 1)
+                                                (0 0 1 1)
+                                                (0 1 0 0)
+                                                (0 1 1 1)
+                                                (1 0 0 0)
+                                                (1 0 1 0)
+                                                (1 1 0 1)
+                                                (1 1 1 0)))
+                    '(((0 0 0 1))
+                      ((0 0 1 1) (0 1 0 0) (1 0 0 0))
+                      ((0 1 1 1) (1 0 1 0) (1 1 0 1))
+                      ((1 1 1 0))))))
+
+  (define-type TBN (HashTable Variable TBF/State))
+
+  (: sbn? (-> TBN Boolean))
+  (define (sbn? tbn) (andmap sbf/state? (hash-values tbn)))
+
+  (module+ test
+    (test-case "sbn?"
+      (define f1 (tbf/state (hash 'a -1 'b 1) 0))
+      (define f2 (tbf/state (hash 'a -1 'b 1) 1))
+      (check-true (sbn? (hash 'a f1 'b f1)))
+      (check-false (sbn? (hash 'a f1 'b f2))))
+    )
+
+  (: tbn->network (-> TBN (Network (U Zero One))))
+  (define (tbn->network tbn)
+    (make-01-network
+     (for/hash : (VariableMapping (UpdateFunction (U Zero One)))
+               ([(x tbfx) (in-hash tbn)])
+       (values x (λ ([s : (State (U Zero One))])
+                   (apply-tbf/state tbfx s))))))
+
+  (module+ test
+    (test-case "tbn->network"
+      (define tbn-form (hash 'a (tbf/state (hash 'a -1 'b 1) 0)
+                             'b (tbf/state (hash 'a -1 'b 1) 1)))
+      (define tbn (tbn->network tbn-form))
+      (define s (hash 'a 0 'b 1))
+      (check-equal? (update tbn s '(a b))
+                    #hash((a . 1) (b . 0)))
+      (check-equal? (network-domains tbn)
+                    #hash((a . (0 1)) (b . (0 1))))))
   )
 
 (module+ test