diff --git a/networks-tests.rkt b/networks-tests.rkt index 9a9ae62..1d4cd1e 100644 --- a/networks-tests.rkt +++ b/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)) diff --git a/networks.rkt b/networks.rkt index dca88cd..8fdedcf 100644 --- a/networks.rkt +++ b/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))))