From 8421d89629fe213bebe64e527d7eee345de2b475 Mon Sep 17 00:00:00 2001 From: Sergiu Ivanov Date: Thu, 28 May 2020 00:24:17 +0200 Subject: [PATCH] networks: Factor out purely function-related code into functions. --- functions.rkt | 172 ++++++++++++++++++++++++++++++++++++++++++++++++++ networks.rkt | 149 +------------------------------------------ 2 files changed, 173 insertions(+), 148 deletions(-) diff --git a/functions.rkt b/functions.rkt index 1ce9c0c..d271e42 100644 --- a/functions.rkt +++ b/functions.rkt @@ -6,3 +6,175 @@ ;;; tabulating, (re)constructing from tables, generating random ;;; functions, etc. Some definitions of particular kinds of functions ;;; are also provided (threshold Boolean functions, etc.). + +(require "utils.rkt") + +(provide + ;; Functions + (contract-out + [tabulate/domain-list (-> procedure? (listof generic-set?) (listof list?))] + [tabulate (->* (procedure?) () #:rest (listof generic-set?) (listof list?))] + [tabulate/boolean (-> procedure-fixed-arity? (listof (listof boolean?)))] + [table->function (-> (listof (*list/c any/c any/c)) procedure?)] + [table->function/list (-> (listof (*list/c any/c any/c)) procedure?)] + [enumerate-boolean-tables (-> number? (stream/c (listof (*list/c boolean? boolean?))))] + [enumerate-boolean-functions (-> number? (stream/c procedure?))] + [enumerate-boolean-functions/list (-> number? (stream/c procedure?))] + [random-boolean-table (-> number? (listof (*list/c boolean? boolean?)))] + [random-boolean-function (-> number? procedure?)] + [random-boolean-function/list (-> number? procedure?)])) + +(module+ test + (require rackunit)) + + +;;; ========== +;;; Tabulating +;;; ========== + +;;; Given a function and a list of domains for each of its arguments, +;;; in order, produces a list of lists giving the values of arguments +;;; and the value of the functions for these inputs. +(define (tabulate/domain-list func doms) + (for/list ([xs (apply cartesian-product doms)]) + (append xs (list (apply func xs))))) + +(module+ test + (test-case "tabulate/domain-list" + (check-equal? (tabulate/domain-list (λ (x y) (and x y)) '((#f #t) (#f #t))) + '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))) + +;;; Like tabulate, but the domains are given as a rest argument. +(define (tabulate func . doms) (tabulate/domain-list func doms)) + +(module+ test + (test-case "tabulate" + (check-equal? (tabulate (λ (x y) (and x y)) '(#f #t) '(#f #t)) + '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))) + +;;; Like tabulate, but assumes the domains of all variables of the +;;; function are Boolean. func must have a fixed arity. It is an +;;; error to supply a function of variable arity. +(define (tabulate/boolean func) + (tabulate/domain-list func (make-list (procedure-arity func) '(#f #t)))) + +(module+ test + (test-case "tabulate/boolean" + (check-equal? (tabulate/boolean (lambda (x y) (and x y))) + '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))) + + +;;; ====================== +;;; Constructing functions +;;; ====================== + +;;; Given a table like the one produced by the tabulate functions, +;;; creates a function which has this behaviour. +;;; +;;; More exactly, the input is a list of lists of values. All but the +;;; last elements of every list give the values of the parameters of +;;; the function, while the the last element of every list gives the +;;; value of the function. Thus, every list should have at least two +;;; elements. +;;; +;;; The produced function is implemented via lookups in hash tables, +;;; meaning that it may be sometimes more expensive to compute than by +;;; using an direct symbolic implementation. +(define (table->function table) + (let ([func (table->function/list table)]) + (λ args (func args)))) + +(module+ test + (test-case "table->function" + (define negation (table->function '((#t #f) (#f #t)))) + (check-true (negation #f)) + (check-false (negation #t)))) + +;;; Like table->function, but the produced function accepts a single +;;; list of arguments instead of individual arguments. +(define (table->function/list table) + ((curry hash-ref) + (for/hash ([line table]) + (let-values ([(x fx) (split-at-right line 1)]) + (values x (car fx)))))) + +(module+ test + (test-case "table->function/list" + (define negation/list (table->function/list '((#t #f) (#f #t)))) + (check-true (negation/list '(#f))) + (check-false (negation/list '(#t))))) + +;;; Returns the stream of the truth tables of all Boolean functions of +;;; a given arity. +;;; +;;; There are 2^(2^n) Boolean functions of arity n. +(define (enumerate-boolean-tables n) + (let ([inputs (boolean-power/stream n)] + [outputs (boolean-power/stream (expt 2 n))]) + (for/stream ([out (in-stream outputs)]) + (for/list ([in (in-stream inputs)] [o out]) + (append in (list o)))))) + +;;; Returns the stream of all Boolean functions of a given arity. +;;; +;;; There are 2^(2^n) Boolean functions of arity n. +(define (enumerate-boolean-functions n) + (stream-map table->function (enumerate-boolean-tables n))) + +(module+ test + (test-case "enumerate-boolean-tables" + (define f1 (stream-first (enumerate-boolean-functions 1))) + (check-false (f1 #f)) + (check-false (f1 #t)))) + +;;; Returns the stream of all Boolean functions of a given arity. As +;;; different from the functions returned by +;;; enumerate-boolean-functions, the functions take lists of arguments +;;; instead of n arguments. +;;; +;;; There are 2^(2^n) Boolean functions of arity n. +(define (enumerate-boolean-functions/list n) + (stream-map table->function/list (enumerate-boolean-tables n))) + +(module+ test + (test-case "enumerate-boolean-functions/list" + (define f1/list (stream-first (enumerate-boolean-functions/list 1))) + (check-false (f1/list '(#f))) + (check-false (f1/list '(#t))))) + + +;;; ================ +;;; Random functions +;;; ================ + +;;; Generates a random truth table for a Boolean function of arity n. +(define (random-boolean-table n) + (define/match (num->bool x) [(0) #f] [(1) #t]) + (define inputs (boolean-power n)) + (define outputs (stream-take (in-random 2) (expt 2 n))) + (for/list ([i inputs] [o outputs]) + (append i (list (num->bool o))))) + +(module+ test + (test-case "random-boolean-table" + (random-seed 0) + (check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f))))) + +;;; Generates a random Boolean function of arity n. +(define random-boolean-function (compose table->function random-boolean-table)) + +(module+ test + (test-case "random-boolean-function" + (define f (random-boolean-function 2)) + (check-true (f #f #f)) (check-false (f #f #t)) + (check-true (f #t #f)) (check-false (f #t #t)))) + +;;; Like random-boolean-function, but the constructed function takes a +;;; list of arguments. +(define random-boolean-function/list (compose table->function/list random-boolean-table)) + +(module+ test + (test-case "random-boolean-function/list" + (define f (random-boolean-function/list 2)) + (check-false (f '(#f #f))) (check-true (f '(#f #t))) + (check-true (f '(#t #f))) (check-false (f '(#t #t))))) diff --git a/networks.rkt b/networks.rkt index 52cd037..84e7deb 100644 --- a/networks.rkt +++ b/networks.rkt @@ -10,7 +10,7 @@ ;;; This model can generalise Boolean networks, TBANs, multivalued ;;; networks, etc. -(require "utils.rkt" "generic.rkt" graph racket/random) +(require "utils.rkt" "generic.rkt" "functions.rkt" graph racket/random) (provide ;; Structures @@ -58,9 +58,6 @@ [pretty-print-boolean-state-graph (-> graph? graph?)] [build-full-boolean-state-graph (-> dynamics? graph?)] [build-full-boolean-state-graph-annotated (-> dynamics? graph?)] - [tabulate/domain-list (-> procedure? (listof generic-set?) (listof list?))] - [tabulate (->* (procedure?) () #:rest (listof generic-set?) (listof list?))] - [tabulate/boolean (-> procedure-fixed-arity? (listof (listof boolean?)))] [tabulate-state (->* (procedure? domain-mapping/c) (#:headers boolean?) (listof (listof any/c)))] [tabulate-state/boolean (->* (procedure? (listof variable?)) (#:headers boolean?) @@ -69,15 +66,7 @@ (listof (listof any/c)))] [tabulate-boolean-network (->* (network?) (#:headers boolean?) (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?)] - [enumerate-boolean-tables (-> number? (stream/c (listof (*list/c boolean? boolean?))))] - [enumerate-boolean-functions (-> number? (stream/c procedure?))] - [enumerate-boolean-functions/list (-> number? (stream/c procedure?))] - [random-boolean-table (-> number? (listof (*list/c boolean? boolean?)))] - [random-boolean-function (-> number? procedure?)] - [random-boolean-function/list (-> number? procedure?)] [random-function/state (domain-mapping/c generic-set? . -> . procedure?)] [random-boolean-function/state ((listof variable?) . -> . procedure?)] [random-network (domain-mapping/c . -> . network?)] @@ -716,36 +705,6 @@ ;;; Tabulating functions and networks ;;; ================================= -;;; Given a function and a list of domains for each of its arguments, -;;; in order, produces a list of lists giving the values of arguments -;;; and the value of the functions for these inputs. -(define (tabulate/domain-list func doms) - (for/list ([xs (apply cartesian-product doms)]) - (append xs (list (apply func xs))))) - -(module+ test - (test-case "tabulate/domain-list" - (check-equal? (tabulate/domain-list (λ (x y) (and x y)) '((#f #t) (#f #t))) - '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))) - -;;; Like tabulate, but the domains are given as a rest argument. -(define (tabulate func . doms) (tabulate/domain-list func doms)) - -(module+ test - (test-case "tabulate" - (check-equal? (tabulate (λ (x y) (and x y)) '(#f #t) '(#f #t)) - '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))) - -;;; Like tabulate, but assumes the domains of all variables of the -;;; function are Boolean. func must have a fixed arity. It is an -;;; error to supply a function of variable arity. -(define (tabulate/boolean func) - (tabulate/domain-list func (make-list (procedure-arity func) '(#f #t)))) - -(module+ test - (test-case "tabulate/boolean" - (check-equal? (tabulate/boolean (lambda (x y) (and x y))) - '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t))))) ;;; Like tabulate, but supposes that the function works on states. ;;; @@ -813,42 +772,6 @@ ;;; Constructing functions and networks ;;; =================================== -;;; Given a table like the one produced by the tabulate functions, -;;; creates a function which has this behaviour. -;;; -;;; More exactly, the input is a list of lists of values. All but the -;;; last elements of every list give the values of the parameters of -;;; the function, while the the last element of every list gives the -;;; value of the function. Thus, every list should have at least two -;;; elements. -;;; -;;; The produced function is implemented via lookups in hash tables, -;;; meaning that it may be sometimes more expensive to compute than by -;;; using an direct symbolic implementation. -(define (table->function table) - (let ([func (table->function/list table)]) - (λ args (func args)))) - -(module+ test - (test-case "table->function" - (define negation (table->function '((#t #f) (#f #t)))) - (check-true (negation #f)) - (check-false (negation #t)))) - -;;; Like table->function, but the produced function accepts a single -;;; list of arguments instead of individual arguments. -(define (table->function/list table) - ((curry hash-ref) - (for/hash ([line table]) - (let-values ([(x fx) (split-at-right line 1)]) - (values x (car fx)))))) - -(module+ test - (test-case "table->function/list" - (define negation/list (table->function/list '((#t #f) (#f #t)))) - (check-true (negation/list '(#f))) - (check-false (negation/list '(#t))))) - ;;; 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 @@ -906,81 +829,11 @@ (check-false (f2 (make-state '((x1 . #t) (x2 . #f))))) (check-true (f2 (make-state '((x1 . #t) (x2 . #t))))))) -;;; Returns the stream of the truth tables of all Boolean functions of -;;; a given arity. -;;; -;;; There are 2^(2^n) Boolean functions of arity n. -(define (enumerate-boolean-tables n) - (let ([inputs (boolean-power/stream n)] - [outputs (boolean-power/stream (expt 2 n))]) - (for/stream ([out (in-stream outputs)]) - (for/list ([in (in-stream inputs)] [o out]) - (append in (list o)))))) - -;;; Returns the stream of all Boolean functions of a given arity. -;;; -;;; There are 2^(2^n) Boolean functions of arity n. -(define (enumerate-boolean-functions n) - (stream-map table->function (enumerate-boolean-tables n))) - -(module+ test - (test-case "enumerate-boolean-tables" - (define f1 (stream-first (enumerate-boolean-functions 1))) - (check-false (f1 #f)) - (check-false (f1 #t)))) - -;;; Returns the stream of all Boolean functions of a given arity. As -;;; different from the functions returned by -;;; enumerate-boolean-functions, the functions take lists of arguments -;;; instead of n arguments. -;;; -;;; There are 2^(2^n) Boolean functions of arity n. -(define (enumerate-boolean-functions/list n) - (stream-map table->function/list (enumerate-boolean-tables n))) - -(module+ test - (test-case "enumerate-boolean-functions/list" - (define f1/list (stream-first (enumerate-boolean-functions/list 1))) - (check-false (f1/list '(#f))) - (check-false (f1/list '(#t))))) - ;;; ============================= ;;; Random functions and networks ;;; ============================= -;;; Generates a random truth table for a Boolean function of arity n. -(define (random-boolean-table n) - (define/match (num->bool x) [(0) #f] [(1) #t]) - (define inputs (boolean-power n)) - (define outputs (stream-take (in-random 2) (expt 2 n))) - (for/list ([i inputs] [o outputs]) - (append i (list (num->bool o))))) - -(module+ test - (test-case "random-boolean-table" - (random-seed 0) - (check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f))))) - -;;; Generates a random Boolean function of arity n. -(define random-boolean-function (compose table->function random-boolean-table)) - -(module+ test - (test-case "random-boolean-function" - (define f (random-boolean-function 2)) - (check-true (f #f #f)) (check-false (f #f #t)) - (check-true (f #t #f)) (check-false (f #t #t)))) - -;;; Like random-boolean-function, but the constructed function takes a -;;; list of arguments. -(define random-boolean-function/list (compose table->function/list random-boolean-table)) - -(module+ test - (test-case "random-boolean-function/list" - (define f (random-boolean-function/list 2)) - (check-false (f '(#f #f))) (check-true (f '(#f #t))) - (check-true (f '(#t #f))) (check-false (f '(#t #t))))) - ;;; Generates a random function accepting a state over the domains ;;; given by arg-domains and producing values in func-domain. (define (random-function/state arg-domains func-domain)