networks: Add table->network.

networks-tests.rkt

@@ -238,6 +238,22 @@
         [negation/list (table->function/list '((#t #f) (#f #t)))])
     (check-true (negation #f)) (check-false (negation #t))
     (check-true (negation/list '(#f))) (check-false (negation/list '(#t))))
+  (let* ([n (table->network '((x1 x2 f1 f2)
+                              (#f #f #f #f)
+                              (#f #t #f #t)
+                              (#t #f #t #f)
+                              (#t #t #t #t)))]
+         [f1 (hash-ref n 'x1)]
+         [f2 (hash-ref n 'x2)])
+    (check-false (f1 (st '((x1 . #f) (x2 . #f)))))
+    (check-false (f1 (st '((x1 . #f) (x2 . #t)))))
+    (check-true (f1 (st '((x1 . #t) (x2 . #f)))))
+    (check-true (f1 (st '((x1 . #t) (x2 . #t)))))
+
+    (check-false (f2 (st '((x1 . #f) (x2 . #f)))))
+    (check-true (f2 (st '((x1 . #f) (x2 . #t)))))
+    (check-false (f2 (st '((x1 . #t) (x2 . #f)))))
+    (check-true (f2 (st '((x1 . #t) (x2 . #t))))))
   (let ([f1 (stream-first (enumerate-boolean-functions 1))]
         [f1/list (stream-first (enumerate-boolean-functions/list 1))])
     (check-false (f1 #f)) (check-false (f1 #t))

networks.rkt

@@ -71,6 +71,7 @@
                                               (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?)]
+               [table->network (->* ((listof (*list/c any/c any/c))) (#:headers boolean?) network?)]
                [boolean-power (-> number? (listof (listof boolean?)))]
                [boolean-power/stream (-> number? (stream/c (listof boolean?)))]
                [enumerate-boolean-tables (-> number? (stream/c (listof (*list/c boolean? boolean?))))]
@@ -541,6 +542,43 @@
      (let-values ([(x fx) (split-at-right line 1)])
        (values x (car fx))))))
 
+;;; Given a table like the one produced by tabulate-network,
+;;; constructs a Boolean network having this behaviour.  If headers is
+;;; #t, considers that the first element of the list are the headers
+;;; and reads the names of the variables from them.  Otherwise
+;;; generates names for variables of the form xi, where 0 ≤ i < number
+;;; of variables, and treats all rows in the table as defining the
+;;; behaviour of the functions of the network.  The columns defining
+;;; the functions are taken to be in the same order as the variables
+;;; in the first half of the function.  The headers of the columns
+;;; defining the functions are therefore discarded.
+;;;
+;;; This function relies on table->function, so the same caveats
+;;; apply.
+(define (table->network table #:headers [headers #t])
+  (define n (/ (length (car table)) 2))
+  ;; Get the variable names from the table or generate them, if
+  ;; necessary.
+  (define var-names (cond [headers (take (car table) n)]
+                          [else (for ([i (in-range n)])
+                                  (symbol->string (format "x~a" i)))]))
+  ;; Drop the headers if they are present.
+  (define tab (cond [headers (cdr table)]
+                    [else table]))
+  ;; Split the table into the inputs and the outputs of the functions.
+  (define-values (ins outs) (multi-split-at tab n))
+  ;; Transpose outs to have functions define by lines instead of by
+  ;; columns.
+  (define func-lines (lists-transpose outs))
+  ;; Make states out of inputs.
+  (define st-ins (for/list ([in ins]) (make-state (map cons var-names in))))
+  ;; Construct the functions.
+  (define funcs (for/list ([out func-lines])
+                  (table->function (for/list ([in st-ins] [o out])
+                                     (list in o)))))
+  ;; Construct the network.
+  (make-network-from-functions (map cons var-names funcs)))
+
 ;;; Returns the n-th Cartesian power of the Boolean domain: {0,1}^n.
 (define (boolean-power n) (apply cartesian-product (make-list n '(#f #t))))