diff --git a/networks.rkt b/networks.rkt index 9c4f6f8..1435212 100644 --- a/networks.rkt +++ b/networks.rkt @@ -47,6 +47,8 @@ tabulate-state tabulate-state/boolean tabulate-state+headers tabulate-state+headers/boolean tabulate-network tabulate-network+headers + + table->network ) (define-type (State a) (VariableMapping a)) @@ -928,7 +930,66 @@ (#f #t #t #t) (#t #f #f #f) (#t #t #f #t))))) - ) + + (: table->network (All (a) (-> (Listof (Listof a)) (Network a)))) + (define (table->network table) + (define n : Integer (quotient (length (car table)) 2)) + ;; Get the variable names from the table or generate them, if + ;; necessary. + (define var-names : (Listof Variable) + (for/list : (Listof Variable) + ([i (in-range 1 (add1 n))]) + (format-symbol "x~a" i))) + ;; Split the table into the inputs and the outputs of the functions. + (define-values (ins outs) (multi-split-at table n)) + ;; Transpose outs to have functions define by lines instead of by + ;; columns. + (define func-lines : (Listof (Listof a)) (lists-transpose outs)) + ;; Make states out of inputs. + (define st-ins : (Listof (State a)) + (for/list ([in ins]) (make-immutable-hash + (map (inst cons Variable a) var-names in)))) + ;; Construct the functions. + (define funcs : (Listof (UpdateFunction a)) + (for/list ([out func-lines]) + (table->unary-function + (for/list : (Listof (List (State a) a)) + ([in st-ins] [o out]) + (list in o))))) + ;; Infer the domains. + (define domains : (DomainMapping a) + (make-immutable-hash + (map (inst cons Variable (Domain a)) + var-names + (map (inst remove-duplicates a) (lists-transpose ins))))) + ;; Construct the network. + (network (make-immutable-hash + (map (inst cons Variable (UpdateFunction a)) + var-names funcs)) + domains)) + + (module+ test + (test-case "table->network" + (define n (table->network '((#f #f #f #f) + (#f #t #f #t) + (#t #f #t #f) + (#t #t #t #t)))) + (define f1 (hash-ref (network-functions n) 'x1)) + (define f2 (hash-ref (network-functions n) 'x2)) + + (check-false (f1 (hash 'x1 #f 'x2 #f))) + (check-false (f1 (hash 'x1 #f 'x2 #t))) + (check-true (f1 (hash 'x1 #t 'x2 #f))) + (check-true (f1 (hash 'x1 #t 'x2 #t))) + + (check-false (f2 (hash 'x1 #f 'x2 #f))) + (check-true (f2 (hash 'x1 #f 'x2 #t))) + (check-false (f2 (hash 'x1 #t 'x2 #f))) + (check-true (f2 (hash 'x1 #t 'x2 #t))) + + (check-equal? (network-domains n) + #hash((x1 . (#f #t)) (x2 . (#f #t)))))) + ) (require 'typed) diff --git a/scribblings/networks.scrbl b/scribblings/networks.scrbl index ca94b0b..3b646ee 100644 --- a/scribblings/networks.scrbl +++ b/scribblings/networks.scrbl @@ -832,6 +832,31 @@ function names in the corresponding column headers are of the form @section{Constructing functions and networks} +@defproc[(table->network [table (Listof (Listof a))]) + (Network a)]{ + +Given a table like the one produced by @racket[tabulate-network], +constructs a network having this behaviour. + +Variable names are generated as @tt{xi}, where 1 ≤ @tt{i} ≤ number of +variables. The columns defining the functions are taken to be in the +same order as the columns defining the variables. The domains of the +network are a mapping assigning to each variable the set of values +which can appear in the corresponding column in the table. + +This function relies on @racket[table->unary-function], so the same +performance caveats apply. + +This function does not check whether the table is complete. + +@ex[ +(let ([n (table->network '((#f #f #f #f) + (#f #t #f #t) + (#t #f #t #f) + (#t #t #t #t)))]) + (tabulate-network n)) +]} + @section{Random functions and networks} @section{TBF/TBN and SBF/SBN}