dds/networks.rkt

652 lines
29 KiB
Racket
Raw Normal View History

#lang racket
;;; dds/networks
;;; This module provides some quick definitions for and analysing
;;; network models. A network is a set of variables which are updated
;;; according to their corresponding update functions. The variables
;;; to be updated at each step are given by the mode.
;;;
;;; This model can generalise Boolean networks, TBANs, multivalued
;;; networks, etc.
(require "utils.rkt" "generic.rkt" graph racket/random)
(provide
;; Structures
(struct-out dynamics)
;; Functions
(contract-out [update (-> network? state? (set/c variable? #:kind 'dont-care) state?)]
[make-state (-> (listof (cons/c symbol? any/c)) state?)]
[make-state-booleanize (-> (listof (cons/c symbol? (or/c 0 1))) state?)]
[booleanize-state (-> state? state?)]
[make-network-from-functions (-> (listof (cons/c symbol? update-function/c)) network?)]
[update-function-form->update-function (-> update-function-form? update-function/c)]
[network-form->network (-> network-form? network?)]
[make-network-from-forms (-> (listof (cons/c symbol? update-function-form?))
2020-02-20 15:17:32 +01:00
network?)]
2020-02-20 15:56:48 +01:00
[list-interactions (-> network-form? variable? (listof variable?))]
2020-02-22 22:27:40 +01:00
[build-interaction-graph (-> network-form? graph?)]
[build-all-states (-> domain-mapping/c (listof state?))]
[make-same-domains (-> (listof variable?) generic-set? domain-mapping/c)]
[make-boolean-domains (-> (listof variable?) (hash/c variable? (list/c #f #t)))]
[build-all-boolean-states (-> (listof variable?) (listof state?))]
[get-interaction-sign (-> network? domain-mapping/c variable? variable? (or/c '+ '- '0))]
[build-signed-interaction-graph/form (-> network-form? domain-mapping/c graph?)]
[build-boolean-signed-interaction-graph/form (-> network-form? graph?)]
[build-signed-interaction-graph (-> network? domain-mapping/c graph?)]
[build-boolean-signed-interaction-graph (-> network? graph?)]
2020-02-23 11:25:19 +01:00
[make-asyn (-> (listof variable?) mode?)]
[make-syn (-> (listof variable?) mode?)]
[make-dynamics-from-func (-> network? (-> (listof variable?) mode?) dynamics?)]
[make-asyn-dynamics (-> network? dynamics?)]
[make-syn-dynamics (-> network? dynamics?)]
[read-org-network-make-asyn (-> string? dynamics?)]
[read-org-network-make-syn (-> string? dynamics?)]
2020-02-23 13:28:51 +01:00
[dds-step-one (-> dynamics? state? (set/c state?))]
[dds-step-one-annotated (-> dynamics? state? (set/c (cons/c modality? state?)))]
[dds-step (-> dynamics? (set/c state? #:kind 'dont-care) (set/c state?))]
[dds-build-state-graph (-> dynamics? (set/c state? #:kind 'dont-care) graph?)]
2020-02-23 19:24:53 +01:00
[dds-build-n-step-state-graph (-> dynamics? (set/c state? #:kind 'dont-care) number? graph?)]
[dds-build-state-graph-annotated (-> dynamics? (set/c state? #:kind 'dont-care) graph?)]
[dds-build-n-step-state-graph-annotated (-> dynamics? (set/c state? #:kind 'dont-care) number? graph?)]
[pretty-print-state (-> state? string?)]
[any->boolean (-> any/c boolean?)]
[pretty-print-boolean-state (-> state? string?)]
[pretty-print-state-graph-with (-> graph? (-> state? string?) graph?)]
[pretty-print-state-graph (-> graph? graph?)]
[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?)
(listof (listof any/c)))]
[tabulate-network (->* (network? domain-mapping/c) (#:headers boolean?)
(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?)]
2020-03-24 00:18:39 +01:00
[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?))))]
[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?)]
[random-boolean-network ((listof variable?) . -> . network?)]
[random-boolean-network/vars (number? . -> . network?)])
;; Predicates
(contract-out [variable? (-> any/c boolean?)]
[state? (-> any/c boolean?)]
[update-function-form? (-> any/c boolean?)]
[network-form? (-> any/c boolean?)]
2020-02-23 13:53:02 +01:00
[modality? (-> any/c boolean?)]
[mode? (-> any/c boolean?)])
;; Contracts
2020-02-22 10:37:37 +01:00
(contract-out [state/c contract?]
[update-function/c contract?]
[domain-mapping/c contract?])
;; Syntax
2020-03-25 23:15:37 +01:00
unorg-syn unorg-asyn)
;;; =================
;;; Basic definitions
;;; =================
(define variable? symbol?)
;;; A state of a network is a mapping from the variables of the
;;; network to their values.
(define state? variable-mapping?)
(define state/c (flat-named-contract 'state state?))
;;; An update function is a function computing a value from the given
;;; state.
(define update-function/c (-> state? any/c))
;;; A network is a mapping from its variables to its update functions.
(define network? (hash/c variable? procedure?))
;;; Given a state s updates all the variables from xs. This
;;; corresponds to a parallel mode.
(define (update network s xs)
(for/fold ([new-s s])
([x xs])
(let ([f (hash-ref network x)])
(hash-set new-s x (f s)))))
;;; A version of make-immutable-hash restricted to creating network
;;; states (see contract).
(define (make-state mappings) (make-immutable-hash mappings))
;;; Makes a new Boolean states from a state with numerical values 0
;;; and 1.
(define (make-state-booleanize mappings)
(make-state (for/list ([mp mappings])
(match mp
[(cons var 0) (cons var #f)]
[(cons var 1) (cons var #t)]))))
;;; Booleanizes a given state: replaces 0 with #f and 1 with #t.
(define (booleanize-state s)
(for/hash ([(x val) s]) (match val [0 (values x #f)] [1 (values x #t)])))
;;; A version of make-immutable-hash restricted to creating networks.
(define (make-network-from-functions funcs) (make-immutable-hash funcs))
;;; =================================
;;; Syntactic description of networks
;;; =================================
;;; An update function form is any form which can appear as a body of
;;; a function and which can be evaluated with eval. For example,
;;; '(and x y (not z)) or '(+ 1 a (- b 10)).
(define update-function-form? any/c)
;;; A Boolean network form is a mapping from its variables to the
;;; forms of their update functions.
(define network-form? variable-mapping?)
;;; Build an update function from an update function form.
(define (update-function-form->update-function form)
2020-02-20 15:36:29 +01:00
(λ (s) (eval-with s form)))
;;; Build a network from a network form.
(define (network-form->network bnf)
(for/hash ([(x form) bnf])
(values x (update-function-form->update-function form))))
;;; Build a network from a list of pairs of forms of update functions.
(define (make-network-from-forms forms)
(network-form->network (make-immutable-hash forms)))
;;; ============================
;;; Inferring interaction graphs
;;; ============================
;;; I allow any syntactic forms in definitions of Boolean functions.
;;; I can still find out which Boolean variables appear in those
;;; syntactic form, but I have no reliable syntactic means of finding
;;; out what kind of action do they have (inhibition or activation)
;;; since I cannot do Boolean minimisation (e.g., I cannot rely on not
;;; appearing before a variable, since (not (not a)) is equivalent
;;; to a). On the other hand, going through all Boolean states is
;;; quite resource-consuming and thus not always useful.
;;;
;;; In this section I provide inference of both unsigned and signed
;;; interaction graphs, but since the inference of signed interaction
;;; graphs is based on analysing the dynamics of the networks, it may
;;; be quite resource-consuming.
2020-02-20 15:17:32 +01:00
;;; Lists the variables of the network form appearing in the update
;;; function form for x.
(define (list-interactions nf x)
(set-intersect
(extract-symbols (hash-ref nf x))
(hash-keys nf)))
2020-02-20 15:56:48 +01:00
;;; Builds the graph in which the vertices are the variables of a
;;; given network, and which contains an arrow from a to b whenever a
;;; appears in (list-interactions a).
(define (build-interaction-graph n)
(transpose
(unweighted-graph/adj
(for/list ([(var _) n]) (cons var (list-interactions n var))))))
2020-02-22 22:27:40 +01:00
;;; A domain mapping is a hash set mapping variables to the lists of
;;; values in their domains.
(define domain-mapping/c (hash/c variable? list?))
;;; Given a hash-set mapping variables to generic sets of their
2020-02-22 22:27:40 +01:00
;;; possible values, constructs the list of all possible states.
(define (build-all-states vars-domains)
(let* ([var-dom-list (hash-map vars-domains (λ (x y) (cons x y)) #t)]
[vars (map car var-dom-list)]
[domains (map cdr var-dom-list)])
2020-02-22 22:27:40 +01:00
(for/list ([s (apply cartesian-product domains)])
(make-state (for/list ([var vars] [val s])
(cons var val))))))
;;; Makes a hash set mapping all variables to a single domain.
(define (make-same-domains vars domain)
(for/hash ([var vars]) (values var domain)))
;;; Makes a hash set mapping all variables to the Boolean domain.
(define (make-boolean-domains vars)
(make-same-domains vars '(#f #t)))
;;; Builds all boolean states possible over a given set of variables.
(define (build-all-boolean-states vars)
(build-all-states (make-boolean-domains vars)))
;;; Given two interacting variables of a network and the domains
2020-02-23 00:04:19 +01:00
;;; of the variables, returns '+ if the interaction is monotonously
;;; increasing, '- if it is monotonously decreasing, and '0 otherwise.
;;;
;;; This function does not check whether the two variables indeed
;;; interact. Its behaviour is undefined if the variables do not
;;; interact.
;;;
;;; /!\ This function iterates through almost all of the states of the
;;; network, so its performance decreases very quickly with network
;;; size.
(define (get-interaction-sign network doms x y)
2020-02-23 00:04:19 +01:00
(let* ([dom-x (hash-ref doms x)]
[dom-y (hash-ref doms y)]
;; Replace the domain of x by a dummy singleton.
[doms-no-x (hash-set doms x '(#f))]
;; Build all the states, but as if x were not there: since I
;; replace its domain by a singleton, all states will contain
;; the same value for x.
[states-no-x (build-all-states doms-no-x)]
2020-02-23 00:04:19 +01:00
;; Go through all states, then through all ordered pairs of
;; values of x, generate pairs of states (s1, s2) such that x
;; has a smaller value in s1, and check that updating y in s1
;; yields a smaller value than updating y in s2. I rely on
;; the fact that the domains are ordered.
[x-y-interactions (for*/list ([s states-no-x]
[x1 dom-x] ; ordered pairs of values of x
[x2 (cdr (member x1 dom-x))])
(let* ([s1 (hash-set s x x1)] ; s1(x) < s2(x)
[s2 (hash-set s x x2)]
[y1 ((hash-ref network y) s1)]
[y2 ((hash-ref network y) s2)])
;; y1 <= y2?
(<= (index-of dom-y y1) (index-of dom-y y2))))])
(cond
;; If, in all interactions, y1 <= y2, then we have an
;; increasing/promoting interaction between x and y.
[(andmap (λ (x) (eq? x #t)) x-y-interactions) '+]
;; If, in all interactions, y1 > y2, then we have an
;; decreasing/inhibiting interaction between x and y.
[(andmap (λ (x) (eq? x #f)) x-y-interactions) '-]
;; Otherwise the interaction is neither increasing nor
;; decreasing.
[else '0])))
;;; Constructs a signed interaction graph of a given network form,
;;; given the ordered domains of its variables. The order on the
;;; domains determines the signs which will appear on the interaction
;;; graph.
;;;
;;; /!\ This function iterates through almost all states of the
;;; network for every arrow in the unsigned interaction graph, so its
;;; performance decreases very quickly with the size of the network.
(define (build-signed-interaction-graph/form network-form doms)
(let ([ig (build-interaction-graph network-form)]
[network (network-form->network network-form)])
(weighted-graph/directed
(for/list ([e (in-edges ig)])
(match-let ([(list x y) e])
(list (get-interaction-sign network doms x y)
x y))))))
;;; Calls build-signed-interaction-graph with the Boolean domain for
;;; all variable.
;;;
;;; /!\ The same performance warning applies as for
;;; build-signed-interaction-graph.
(define (build-boolean-signed-interaction-graph/form network-form)
(build-signed-interaction-graph/form
network-form
(make-boolean-domains (hash-keys network-form))))
;;; Similar to build-signed-interaction-graph/form, but operates on a
;;; network rather than a form. The resulting graph only includes the
;;; edges for positive or negative interactions.
;;;
;;; This function has operates with much less knowledge than
;;; build-signed-interaction-graph/form, so prefer using the latter
;;; when you can get a network form.
;;;
;;; /!\ This function iterates through all states of the network for
;;; every arrow in the unsigned interaction graph, so its performance
;;; decreases very quickly with the size of the network.
(define (build-signed-interaction-graph network doms)
(weighted-graph/directed
(for*/fold ([edges '()])
([(x  x-val) (in-hash network)]
[(y  y-val) (in-hash network)])
(match (get-interaction-sign network doms x y)
['0 edges]
[sign (cons (list sign x y) edges)]))))
;;; Calls build-signed-interaction-graph assuming that the domains of
;;; all variables are Boolean.
;;;
;;; This function has operates with much less knowledge than
;;; build-boolean-signed-interaction-graph/form, so prefer using the
;;; latter when you can get a network form.
;;;
;;; /!\ This function iterates through all states of the network for
;;; every arrow in the unsigned interaction graph, so its performance
;;; decreases very quickly with the size of the network.
(define (build-boolean-signed-interaction-graph network)
(build-signed-interaction-graph network (make-boolean-domains (hash-keys network))))
;;; ====================
;;; Dynamics of networks
;;; ====================
;;; This section contains definitions for building and analysing the
;;; dynamics of networks.
2020-02-23 13:53:02 +01:00
;;; A modality is a set of variable.
(define modality? (set/c variable?))
;;; A mode is a set of modalities.
(define mode? (set/c modality?))
;;; A network dynamics is a network plus a mode.
(struct dynamics (network mode)
#:methods gen:dds
[;; Annotates each result state with the modality which lead to it.
(define/match (dds-step-one-annotated dyn s)
[((dynamics network mode) s)
(for/set ([m mode]) (cons m (update network s m)))])])
2020-02-23 11:25:19 +01:00
;;; Given a list of variables, builds the asynchronous mode (a set of
;;; singletons).
(define (make-asyn vars)
(for/set ([v vars]) (set v)))
;;; Given a list of variables, builds the synchronous mode (a set
;;; containing the set of variables).
(define (make-syn vars) (set (list->set vars)))
;;; Given a network, applies a function for building a mode to its
;;; variables and returns the corresponding network dynamics.
(define (make-dynamics-from-func network mode-func)
(dynamics network (mode-func (hash-keys network))))
;;; Creates the asynchronous dynamics for a given network.
(define (make-asyn-dynamics network)
(make-dynamics-from-func network make-asyn))
;;; Creates the synchronous dynamics for a given network.
(define (make-syn-dynamics network)
(make-dynamics-from-func network make-syn))
2020-02-23 19:24:53 +01:00
;;; Reads an Org-mode-produced sexp, converts it into a network, and
;;; builds the asyncronous dynamics out of it.
(define read-org-network-make-asyn (compose make-asyn-dynamics network-form->network read-org-variable-mapping))
;;; A shortcut for read-org-network-make-asyn.
(define-syntax-rule (unorg-asyn str) (read-org-network-make-asyn str))
;;; Reads an Org-mode-produced sexp, converts it into a network, and
;;; builds the synchronous dynamics out of it.
(define read-org-network-make-syn (compose make-syn-dynamics network-form->network read-org-variable-mapping))
;;; A shortcut for read-org-network-make-syn.
(define-syntax-rule (unorg-syn str) (read-org-network-make-syn str))
2020-02-23 19:24:53 +01:00
;;; Pretty-prints a state of the network.
(define (pretty-print-state s)
(string-join (hash-map s (λ (key val) (format "~a:~a" key val)) #t)))
;;; Converts any non-#f value to 1 and #f to 0.
(define (any->boolean x) (if x 1 0))
;;; Pretty-prints a state of the network to Boolean values 0 or 1.
(define (pretty-print-boolean-state s)
(string-join (hash-map s (λ (key val) (format "~a:~a" key (any->boolean val))) #t)))
;;; Given a state graph and a pretty-printer for states build a new
;;; state graph with pretty-printed vertices and edges.
(define (pretty-print-state-graph-with gr pprinter)
(update-graph gr #:v-func pprinter #:e-func pretty-print-set-sets))
;;; Pretty prints a state graph with pretty-print-state.
(define (pretty-print-state-graph gr)
(pretty-print-state-graph-with gr pretty-print-state))
;;; A shortcut for pretty-print-state-graph.
(define-syntax-rule (ppsg gr) (pretty-print-state-graph gr))
;;; Pretty prints a state graph with pretty-print-boolean-state.
(define (pretty-print-boolean-state-graph gr)
(pretty-print-state-graph-with gr pretty-print-boolean-state))
;;; A shortcut for pretty-print-boolean-state-graph.
(define-syntax-rule (ppsgb gr) (pretty-print-boolean-state-graph gr))
;;; Builds the full state graph of a Boolean network.
(define (build-full-boolean-state-graph dyn)
(dds-build-state-graph
dyn
(list->set (build-all-boolean-states (hash-keys (dynamics-network dyn))))))
;;; Build the full annotated state graph of a Boolean network.
(define (build-full-boolean-state-graph-annotated dyn)
(dds-build-state-graph-annotated
dyn
(list->set (build-all-boolean-states (hash-keys (dynamics-network dyn))))))
;;; =================================
;;; 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)))))
;;; Like tabulate, but the domains are given as a rest argument.
(define (tabulate func . doms) (tabulate/domain-list func doms))
;;; 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))))
;;; Like tabulate, but supposes that the function works on states.
;;;
;;; The argument domains defines the domains of each of the component
;;; of the states. If headers it true, the resulting list starts with
;;; a listing the names of the variables of the domain and ending with
;;; the symbol 'f, which indicates the values of the function.
(define (tabulate-state func domains #:headers [headers #t])
(define (st-vals st) (hash-map st (λ (x y) y) #t))
(define tab (for/list ([st (build-all-states domains)])
(append (st-vals st) (list (func st)))))
(cond
[headers
(define vars (append (hash-map domains (λ (x y) x) #t) '(f)))
(cons vars tab)]
[else tab]))
;;; Like tabulate-state, but assumes the function is a Boolean
;;; function. args is a list of names of the arguments which can
;;; appear in the states.
(define (tabulate-state/boolean func args #:headers [headers #t])
(tabulate-state func (make-boolean-domains args) #:headers headers))
;;; Tabulates a given network.
;;;
;;; For a Boolean network with n variables, returns a table with 2n
;;; columns and 2^n rows. The first n columns correspond to the
;;; different values of the variables of the networks. The last n
;;; columns represent the values of the n update functions of the
;;; network. If headers is #t, prepends a list of variable names and
;;; update functions (f-x, where x is the name of the corresponding
;;; variable) to the result.
(define (tabulate-network network domains #:headers [headers #t])
(define funcs (hash-map network (λ (x y) y) #t))
(define tab (for/list ([st (build-all-states domains)])
(append (hash-map st (λ (x y) y) #t)
(for/list ([f funcs]) (f st)))))
(cond
[headers
(define var-names (hash-map network (λ (x y) x) #t))
(define func-names (for/list ([x var-names]) (string->symbol (format "f-~a" x))))
(cons (append var-names func-names) tab)]
[else tab]))
;;; Like tabulate-network, but assumes all the variables are Boolean.
(define (tabulate-boolean-network bn #:headers [headers #t])
(tabulate-network bn (make-boolean-domains (hash-map bn (λ (x y) x) #t))
#:headers headers))
;;; ===================================
;;; 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))))
;;; 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))))))
2020-03-24 00:18:39 +01:00
;;; 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))))
;;; Like boolean-power, but returns a stream whose elements the
2020-03-20 16:40:15 +01:00
;;; elements of the Cartesian power.
(define (boolean-power/stream n) (apply cartesian-product/stream (make-list n '(#f #t))))
2020-03-20 16:40:15 +01:00
;;; 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)))
;;; 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)))
;;; =============================
;;; 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)))))
;;; Generates a random Boolean function of arity n.
(define random-boolean-function (compose table->function random-boolean-table))
;;; 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))
;;; 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)
(table->function (for/list ([st (build-all-states arg-domains)])
(list st (random-ref func-domain)))))
;;; Like random-function/state, but the domains of the arguments and
;;; of the function are Boolean. args is a list of names of the
;;; variables appearing in the state.
(define (random-boolean-function/state args)
(random-function/state (make-boolean-domains args) '(#f #t)))
;;; Generates a random network from the given domain mapping.
(define (random-network domains)
(for/hash ([(x x-dom) (in-hash domains)])
(values x (random-function/state domains x-dom))))
;;; Generates a random Boolean network with the given variables.
(define (random-boolean-network vars)
(random-network (make-boolean-domains vars)))
;;; Like random-boolean-network, but also generates the names of the
;;; variables for the network. The variables have the names x0 to xk,
;;; where k = n - 1.
(define (random-boolean-network/vars n)
(random-boolean-network (for/list ([i (in-range n)]) (string->symbol (format "x~a" i)))))