dds/networks.rkt
Sergiu Ivanov 180810a2aa utils: 0-1 -> 01
Shorter and easier to type.
2020-06-06 08:23:55 +02:00

919 lines
40 KiB
Racket
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#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" "functions.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?))
network?)]
[list-interactions (-> network-form? variable? (listof variable?))]
[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?)]
[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?)]
[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?)]
[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?)]
[pretty-print-boolean-state (-> state? string?)]
[pretty-print-state-graph-with (-> graph? (-> state? string?) graph?)]
[pretty-print-state-graph (-> graph? graph?)]
[ppsg (-> graph? graph?)]
[pretty-print-boolean-state-graph (-> graph? graph?)]
[ppsgb (-> graph? graph?)]
[build-full-boolean-state-graph (-> dynamics? graph?)]
[build-full-boolean-state-graph-annotated (-> dynamics? graph?)]
[tabulate-state (->* (procedure? domain-mapping/c) (#:headers boolean?)
(listof (listof any/c)))]
[tabulate-state* (->* ((non-empty-listof procedure?) domain-mapping/c) (#:headers boolean?)
(listof (listof any/c)))]
[tabulate-state/boolean (->* (procedure? (listof variable?)) (#:headers boolean?)
(listof (listof any/c)))]
[tabulate-state*/boolean (->* ((non-empty-listof 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->network (->* ((listof (*list/c any/c any/c))) (#:headers boolean?) network?)]
[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?)]
[modality? (-> any/c boolean?)]
[mode? (-> any/c boolean?)])
;; Contracts
(contract-out [state/c contract?]
[update-function/c contract?]
[domain-mapping/c contract?]))
(module+ test
(require rackunit))
;;; =================
;;; 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)))))
(module+ test
(test-case "basic definitions"
(define f1 (λ (s) (let ([x1 (hash-ref s 'x1)]
[x2 (hash-ref s 'x2)])
(and x1 (not x2)))))
(define f2 (λ (s) (let ([x2 (hash-ref s 'x2)])
(not x2))))
(define bn (make-network-from-functions `((x1 . ,f1) (x2 . ,f2))))
(define s1 (make-state '((x1 . #t) (x2 . #f))))
(define new-s1 (update bn s1 '(x2 x1)))
(define s2 (make-state '((x1 . #f) (x2 . #f))))
(define new-s2 (update bn s2 '(x2)))
(check-equal? s1 #hash((x1 . #t) (x2 . #f)))
(check-equal? new-s1 #hash((x1 . #t) (x2 . #t)))
(check-equal? s2 #hash((x1 . #f) (x2 . #f)))
(check-equal? new-s2 #hash((x1 . #f) (x2 . #t)))))
;;; 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)]))))
(module+ test
(test-case "make-state, make-state-booleanize, booleanize-state"
(check-equal? (make-state-booleanize '((a . 0) (b . 1)))
(make-state '((a . #f) (b . #t))))
(check-equal? (booleanize-state (make-state '((a . 0) (b . 1))))
(make-state '((a . #f) (b . #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)
(λ (s) (eval-with s form)))
(module+ test
(test-case "update-function-form->update-function"
(define s (make-state '((x . #t) (y . #f))))
(define f (update-function-form->update-function '(and x y)))
(check-equal? (f s) #f)))
;;; 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))))
(module+ test
(test-case "network-form->network"
(define bn (network-form->network
(make-hash '((a . (and a b)) (b . (not b))))))
(define s (make-state '((a . #t) (b . #t))))
(check-equal? ((hash-ref bn 'a) s) #t)))
;;; 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)))
(module+ test
(test-case "make-network-from-forms"
(define bn (make-network-from-forms '((a . (and a b))
(b . (not b)))))
(define s (make-state '((a . #t) (b . #t))))
(check-equal? ((hash-ref bn 'a) s) #t)))
;;; ============================
;;; 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.
;;; 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)))
(module+ test
(test-case "list-interactions"
(define n #hash((a . (+ a b c))
(b . (- b c))))
(check-true (set=? (list-interactions n 'a) '(a b)))
(check-true (set=? (list-interactions n 'b) '(b)))))
;;; 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))))))
(module+ test
(test-case "build-interaction-graph"
(define n #hash((a . (+ a b c))
(b . (- b c))))
(define ig (build-interaction-graph n))
(check-true (has-vertex? ig 'a))
(check-true (has-vertex? ig 'b))
(check-false (has-vertex? ig 'c))
(check-true (has-edge? ig 'a 'a))
(check-true (has-edge? ig 'b 'a))
(check-true (has-edge? ig 'b 'b))
(check-false (has-edge? ig 'c 'b))
(check-false (has-edge? ig 'c 'a))))
;;; 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
;;; 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)])
(for/list ([s (apply cartesian-product domains)])
(make-state (for/list ([var vars] [val s])
(cons var val))))))
(module+ test
(test-case "build-all-states"
(check-equal? (build-all-states #hash((a . (#t #f)) (b . (1 2 3))))
'(#hash((a . #t) (b . 1))
#hash((a . #t) (b . 2))
#hash((a . #t) (b . 3))
#hash((a . #f) (b . 1))
#hash((a . #f) (b . 2))
#hash((a . #f) (b . 3))))))
;;; 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)))
(module+ test
(test-case "make-same-domains, make-boolean-domains"
(check-equal? (make-boolean-domains '(a b))
#hash((a . (#f #t)) (b . (#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)))
(module+ test
(test-case "build-all-boolean-states"
(check-equal? (build-all-boolean-states '(a b))
'(#hash((a . #f) (b . #f))
#hash((a . #f) (b . #t))
#hash((a . #t) (b . #f))
#hash((a . #t) (b . #t))))))
;;; Given two interacting variables of a network and the domains
;;; 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)
(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)]
;; 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])))
(module+ test
(test-case "get-interaction-sign"
(define n #hash((a . (not b)) (b . a)))
(define doms (make-boolean-domains '(a b)))
(check-equal? (get-interaction-sign (network-form->network n) doms 'a 'b) '+)
(check-equal? (get-interaction-sign (network-form->network n) doms 'b 'a) '-)))
;;; 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)])
;; Label every edge of the interaction graph with the sign.
(define sig
(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)))))
;; Ensure that every variable of the network appears in the signed
;; interaction graph as well.
(for ([v (in-vertices ig)])
(add-vertex! sig v))
sig))
(module+ test
(test-case "build-signed-interaction-graph/form"
(define n #hash((a . (not b)) (b . a)))
(define doms (make-boolean-domains '(a b)))
(define sig1 (build-signed-interaction-graph/form n doms))
(check-true (has-vertex? sig1 'a))
(check-true (has-vertex? sig1 'b))
(check-false (has-vertex? sig1 'c))
(check-false (has-edge? sig1 'a 'a))
(check-true (has-edge? sig1 'b 'a))
(check-false (has-edge? sig1 'b 'b))
(check-false (has-edge? sig1 'c 'b))
(check-false (has-edge? sig1 'c 'a))
(check-equal? (edge-weight sig1 'a 'b) '+)
(check-equal? (edge-weight sig1 'b 'a) '-)))
;;; 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))))
(module+ test
(test-case "build-boolean-signed-interaction-graph/form"
(define n #hash((a . (not b)) (b . a)))
(define sig2 (build-boolean-signed-interaction-graph/form n))
(check-true (has-vertex? sig2 'a))
(check-true (has-vertex? sig2 'b))
(check-false (has-vertex? sig2 'c))
(check-false (has-edge? sig2 'a 'a))
(check-true (has-edge? sig2 'b 'a))
(check-false (has-edge? sig2 'b 'b))
(check-false (has-edge? sig2 'c 'b))
(check-false (has-edge? sig2 'c 'a))
(check-equal? (edge-weight sig2 'a 'b) '+)
(check-equal? (edge-weight sig2 'b 'a) '-)))
;;; 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)
(define sig
(weighted-graph/directed
(for*/fold ([edges '()])
([(x _) (in-hash network)]
[(y _) (in-hash network)])
(match (get-interaction-sign network doms x y)
['0 edges]
[sign (cons (list sign x y) edges)]))))
;; Ensure that all variables of the network appear in the signed
;; interaction graph.
(for ([(v _) (in-hash network)])
(add-vertex! sig v))
sig)
;;; 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))))
(module+ test
(test-case "build-signed-interaction-graph, build-boolean-signed-interaction-graph"
(define n #hash((a . (not b)) (b . a)))
(define sig3 (build-boolean-signed-interaction-graph (network-form->network n)))
(check-true (has-vertex? sig3 'a))
(check-true (has-vertex? sig3 'b))
(check-equal? (edge-weight sig3 'a 'a) '+)
(check-equal? (edge-weight sig3 'b 'b) '+)
(check-equal? (edge-weight sig3 'a 'b) '+)
(check-equal? (edge-weight sig3 'b 'a) '-)))
;;; Interaction graphs for networks without interactions must still
;;; contain all nodes.
(module+ test
(test-case "Interaction must graphs always contain all nodes."
(define n #hash((a . #t) (b . #t)))
(define ig (build-interaction-graph n))
(define sig-nf (build-boolean-signed-interaction-graph/form n))
(define sig (build-boolean-signed-interaction-graph (network-form->network n)))
(check-equal? (get-vertices ig) '(b a))
(check-true (empty? (get-edges ig)))
(check-equal? (get-vertices sig-nf) '(b a))
(check-true (empty? (get-edges sig-nf)))
(check-equal? (get-vertices sig) '(b a))))
;;; ====================
;;; Dynamics of networks
;;; ====================
;;; This section contains definitions for building and analysing the
;;; dynamics of networks.
;;; 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)))])])
;;; 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)))
(module+ test
(test-case "make-asyn, make-syn"
(define vars '(a b c))
(check-equal? (make-asyn vars) (set (set 'a) (set 'b) (set 'c)))
(check-equal? (make-syn vars) (set (set 'a 'b 'c)))))
;;; 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))
(module+ test
(test-case "make-asyn-dynamics, make-syn-dynamics"
(define n (network-form->network #hash((a . (not a)) (b . b))))
(define asyn (make-asyn-dynamics n))
(define syn (make-syn-dynamics n))
(check-equal? (dynamics-network asyn) n)
(check-equal? (dynamics-mode asyn) (set (set 'a) (set 'b)))
(check-equal? (dynamics-network syn) n)
(check-equal? (dynamics-mode syn) (set (set 'a 'b)))))
;;; 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))
;;; 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))
;;; 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)))
(module+ test
(test-case "pretty-print-state"
(check-equal? (pretty-print-state (make-state '((a . #f) (b . 3) (c . 4))))
"a:#f b:3 c:4")))
;;; 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->01 val))) #t)))
(module+ test
(test-case "pretty-print-boolean-state"
(check-equal?
(pretty-print-boolean-state (make-state '((a . #f) (b . #t) (c . #t))))
"a:0 b:1 c:1")))
;;; 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 ppsg pretty-print-state-graph)
;;; 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 ppsgb pretty-print-boolean-state-graph)
;;; 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))))))
(module+ test
(test-case "Dynamics of networks"
(define n (network-form->network #hash((a . (not a)) (b . b))))
(define asyn (make-asyn-dynamics n))
(define syn (make-syn-dynamics n))
(define s (make-state '((a . #t) (b . #f))))
(define ss (set (make-state '((a . #t) (b . #t)))
(make-state '((a . #f) (b . #t)))))
(define gr1 (dds-build-n-step-state-graph asyn (set s) 1))
(define gr-full (dds-build-state-graph asyn (set s)))
(define gr-full-pp (pretty-print-state-graph gr-full))
(define gr-full-ppb (pretty-print-boolean-state-graph gr-full))
(define gr-complete-bool (build-full-boolean-state-graph asyn))
(define gr-complete-bool-ann (build-full-boolean-state-graph-annotated asyn))
(check-equal? (dds-step-one asyn s) (set (make-state '((a . #f) (b . #f)))
(make-state '((a . #t) (b . #f)))))
(check-equal? (dds-step-one-annotated asyn s)
(set (cons (set 'b) '#hash((a . #t) (b . #f)))
(cons (set 'a) '#hash((a . #f) (b . #f)))))
(check-equal? (dds-step-one syn s) (set (make-state '((a . #f) (b . #f)))))
(check-equal? (dds-step asyn ss)
(set (make-state '((a . #f) (b . #t)))
(make-state '((a . #t) (b . #t)))))
(check-true (has-vertex? gr1 #hash((a . #t) (b . #f))))
(check-true (has-vertex? gr1 #hash((a . #f) (b . #f))))
(check-false (has-vertex? gr1 #hash((a . #t) (b . #t))))
(check-true (has-edge? gr1 #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))))
(check-true (has-edge? gr1 #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))))
(check-false (has-edge? gr1 #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))))
(check-true (has-vertex? gr-full #hash((a . #t) (b . #f))))
(check-true (has-vertex? gr-full #hash((a . #f) (b . #f))))
(check-false (has-vertex? gr-full #hash((a . #t) (b . #t))))
(check-true (has-edge? gr-full #hash((a . #t) (b . #f)) #hash((a . #f) (b . #f))))
(check-true (has-edge? gr-full #hash((a . #t) (b . #f)) #hash((a . #t) (b . #f))))
(check-true (has-edge? gr-full #hash((a . #f) (b . #f)) #hash((a . #t) (b . #f))))
(check-true (has-edge? gr-full #hash((a . #f) (b . #f)) #hash((a . #f) (b . #f))))
(check-true (has-vertex? gr-full-pp "a:#f b:#f"))
(check-true (has-vertex? gr-full-pp "a:#t b:#f"))
(check-true (has-vertex? gr-full-ppb "a:0 b:0"))
(check-true (has-vertex? gr-full-ppb "a:1 b:0"))
(check-true (set=?
(get-edges gr-complete-bool)
'((#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))
(#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f)))
(#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))
(#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))
(#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t)))
(#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t)))
(#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t)))
(#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t))))))
(check-true (set=?
(get-edges gr-complete-bool-ann)
'((#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))
(#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f)))
(#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))
(#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))
(#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t)))
(#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t)))
(#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t)))
(#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t))))))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #f) (b . #f)) #hash((a . #t) (b . #f)))
(set (set 'a)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #f) (b . #f)) #hash((a . #f) (b . #f)))
(set (set 'b)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #t) (b . #f)) #hash((a . #t) (b . #f)))
(set (set 'b)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #t) (b . #f)) #hash((a . #f) (b . #f)))
(set (set 'a)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #t) (b . #t)) #hash((a . #f) (b . #t)))
(set (set 'a)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #t) (b . #t)) #hash((a . #t) (b . #t)))
(set (set 'b)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #f) (b . #t)) #hash((a . #f) (b . #t)))
(set (set 'b)))
(check-equal? (edge-weight gr-complete-bool-ann
#hash((a . #f) (b . #t)) #hash((a . #t) (b . #t)))
(set (set 'a)))))
;;; =================================
;;; Tabulating functions and networks
;;; =================================
;;; 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 tab (tabulate-state* `(,func) domains #:headers headers))
(cond
[headers
;; Replace 'f1 in the headers by 'f.
(match tab [(cons hdrs vals)
(cons (append (drop-right hdrs 1) '(f)) vals)])]
[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))
(module+ test
(test-case "tabulate-state/boolean"
(define func (λ (st) (not (hash-ref st 'a))))
(check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f)))))
;;; Like tabulate-state, but takes a list of functions over the same
;;; domain. If headers is #t, the first list of the result enumerates
;;; the variable names, and then contains a symbol 'fi for each of the
;;; functions, where i is replaced by the number of the function in
;;; the list.
(define (tabulate-state* funcs domains #:headers [headers #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 domains (λ (x y) x) #t))
(define func-names (for/list ([_ funcs] [i (in-naturals 1)]) (string->symbol (format "f~a" i))))
(cons (append var-names func-names) tab)]
[else tab]))
;;; Like tabulate-state/boolean, but takes a list of functions.
(define (tabulate-state*/boolean funcs args #:headers [headers #t])
(tabulate-state* funcs (make-boolean-domains args) #:headers headers))
(module+ test
(test-case "tabulate-state*/boolean"
(define f1 (λ (st) (and (hash-ref st 'a) (hash-ref st 'b))))
(define f2 (λ (st) (or (hash-ref st 'a) (hash-ref st 'b))))
(check-equal? (tabulate-state*/boolean (list f1 f2) '(a b))
'((a b f1 f2)
(#f #f #f #f)
(#f #t #f #t)
(#t #f #f #t)
(#t #t #t #t)))))
;;; 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])
;; I use hash-map with try-order? set to #t to ask the hash table to
;; sort the keys for me.
(define-values (vars funcs) (for/lists (l1 l2)
([pair (hash-map network cons #t)])
(values (car pair) (cdr pair))))
(define tab (tabulate-state* funcs domains #:headers headers))
(cond
[headers
;; Replace the names of the functions tabulate-state* gave us by
;; what we promise in the comment.
(define fnames (for/list ([x (in-list vars)])
(string->symbol (format "f-~a" x))))
(match tab [(cons hdrs vals)
(cons (append (take hdrs (length vars)) fnames) vals)])]
[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))
(module+ test
(test-case "tabulate-boolean-network"
(define bn (network-form->network #hash((a . (not a)) (b . b))))
(check-equal? (tabulate-boolean-network bn)
'((a b f-a f-b) (#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t)))
(check-equal? (tabulate-boolean-network bn #:headers #f)
'((#f #f #t #f) (#f #t #t #t) (#t #f #f #f) (#t #t #f #t)))))
;;; ===================================
;;; Constructing functions and networks
;;; ===================================
;;; 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)))
(module+ test
(test-case "table->network"
(define n (table->network '((x1 x2 f1 f2)
(#f #f #f #f)
(#f #t #f #t)
(#t #f #t #f)
(#t #t #t #t))))
(define f1 (hash-ref n 'x1))
(define f2 (hash-ref n 'x2))
(check-false (f1 (make-state '((x1 . #f) (x2 . #f)))))
(check-false (f1 (make-state '((x1 . #f) (x2 . #t)))))
(check-true (f1 (make-state '((x1 . #t) (x2 . #f)))))
(check-true (f1 (make-state '((x1 . #t) (x2 . #t)))))
(check-false (f2 (make-state '((x1 . #f) (x2 . #f)))))
(check-true (f2 (make-state '((x1 . #f) (x2 . #t)))))
(check-false (f2 (make-state '((x1 . #t) (x2 . #f)))))
(check-true (f2 (make-state '((x1 . #t) (x2 . #t)))))))
;;; =============================
;;; Random functions and networks
;;; =============================
;;; 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)))
(module+ test
(test-case "random-boolean-function/state"
(random-seed 0)
(define f (random-boolean-function/state '(x1 x2)))
(check-equal? (tabulate-state/boolean f '(x1 x2))
'((x1 x2 f) (#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t)))
(check-equal? (tabulate-state/boolean f '(x1 x2) #:headers #f)
'((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t)))
(define bn (random-boolean-network/vars 3))
(check-equal? (tabulate-boolean-network bn)
'((x0 x1 x2 f-x0 f-x1 f-x2)
(#f #f #f #f #t #f)
(#f #f #t #t #f #f)
(#f #t #f #f #t #t)
(#f #t #t #t #f #f)
(#t #f #f #t #f #t)
(#t #f #t #f #f #t)
(#t #t #f #f #f #f)
(#t #t #t #t #t #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)))))