networks: Add compact-tbn.

networks.rkt

@@ -121,7 +121,8 @@
                [build-tbn-state-graph (-> tbn? graph?)]
                [normalized-tbn? (-> tbn? boolean?)]
                [normalize-tbn (-> tbn? normalized-tbn?)]
-               [compact-tbf (-> tbf/state? tbf/state?)])
+               [compact-tbf (-> tbf/state? tbf/state?)]
+               [compact-tbn (-> tbn? tbn?)])
  ;; Predicates
  (contract-out [variable? (-> any/c boolean?)]
                [state? (-> any/c boolean?)]
@@ -1535,3 +1536,27 @@
   (test-case "compact-tbf"
     (check-equal? (compact-tbf (tbf/state (hash 'a 0 'b 1 'c 2 'd 0) 2))
                   (tbf/state '#hash((b . 1) (c . 2)) 2))))
+
+;;; Compacts a TBN by removing all inputs which are 0 or which are not
+;;; variables of the network.
+(define (compact-tbn tbn)
+  (define (remove-0-non-var tbf)
+    (tbf/state
+     (for/hash ([(x w) (in-hash (tbf/state-w tbf))]
+                #:when (hash-has-key? tbn x)
+                #:unless (zero? w))
+       (values x w))
+     (tbf/state-θ tbf)))
+  (for/hash ([(x tbf) (in-hash tbn)])
+    (values x (remove-0-non-var tbf))))
+
+(module+ test
+  (test-case "compact-tbn"
+    (check-equal?
+     (compact-tbn (hash 'a (tbf/state (hash 'a 0 'b 1 'c 3 'd 0) 0)
+                        'b (tbf/state (hash 'a -1 'b 1) -1)))
+     (hash
+      'a
+      (tbf/state '#hash((b . 1)) 0)
+      'b
+      (tbf/state '#hash((a . -1) (b . 1)) -1)))))