dds/networks.rkt
2022-04-01 00:09:42 +02:00

1794 lines
79 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 (except-in "utils.rkt" lists-transpose) (submod "utils.rkt" untyped)
"generic.rkt" "functions.rkt"
graph racket/random racket/hash)
(provide
;; Structures
(contract-out [struct tbf/state ([weights (hash/c variable? number?)]
[threshold number?])]
[struct dynamics ([network network?]
[mode mode?])]
[struct network ([functions (hash/c variable? procedure?)]
[domains domain-mapping/c])]
[struct network-form ([forms variable-mapping?]
[domains domain-mapping/c])])
;; Functions
(contract-out [make-boolean-network (-> (hash/c variable? procedure?) network?)]
[make-01-network (-> (hash/c variable? procedure?) network?)]
[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?)]
[update-function-form->update-function (-> update-function-form? update-function/c)]
[network-form->network (-> network-form? network?)]
[make-boolean-network-form (-> variable-mapping? network-form?)]
[forms->boolean-network (-> variable-mapping? network?)]
[list-syntactic-interactions (-> network-form? variable? (listof variable?))]
[build-syntactic-interaction-graph (-> network-form? graph?)]
[interaction? (-> network? variable? variable? boolean?)]
[get-interaction-sign (-> network? variable? variable? (or/c #f -1 0 1))]
[build-interaction-graph (-> network? graph?)]
[build-interaction-graph/form (-> network-form? graph?)]
[build-signed-interaction-graph (-> network? graph?)]
[build-signed-interaction-graph/form (-> 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)))]
[make-01-domains (-> (listof variable?) (hash/c variable? (list/c 0 1)))]
[build-all-boolean-states (-> (listof variable?) (listof state?))]
[build-all-01-states (-> (listof variable?) (listof state?))]
[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?)]
[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-state-graph (-> dynamics? graph?)]
[build-full-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?) (#: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?)]
[apply-tbf-to-state (-> tbf? state? (or/c 0 1))]
[tbf/state-w (-> tbf/state? (hash/c variable? number?))]
[tbf/state-θ (-> tbf/state? number?)]
[make-tbf/state (-> (listof (cons/c variable? number?)) number? tbf/state?)]
[make-sbf/state (-> (listof (cons/c variable? number?)) sbf/state?)]
[apply-tbf/state (-> tbf/state? (hash/c variable? (or/c 0 1)) (or/c 0 1))]
[lists->tbfs/state (->* ((listof (listof (or/c number? symbol?))))
(#:headers boolean?)
(listof tbf/state?))]
[lists->sbfs/state (->* ((listof (listof (or/c number? symbol?))))
(#:headers boolean?)
(listof sbf/state?))]
[read-org-tbfs/state (->* (string?) (#:headers boolean?) (listof tbf/state?))]
[read-org-sbfs/state (->* (string?) (#:headers boolean?) (listof sbf/state?))]
[print-org-tbfs/state (->* ((non-empty-listof tbf/state?)) (#:headers boolean?)
(listof (listof (or/c number? symbol?))))]
[print-org-sbfs/state (->* ((non-empty-listof tbf/state?)) (#:headers boolean?)
(listof (listof (or/c number? symbol?))))]
[tbf/state-tabulate* (->* ((non-empty-listof tbf/state?)) (#:headers boolean?)
(listof (listof (or/c symbol? number?))))]
[tbf/state-tabulate (->* (tbf/state?) (#:headers boolean?)
(listof (listof (or/c symbol? number?))))]
[group-truth-table-by-nai (-> (listof (listof (or/c 0 1))) (listof (listof (listof (or/c 0 1)))))]
[make-tbn (-> (listof (cons/c variable? tbf/state?)) tbn?)]
[tbn->network (-> tbn? network?)]
[make-sbn (-> (listof (cons/c variable? tbf/state?)) sbn?)]
[parse-org-tbn (->* ((listof any/c))
(#:headers boolean? #:func-names boolean?)
tbn?)]
[read-org-tbn (->* (string?)
(#:headers boolean? #:func-names boolean?)
tbn?)]
[read-org-sbn (->* (string?)
(#:headers boolean? #:func-names boolean?)
tbn?)]
[build-tbn-state-graph (-> tbn? graph?)]
[normalized-tbn? (-> tbn? boolean?)]
[normalize-tbn (-> tbn? normalized-tbn?)]
[compact-tbf (-> tbf/state? tbf/state?)]
[compact-tbn (-> tbn? tbn?)]
[print-org-tbn (->* (tbn?) (#:headers boolean? #:func-names boolean?)
(listof (listof (or/c number? symbol?))))]
[print-org-sbn (->* (sbn?) (#:headers boolean? #:func-names boolean?)
(listof (listof (or/c number? symbol?))))]
[tbn-interaction-graph (->* (tbn?) (#:zero-edges boolean?)
graph?)]
[pretty-print-tbn-interaction-graph (-> graph? graph?)]
[sbn-interaction-graph (->* (sbn?) (#:zero-edges boolean?)
graph?)])
;; Predicates
(contract-out [variable? (-> any/c boolean?)]
[state? (-> any/c boolean?)]
[update-function-form? (-> any/c boolean?)]
[modality? (-> any/c boolean?)]
[mode? (-> any/c boolean?)]
[sbf/state? (-> any/c boolean?)])
;; Contracts
(contract-out [state/c contract?]
[update-function/c contract?]
[domain-mapping/c contract?]
[tbn? contract?]
[sbn? contract?]))
(module+ test
(require rackunit)
;; When this variable is set to #t, some particularly expensive test
;; cases are omitted.
(define skip-expensive-tests? #t)
(unless skip-expensive-tests?
(displayln "Running the complete test suite...")))
;;; =================
;;; 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 domain mapping is a hash set mapping variables to the lists of
;;; values in their domains.
(define domain-mapping/c (hash/c variable? list?))
;;; A network consists of a mapping from its variables to its update
;;; variables, as a well as of a mapping from its variables to
;;; their domains.
;;;
;;; The domain mapping does not have to assign domains to all
;;; variables (e.g., it may be empty), but in this case the functions
;;; which need to know the domains will not work.
(struct network (functions domains) #:transparent)
;;; Builds a network from a given hash table assigning functions to
;;; variables by attributing Boolean domains to every variable.
(define (make-boolean-network funcs)
(network funcs (make-boolean-domains (hash-keys funcs))))
;;; Build a network from a given hash table assigning functions to
;;; variables by attributing the domain {0,1} to every variable.
(define (make-01-network funcs)
(network funcs (make-01-domains (hash-keys funcs))))
(module+ test
(test-case "make-boolean-network"
(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-boolean-network (hash 'x1 f1 'x2 f2)))
(check-equal? (network-domains bn) (hash 'x1 '(#f #t) 'x2 '(#f #t)))))
;;; Given a state s updates all the variables from xs.
(define (update network s xs)
(define funcs (network-functions network))
(for/fold ([new-s s])
([x xs])
(define fx (hash-ref funcs x))
(hash-set new-s x (fx 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-boolean-network (hash '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)]))))
;;; 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)])))
(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))))))
;;; =================================
;;; 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 network form consists of a mapping from variables to the forms
;;; of their update functions, together with a mapping from its
;;; variables to its update functions.
;;;
;;; The domain mapping does not have to assign domains to all
;;; variables (e.g., it may be empty), but in this case the functions
;;; which need to know the domains will not work.
(struct network-form (forms domains) #:transparent)
;;; Build an update function from an update function form.
(define (update-function-form->update-function form)
(λ (s) (eval1-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 nf)
(network
(for/hash ([(x form) (in-hash (network-form-forms nf))])
(values x (update-function-form->update-function form)))
(network-form-domains nf)))
(module+ test
(test-case "network-form->network"
(define bn (network-form->network
(network-form (hash 'a '(and a b)
'b '(not b))
(hash 'a '(#f #t)
'b '(#f #t)))))
(define s (make-state '((a . #t) (b . #t))))
(check-equal? ((hash-ref (network-functions bn) 'a) s) #t)))
;;; Build a Boolean network form from a given mapping assigning forms
;;; to variables.
(define (make-boolean-network-form forms)
(network-form forms (make-boolean-domains (hash-keys forms))))
(module+ test
(test-case "make-boolean-network-form"
(check-equal? (make-boolean-network-form (hash 'a '(and a b)
'b '(not b)))
(network-form
'#hash((a . (and a b)) (b . (not b)))
'#hash((a . (#f #t)) (b . (#f #t)))))))
;;; Build a Boolean network from a given mapping assigning forms
;;; to variables.
(define forms->boolean-network
(compose network-form->network make-boolean-network-form))
(module+ test
(test-case "forms->boolean-network"
(define n (forms->boolean-network (hash 'a '(and a b)
'b '(not b))))
(check-equal? (network-domains n) (hash 'a '(#f #t)
'b '(#f #t)))))
;;; ============================
;;; Inferring interaction graphs
;;; ============================
;;; 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, especially since I allow any
;;; syntactic forms in the definitions of the functions.
;;;
;;; Note the fine difference between syntactic interaction graphs and
;;; interaction graphs generated from the dynamics of the network.
;;; The syntactic interaction graphs are based on the whether
;;; a variable appears or not in the form of the function for another
;;; variable. On the other hand, the normal, conventional interaction
;;; graph records the fact that one variable has an impact on the
;;; dynamics of the other variable. Depending on the model, these may
;;; or may not be the same.
;;; Lists the variables of the network form appearing in the update
;;; function form for x.
(define (list-syntactic-interactions nf x)
(set-intersect
(extract-symbols (hash-ref (network-form-forms nf) x))
(hash-keys (network-form-forms nf))))
(module+ test
(test-case "list-syntactic-interactions"
(define n (make-boolean-network-form #hash((a . (+ a b c))
(b . (- b c)))))
(check-true (set=? (list-syntactic-interactions n 'a) '(a b)))
(check-true (set=? (list-syntactic-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).
;;;
;;; Note that, while this definition is an easy one to check
;;; structurally, this is *not* how interaction graphs are typically
;;; defined. An interaction graph is usually defined based on the
;;; dynamics of the network: an arrow from a variable x to a variable
;;; y means that varying x and only x may have an influence on the
;;; value of y. It is easy to imagine a situation in which the
;;; syntactic interaction graph does not in fact agree with this
;;; criterion, the simplest example being the network y = x AND (NOT
;;; x).
(define (build-syntactic-interaction-graph n)
(transpose
(unweighted-graph/adj
(for/list ([(var _) (in-hash (network-form-forms n))])
(cons var (list-syntactic-interactions n var))))))
(module+ test
(test-case "build-syntactic-interaction-graph"
(define n (make-boolean-network-form #hash((a . (+ a b c))
(b . (- b c)))))
(define ig (build-syntactic-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))))
;;; 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))))))
;;; Makes a hash set mapping all variables to the Boolean domain,
;;; expressed as {0,1}.
(define (make-01-domains vars)
(make-same-domains vars '(0 1)))
(module+ test
(test-case "make-01-domains"
(check-equal? (make-01-domains '(a b))
'#hash((a . (0 1)) (b . (0 1))))))
;;; 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))))))
;;; Builds all Boolean states over a given set of variables, but with
;;; 0 and 1 for Boolean values.
(define build-all-01-states
(compose build-all-states make-01-domains))
(module+ test
(test-case "build-all-01-states"
(check-equal? (build-all-01-states '(a b))
'(#hash((a . 0) (b . 0))
#hash((a . 0) (b . 1))
#hash((a . 1) (b . 0))
#hash((a . 1) (b . 1))))))
;;; Given two variables x and y of a network f, verifies if they
;;; interact, i.e. that there exists such a state s with the property
;;; that s' which is s with a different value for x yields such a new
;;; state f(s') in which the value for y is different from f(s).
(define (interaction? network x y)
(define doms (network-domains network))
(define states-not-x (build-all-states (hash-remove doms x)))
(define dom-x (hash-ref doms x))
(define y-func (hash-ref (network-functions network) y))
(define (different-ys-exist? st)
(define x-states (for/list ([x-val (in-list dom-x)])
(hash-set st x x-val)))
(for*/first ([st1 x-states]
[st2 x-states]
#:unless (equal? (hash-ref st1 x) (hash-ref st2 x))
#:unless (equal? (y-func st1) (y-func st2)))
#t))
(for*/first ([st (in-list states-not-x)]
#:when (different-ys-exist? st))
#t))
(module+ test
(test-case "interaction?"
(define n1 (forms->boolean-network
(hash 'x '(not y)
'y 'x
'z '(and y z))))
(check-true (interaction? n1 'x 'y))
(check-true (interaction? n1 'y 'x))
(check-false (interaction? n1 'x 'z))
(define n-multi (hash 'x '(max (+ y 1) 2)
'y '(min (- y 1) 0)))
(define 123-doms (make-same-domains '(x y) '(0 1 2)))
(define n2 (network-form->network (network-form n-multi 123-doms)))
(check-false (interaction? n2 'x 'y))
(check-true (interaction? n2 'y 'x))))
;;; Given two variables x and y of a network f, checks whether they
;;; interact, and if they interact, returns 1 if increasing x leads to
;;; an increase in y, -1 if it leads to a decrease in y, and 0 if it
;;; can lead to both. If x has no impact on y, returns #f.
;;;
;;; Use interaction? if you only need to know whether two variables
;;; interact, because interaction? will be often faster.
(define (get-interaction-sign network x y)
(define doms (network-domains network))
(define dom-x (hash-ref doms x))
(define dom-y (hash-ref doms y))
(define y-func (hash-ref (network-functions network) y))
(define (collect-impacts-on-y st)
;; The way in which the values are ordered in the domains gives
;; a total order on these values. This means that considering
;; pairs of consecutive values of x is sufficient for testing the
;; sign of the interaction.
(define x-states (for/list ([x-val (in-list dom-x)])
(hash-set st x x-val)))
(for/list ([st1 (in-list x-states)]
[st2 (in-list (cdr x-states))])
(define y1-idx (index-of dom-y (y-func st1)))
(define y2-idx (index-of dom-y (y-func st2)))
(cond
[(< y1-idx y2-idx) '<]
[(> y1-idx y2-idx) '>]
[else '=])))
(define states-not-x (build-all-states (hash-remove doms x)))
(define interactions
(remove-duplicates
(for/list ([st (in-list states-not-x)])
(define impacts (remove-duplicates (collect-impacts-on-y st)))
(cond
[(and (member '< impacts) (not (member '> impacts))) '<]
[(and (member '> impacts) (not (member '< impacts))) '>]
[(equal? impacts '(=)) '=]
[else 0]))))
(cond
[(and (member '< interactions) (not (member '> interactions))) 1]
[(and (member '> interactions) (not (member '< interactions))) -1]
[(equal? interactions '(=)) #f]
[else 0]))
(module+ test
(test-case "get-interaction-sign"
(define n1 (forms->boolean-network
(hash 'x '(not y)
'y 'x
'z '(and y z)
't '(or (and (not x) y)
(and x (not y))))))
(check-equal? (get-interaction-sign n1 'x 'y) 1)
(check-equal? (get-interaction-sign n1 'y 'x) -1)
(check-false (get-interaction-sign n1 'x 'z))
(check-equal? (get-interaction-sign n1 'y 'z) 1)
(check-equal? (get-interaction-sign n1 'x 't) 0)
(define n-multi (hash 'x '(min (+ y 1) 2)
'y '(max (- y 1) 0)
'z '(- 2 y)
't '(abs (- y 1))))
(define 123-doms (make-same-domains '(x y z t) '(0 1 2)))
(define n2 (network-form->network (network-form n-multi 123-doms)))
(check-false (get-interaction-sign n2 'x 'y))
(check-equal? (get-interaction-sign n2 'y 'x) 1)
(check-equal? (get-interaction-sign n2 'y 'z) -1)
(check-equal? (get-interaction-sign n2 'y 't) 0)
(check-equal? (get-interaction-sign n2 'y 'y) 1)))
;;; Given a network, builds its interaction graph. The graph has
;;; variables as nodes and has a directed edge from x to y if
;;; interaction? returns #t for these variables, in this order.
(define (build-interaction-graph network)
(define vars (hash-keys (network-functions network)))
(unweighted-graph/directed
(for*/list ([x (in-list vars)]
[y (in-list vars)]
#:when (interaction? network x y))
(list x y))))
;;; Like build-interaction-graph, but accepts a network form and
;;; converts it a to a network.
(define build-interaction-graph/form
(compose build-interaction-graph network-form->network))
(module+ test
(test-case "build-interaction-graph"
(cond
[skip-expensive-tests?
(displayln "Skipping test case build-interaction-graph.")]
[else
(define n1 (make-boolean-network-form
(hash 'x '(not y)
'y 'x
'z '(and y z)
't '(or (and (not x) y)
(and x (not y))))))
(check-equal? (graphviz (build-interaction-graph/form n1))
"digraph G {\n\tnode0 [label=\"y\"];\n\tnode1 [label=\"z\"];\n\tnode2 [label=\"x\"];\n\tnode3 [label=\"t\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node2;\n\t\tnode1 -> node1;\n\t}\n\tsubgraph D {\n\t\tnode0 -> node3;\n\t\tnode0 -> node1;\n\t\tnode2 -> node3;\n\t}\n}\n")
(define n-multi (hash 'x '(min (+ y 1) 2)
'y '(max (- y 1) 0)
'z '(- 2 y)
't '(abs (- y 1))))
(define 123-doms (make-same-domains '(x y z t) '(0 1 2)))
(define n2 (network-form n-multi 123-doms))
(check-equal? (graphviz (build-interaction-graph/form n2))
"digraph G {\n\tnode0 [label=\"y\"];\n\tnode1 [label=\"z\"];\n\tnode2 [label=\"x\"];\n\tnode3 [label=\"t\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0;\n\t}\n\tsubgraph D {\n\t\tnode0 -> node2;\n\t\tnode0 -> node3;\n\t\tnode0 -> node1;\n\t}\n}\n")])))
;;; Given a network, builds its signed interaction graph. The graph
;;; has variables as nodes and has a directed edge from x to
;;; y labelled by the value get-interaction-sign for these variables,
;;; in that order, unless this value is #f.
(define (build-signed-interaction-graph network)
(define vars (hash-keys (network-functions network)))
(weighted-graph/directed
(for*/list ([x (in-list vars)]
[y (in-list vars)]
[sign (in-value (get-interaction-sign network x y))]
#:unless (eq? sign #f))
(list sign x y))))
;;; Like build-signed-interaction-graph, but takes a network form and
;;; converts it a to a network.
(define build-signed-interaction-graph/form
(compose build-signed-interaction-graph network-form->network))
(module+ test
(test-case "build-signed-interaction-graph"
(cond
[skip-expensive-tests?
(displayln "Skipping test case build-signed-interaction-graph.")]
[else
(define n1 (make-boolean-network-form
(hash 'x '(not y)
'y 'x
'z '(and y z)
't '(or (and (not x) y)
(and x (not y))))))
(check-equal? (graphviz (build-signed-interaction-graph/form n1))
"digraph G {\n\tnode0 [label=\"y\"];\n\tnode1 [label=\"z\"];\n\tnode2 [label=\"x\"];\n\tnode3 [label=\"t\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode1 -> node1 [label=\"1\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node2 [label=\"-1\"];\n\t\tnode0 -> node3 [label=\"0\"];\n\t\tnode0 -> node1 [label=\"1\"];\n\t\tnode2 -> node3 [label=\"0\"];\n\t\tnode2 -> node0 [label=\"1\"];\n\t}\n}\n")
(define n-multi (hash 'x '(min (+ y 1) 2)
'y '(max (- y 1) 0)
'z '(- 2 y)
't '(abs (- y 1))))
(define 123-doms (make-same-domains '(x y z t) '(0 1 2)))
(define n2 (network-form n-multi 123-doms))
(check-equal? (graphviz (build-signed-interaction-graph/form n2))
"digraph G {\n\tnode0 [label=\"y\"];\n\tnode1 [label=\"z\"];\n\tnode2 [label=\"x\"];\n\tnode3 [label=\"t\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"1\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node2 [label=\"1\"];\n\t\tnode0 -> node3 [label=\"0\"];\n\t\tnode0 -> node1 [label=\"-1\"];\n\t}\n}\n")])))
;;; ====================
;;; 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-functions 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 (forms->boolean-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)))))
;;; 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-state-graph dyn)
(dds-build-state-graph
dyn
((compose list->set
build-all-states
network-domains
dynamics-network) dyn)))
;;; Build the full annotated state graph of a Boolean network.
(define (build-full-state-graph-annotated dyn)
(dds-build-state-graph-annotated
dyn
((compose list->set
build-all-states
network-domains
dynamics-network) dyn)))
(module+ test
(test-case "Dynamics of networks"
(define n (forms->boolean-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-state-graph asyn))
(define gr-complete-bool-ann (build-full-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 #: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-functions network) cons #t)])
(values (car pair) (cdr pair))))
(define tab (tabulate-state* funcs (network-domains network) #: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]))
(module+ test
(test-case "tabulate-network"
(define bn (forms->boolean-network #hash((a . (not a)) (b . b))))
(check-equal? (tabulate-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-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.
;;;
;;; The domains of the network is a mapping assigning to each variable
;;; the set of values which can appear in its column in the table.
;;; This function does not check whether the table is complete.
(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)))))
;; Infer the domains.
(define domains (for/hash [(dom (in-list (lists-transpose ins)))
(x (in-list var-names))]
(values x (remove-duplicates dom))))
;; Construct the network.
(network (for/hash ([x (in-list var-names)]
[f (in-list funcs)])
(values x f))
domains))
(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 (network-functions n) 'x1))
(define f2 (hash-ref (network-functions 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)))))
(check-equal? (network-domains n)
#hash((x1 . (#f #t)) (x2 . (#f #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-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)
(network (for/hash ([(x x-dom) (in-hash domains)])
(values x (random-function/state domains x-dom)))
domains))
;;; 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)))))
;;; ===================
;;; TBF/TBN and SBF/SBN
;;; ===================
;;; Applies a TBF to a state.
;;;
;;; The values of the variables of the state are ordered by hash-map
;;; and fed to the TBF in order. The number of the inputs of the TBF
;;; must match the number of variables in the state.
(define (apply-tbf-to-state tbf st)
(apply-tbf tbf (list->vector (hash-map st (λ (_ val) val)))))
(module+ test
(test-case "apply-tbf-to-state"
(define st (make-state '((x1 . 0) (x2 . 1))))
(define f (tbf #(1 1) 1))
(check-equal? (apply-tbf-to-state f st) 0)))
;;; A state TBF is a TBF with named inputs. A state TBF can be
;;; applied to states in an unambiguous ways.
(struct tbf/state (weights threshold) #:transparent)
;;; Shortcuts for acessing fields of a state/tbf.
(define tbf/state-w tbf/state-weights)
(define tbf/state-θ tbf/state-threshold)
;;; Makes a state/tbf from a list of pairs of names of variables and
;;; weights, as well as a threshold.
(define (make-tbf/state pairs threshold)
(tbf/state (make-immutable-hash pairs) threshold))
(module+ test
(test-case "tbf/state"
(define f (make-tbf/state '((x1 . 1) (x2 . 1)) 1))
(check-equal? (tbf/state-w f) #hash((x1 . 1) (x2 . 1)))
(check-equal? (tbf/state-θ f) 1)))
;;; A sign Boolean function (SBF) is a TBF whose threshold is 0.
(define sbf/state? (and/c tbf/state? (λ (tbf) (zero? (tbf/state-θ tbf)))))
(module+ test
(test-case "sbf/state?"
(check-true (sbf/state? (tbf/state #hash((a . -1) (b . 1)) 0)))))
;;; Makes a state/tbf which is an SBF from a list of pairs of names of
;;; variables and weights.
(define (make-sbf/state pairs)
(make-tbf/state pairs 0))
(module+ test
(test-case "make-sbf/state"
(check-equal? (make-sbf/state '((a . -1) (b . 1)))
(make-tbf/state '((a . -1) (b . 1)) 0))))
;;; Applies a state TBF to its inputs.
;;;
;;; Applying a TBF consists in multiplying the weights by the
;;; corresponding inputs and comparing the sum of the products to the
;;; threshold.
;;;
;;; This function is similar to apply-tbf, but applies a state TBF (a
;;; TBF with explicitly named inputs) to a state whose values are 0
;;; and 1.
(define (apply-tbf/state tbf st)
(any->01 (> (foldl + 0 (hash-values
(hash-intersect (tbf/state-w tbf)
st
#:combine *)))
(tbf/state-θ tbf))))
(module+ test
(test-case "apply-tbf/state"
(define st1 (make-state '((a . 1) (b . 0) (c . 1))))
(define st2 (make-state '((a . 1) (b . 1) (c . 0))))
(define tbf (make-tbf/state '((a . 2) (b . -2)) 1))
(check-equal? (apply-tbf/state tbf st1) 1)
(check-equal? (apply-tbf/state tbf st2) 0)))
;;; Reads a list of tbf/state from a list of list of numbers.
;;;
;;; The last element of each list is taken to be the threshold of the
;;; TBFs, and the rest of the elements are taken to be the weights.
;;;
;;; If headers is #t, the names of the variables to appear as the
;;; inputs of the TBF are taken from the first list. The last element
;;; of this list is discarded.
;;;
;;; If headers is #f, the names of the variables are generated as xi,
;;; where i is the index of the variable.
(define (lists->tbfs/state lsts #:headers [headers #t])
(define-values (var-names rows)
(if headers
(values (car lsts) (cdr lsts))
(values (for/list ([i (in-range (length (car lsts)))])
(string->symbol (format "x~a" i)))
lsts)))
(for/list ([lst (in-list rows)])
(define-values (ws θ) (split-at-right lst 1))
(make-tbf/state (for/list ([x (in-list var-names)]
[w (in-list ws)])
(cons x w))
(car θ))))
(module+ test
(test-case "lists->tbfs/state"
(define tbfs '((1 2 3) (1 1 2)))
(check-equal? (lists->tbfs/state tbfs #:headers #f)
(list
(tbf/state '#hash((x0 . 1) (x1 . 2)) 3)
(tbf/state '#hash((x0 . 1) (x1 . 1)) 2)))
(check-equal? (lists->tbfs/state (cons '(a b f) tbfs))
(list
(tbf/state '#hash((a . 1) (b . 2)) 3)
(tbf/state '#hash((a . 1) (b . 1)) 2)))))
;;; Like lists->tbfs/state, but does not expect thresholds in the
;;; input.
;;;
;;; Every lists in the list contains the weights of the SBF. If
;;; headers is #t, the names of the variables to appear as the inputs
;;; of the TBF are taken from the first list.
;;;
;;; If headers is #f, the names of the variables are generated as xi,
;;; where i is the index of the variable.
(define (lists->sbfs/state lsts #:headers [headers #t])
(define rows (if headers (cdr lsts) lsts))
(define rows-θ (for/list ([lst (in-list rows)]) (append lst '(0))))
(lists->tbfs/state (if headers (cons (car lsts) rows-θ) rows-θ)
#:headers headers))
(module+ test
(test-case "lists->sbfs/state"
(define tbfs '((1 2) (1 -1)))
(check-equal? (lists->sbfs/state tbfs #:headers #f)
(list
(tbf/state '#hash((x0 . 1) (x1 . 2)) 0)
(tbf/state '#hash((x0 . 1) (x1 . -1)) 0)))
(check-equal? (lists->sbfs/state (cons '(a b) tbfs) #:headers #t)
(list
(tbf/state '#hash((a . 1) (b . 2)) 0)
(tbf/state '#hash((a . 1) (b . -1)) 0)))))
;;; Reads a list of tbf/state from an Org-mode string containing a
;;; sexp, containing a list of lists of numbers. As in
;;; lists->tbfs/state, the last element of each list is taken to be
;;; the threshold of the TBFs, and the rest of the elements are taken
;;; to be the weights.
;;;
;;; If headers is #t, the names of the variables to appear as the
;;; inputs of the TBF are taken from the first list. The last element
;;; of this list is discarded.
;;;
;;; If headers is #f, the names of the variables are generated as xi,
;;; where i is the index of the variable.
(define (read-org-tbfs/state str #:headers [headers #t])
(lists->tbfs/state (read-org-sexp str) #:headers headers))
(module+ test
(test-case "read-org-tbfs/state"
(check-equal? (read-org-tbfs/state "((a b f) (1 2 3) (1 1 2))")
(list
(tbf/state '#hash((a . 1) (b . 2)) 3)
(tbf/state '#hash((a . 1) (b . 1)) 2)))
(check-equal? (read-org-tbfs/state "((1 2 3) (1 1 2))" #:headers #f)
(list
(tbf/state '#hash((x0 . 1) (x1 . 2)) 3)
(tbf/state '#hash((x0 . 1) (x1 . 1)) 2)))))
;;; Like read-org-tbfs/state, but reads a list of SBFs. Therefore,
;;; the lists of numbers in the sexp are taken to be the weights of
;;; the SBFs.
;;;
;;; If headers is #t, the names of the variables to appear as the
;;; inputs of the TBF are taken from the first list. If headers is
;;; #f, the names of the variables are generated as xi, where i is the
;;; index of the variable.
(define (read-org-sbfs/state str #:headers [headers #t])
(lists->sbfs/state (read-org-sexp str) #:headers headers))
(module+ test
(test-case "read-org-sbfs/state"
(check-equal? (read-org-sbfs/state "((a b) (-1 2) (1 1))")
(list
(tbf/state '#hash((a . -1) (b . 2)) 0)
(tbf/state '#hash((a . 1) (b . 1)) 0)))
(check-equal? (read-org-sbfs/state "((-1 2) (1 1))" #:headers #f)
(list
(tbf/state '#hash((x0 . -1) (x1 . 2)) 0)
(tbf/state '#hash((x0 . 1) (x1 . 1)) 0)))))
;;; Given a list of tbf/state, produces a sexp that Org-mode can
;;; interpret as a table.
;;;
;;; All tbf/state in the list must have the same inputs. The function
;;; does not check this property.
;;;
;;; If #:headers is #f, does not print the names of the inputs of the
;;; TBFs. If #:headers is #t, the output starts by a list giving the
;;; names of the variables, as well as the symbol 'θ to represent the
;;; column giving the thresholds of the TBF.
(define (print-org-tbfs/state tbfs #:headers [headers #t])
(define table (for/list ([tbf (in-list tbfs)])
(append (hash-map (tbf/state-w tbf) (λ (_ w) w) #t)
(list (tbf/state-θ tbf)))))
(if headers
(cons (append (hash-map (tbf/state-w (car tbfs)) (λ (x _) x) #t) '(θ))
table)
table))
(module+ test
(test-case "print-org-tbfs/state"
(define tbfs (list (make-tbf/state '((a . 1) (b . 2)) 3)
(make-tbf/state '((a . -2) (b . 1)) 1)))
(check-equal? (print-org-tbfs/state tbfs)
'((a b θ) (1 2 3) (-2 1 1)))))
;;; Like print-org-tbfs/state, but expects a list of SBFs. The
;;; thresholds are therefore not included in the output.
;;;
;;; All sbf/state in the list must have the same inputs. The function
;;; does not check this property.
;;;
;;; If #:headers is #f, does not print the names of the inputs of the
;;; TBFs. If #:headers is #t, the output starts by a list giving the
;;; names of the variables.
(define (print-org-sbfs/state sbfs #:headers [headers #t])
(define table (for/list ([sbf (in-list sbfs)])
(hash-map (tbf/state-w sbf) (λ (_ w) w) #t)))
(if headers
(cons (hash-map (tbf/state-w (car sbfs)) (λ (x _) x) #t)
table)
table))
(module+ test
(define sbfs (list (make-sbf/state '((a . 1) (b . 2)))
(make-sbf/state '((a . -2) (b . 1)))))
(check-equal? (print-org-sbfs/state sbfs)
'((a b) (1 2) (-2 1)))
(check-equal? (print-org-sbfs/state sbfs #:headers #f)
'((1 2) (-2 1))))
;;; Tabulates a list of tbf/state.
;;;
;;; As in the case of tbf-tabulate*, the result is a list of lists
;;; giving the truth tables of the given TBFs. The first elements of
;;; each row give the values of the inputs, while the last elements
;;; give the values of each function corresponding to the input.
;;;
;;; All the TBFs must have exactly the same inputs. This function
;;; does not check this property.
;;;
;;; If #:headers is #t, the output starts by a list giving the names
;;; of the variables, and then the symbols 'fi, where i is the number
;;; of the TBF in the list.
(define (tbf/state-tabulate* tbfs #:headers [headers #t])
(define vars (hash-map (tbf/state-w (car tbfs)) (λ (x _) x) #t))
(tabulate-state* (map (curry apply-tbf/state) tbfs)
(make-same-domains vars '(0 1))
#:headers headers))
(module+ test
(test-case "tbf/state-tabulate*"
(define tbfs (list (make-tbf/state '((a . 1) (b . 2)) 1)
(make-tbf/state '((a . -2) (b . 3)) 1)))
(check-equal? (tbf/state-tabulate* tbfs)
'((a b f1 f2)
(0 0 0 0)
(0 1 1 1)
(1 0 0 0)
(1 1 1 0)))))
;;; Like tbf/state-tabulate*, but only tabulates a single TBF.
(define (tbf/state-tabulate tbf #:headers [headers #t])
(tbf/state-tabulate* (list tbf) #:headers headers))
(module+ test
(test-case "tbf/state-tabulate"
(define tbf (make-tbf/state '((a . -2) (b . 3)) 1))
(check-equal? (tbf/state-tabulate tbf)
'((a b f1)
(0 0 0)
(0 1 1)
(1 0 0)
(1 1 0)))))
;;; Given a truth table of a Boolean function, groups the lines by the
;;; "number of activated inputs"—the number of inputs which are 1 in
;;; the input vector.
;;;
;;; The truth table must not include the header line.
(define (group-truth-table-by-nai tt)
(define sum (((curry foldl) +) 0))
(group-by (λ (row) (drop-right row 1))
tt
(λ (in1 in2) (= (sum in1) (sum in2)))))
(module+ test
(test-case "group-truth-table-by-nai"
(check-equal? (group-truth-table-by-nai '((0 0 0 1)
(0 0 1 1)
(0 1 0 0)
(0 1 1 1)
(1 0 0 0)
(1 0 1 0)
(1 1 0 1)
(1 1 1 0)))
'(((0 0 0 1))
((0 0 1 1) (0 1 0 0) (1 0 0 0))
((0 1 1 1) (1 0 1 0) (1 1 0 1))
((1 1 1 0))))))
;;; A TBN is a network form mapping variables to tbf/state.
;;;
;;; The tbf/state must only reference variables appearing in the
;;; network. This contract does not check this condition.
(define tbn? (hash/c variable? tbf/state?))
;;; Builds a TBN from a list of pairs (variable, tbf/state).
(define make-tbn make-immutable-hash)
(module+ test
(test-case "make-tbn"
(define tbf-not (make-tbf/state '((a . -1)) -1))
(define tbf-id (make-sbf/state '((a . 1))))
(check-equal? (make-tbn `((a . ,tbf-not) (b . ,tbf-id)))
(hash 'a (tbf/state '#hash((a . -1)) -1)
'b (tbf/state '#hash((a . 1)) 0)))))
;;; A SBN is a network form mapping variables to sbf/state.
;;;
;;; The tbf/state must only reference variables appearing in the
;;; network. This contract does not check this condition.
(define sbn? (hash/c variable? sbf/state?))
;;; Builds an SBN from a list of pairs (variable, sbf/state).
(define make-sbn make-immutable-hash)
(module+ test
(test-case "make-sbn"
(define sbf1 (make-sbf/state '((a . -1))))
(define sbf2 (make-sbf/state '((a . 1))))
(check-equal? (make-sbn `((a . ,sbf1) (b . ,sbf2)))
(hash 'a (tbf/state '#hash((a . -1)) 0)
'b (tbf/state '#hash((a . 1)) 0)))))
;;; Constructs a network from a network form defining a TBN.
(define (tbn->network tbn)
(make-01-network (for/hash ([(var tbf) (in-hash tbn)])
(values var ((curry apply-tbf/state) tbf)))))
(module+ test
(test-case "tbn->network"
(define tbn (make-tbn `((a . ,(make-sbf/state '((b . 1))))
(b . ,(make-tbf/state '((a . -1)) -1)))))
(define n (tbn->network tbn))
(define s1 (make-state '((a . 0) (b . 0))))
(check-equal? (update n s1 '(a b))
(make-state '((a . 0) (b . 1))))
(check-equal? (network-domains n) #hash((a . (0 1)) (b . (0 1))))
(define sbn (make-sbn `((a . ,(make-sbf/state '((b . -1))))
(b . ,(make-sbf/state '((a . 1)))))))
(define sn (tbn->network sbn))
(define s2 (make-state '((a . 1) (b . 1))))
(check-equal? (update sn s2 '(a b))
(make-state '((a . 0) (b . 1))))
(check-equal? (network-domains sn) #hash((a . (0 1)) (b . (0 1))))))
;;; A helper function for read-org-tbn and read-org-sbn. It reads a
;;; TBN from an Org-mode sexp containing a list of lists of numbers.
;;; As in lists->tbfs/state, the last element of each list is taken to
;;; be the threshold of the TBFs, and the rest of the elements are
;;; taken to be the weights.
;;;
;;; As in read-org-tbfs/state, if headers is #t, the names of the
;;; variables to appear as the inputs of the TBF are taken from the
;;; first list. The last element of this list is discarded.
;;; If headers is #f, the names of the variables are generated as xi,
;;; where i is the index of the variable.
;;;
;;; If func-names is #t, the first element in every row except the
;;; first one, are taken to be the name of the variable to which the
;;; TBF should be associated. If func-names is #f, the functions are
;;; assigned to variables in alphabetical order.
;;;
;;; func-names cannot be #t if headers is #f. The function does not
;;; check this condition.
(define (parse-org-tbn sexp
#:headers [headers #t]
#:func-names [func-names #t])
(cond
[(eq? func-names #t)
(define-values (vars rows) (multi-split-at sexp 1))
(define tbfs (lists->tbfs/state rows #:headers headers))
(for/hash ([tbf (in-list tbfs)] [var (in-list (cdr vars))])
(values (car var) tbf))]
[else
(define tbfs (lists->tbfs/state sexp #:headers headers))
(define vars (hash-map (tbf/state-w (car tbfs)) (λ (x _) x) #t))
(for/hash ([tbf (in-list tbfs)] [var (in-list vars)])
(values var tbf))]))
;;; Reads a TBN from an Org-mode string containing a sexp, containing
;;; a list of lists of numbers. As in lists->tbfs/state, the last
;;; element of each list is taken to be the threshold of the TBFs, and
;;; the rest of the elements are taken to be the weights.
;;;
;;; As in read-org-tbfs/state, if headers is #t, the names of the
;;; variables to appear as the inputs of the TBF are taken from the
;;; first list. The last element of this list is discarded.
;;; If headers is #f, the names of the variables are generated as xi,
;;; where i is the index of the variable.
;;;
;;; If func-names is #t, the first element in every row except the
;;; first one, are taken to be the name of the variable to which the
;;; TBF should be associated. If func-names is #f, the functions are
;;; assigned to variables in alphabetical order.
;;;
;;; func-names cannot be #t if headers is #f. The function does not
;;; check this condition.
(define (read-org-tbn str
#:headers [headers #t]
#:func-names [func-names #t])
(parse-org-tbn (read-org-sexp str)
#:headers headers
#:func-names func-names))
(module+ test
(test-case "read-org-tbn, parse-org-tbn"
(check-equal? (read-org-tbn "((\"-\" \"x\" \"y\" \"θ\") (\"y\" -1 0 -1) (\"x\" 0 -1 -1))")
(hash
'x
(tbf/state '#hash((x . 0) (y . -1)) -1)
'y
(tbf/state '#hash((x . -1) (y . 0)) -1)))
(check-equal? (read-org-tbn "((\"x\" \"y\" \"θ\") (-1 0 -1) (0 -1 -1))" #:func-names #f)
(hash
'x
(tbf/state '#hash((x . -1) (y . 0)) -1)
'y
(tbf/state '#hash((x . 0) (y . -1)) -1)))
(check-equal? (read-org-tbn "((-1 0 -1) (0 -1 -1))" #:headers #f #:func-names #f)
(hash
'x0
(tbf/state '#hash((x0 . -1) (x1 . 0)) -1)
'x1
(tbf/state '#hash((x0 . 0) (x1 . -1)) -1)))))
;;; Like read-org-tbn, but reads an SBN from an Org-mode string
;;; containing a sexp, containing a list of lists of numbers.
;;;
;;; As in read-org-sbfs/state, if headers is #t, the names of the
;;; variables to appear as the inputs of the SBF are taken from the
;;; first list. The last element of this list is discarded.
;;; If headers is #f, the names of the variables are generated as xi,
;;; where i is the index of the variable.
;;;
;;; If func-names is #t, the first element in every row except the
;;; first one, are taken to be the name of the variable to which the
;;; TBF should be associated. If func-names is #f, the functions are
;;; assigned to variables in alphabetical order.
;;;
;;; func-names cannot be #t if headers is #f. The function does not
;;; check this condition.
(define (read-org-sbn str
#:headers [headers #t]
#:func-names [func-names #t])
(define sexp (read-org-sexp str))
;; Inject the 0 thresholds into the rows of the sexp we have just read.
(define (inject-0 rows) (for/list ([row (in-list rows)]) (append row '(0))))
(define sexp-ready (if headers
(cons (car sexp) (inject-0 (cdr sexp)))
(inject-0 sexp)))
(parse-org-tbn sexp-ready #:headers headers #:func-names func-names))
(module+ test
(test-case "read-org-sbn, parse-org-tbn"
(check-equal? (read-org-sbn "((\"-\" \"x\" \"y\") (\"y\" -1 0) (\"x\" 0 -1))")
(hash
'x
(tbf/state '#hash((x . 0) (y . -1)) 0)
'y
(tbf/state '#hash((x . -1) (y . 0)) 0)))
(check-equal? (read-org-sbn "((\"x\" \"y\") (-1 0) (0 -1))" #:func-names #f)
(hash
'x
(tbf/state '#hash((x . -1) (y . 0)) 0)
'y
(tbf/state '#hash((x . 0) (y . -1)) 0)))
(check-equal? (read-org-sbn "((-1 0) (0 -1))" #:headers #f #:func-names #f)
(hash
'x0
(tbf/state '#hash((x0 . -1) (x1 . 0)) 0)
'x1
(tbf/state '#hash((x0 . 0) (x1 . -1)) 0)))))
;;; A shortcut for building the state graphs of TBN.
(define build-tbn-state-graph
(compose pretty-print-state-graph
build-full-state-graph
make-syn-dynamics
tbn->network))
;;; Checks whether a TBN is normalized: whether all of the functions
;;; have the same inputs, and whether these inputs are exactly the
;;; variables of the TBN.
(define (normalized-tbn? tbn)
(define tbn-vars (hash-keys tbn))
(for/and ([tbf (in-list (hash-values tbn))])
(set=? tbn-vars (hash-keys (tbf/state-w tbf)))))
(module+ test
(test-case "normalized-tbn?"
(check-false (normalized-tbn?
(make-tbn `((a . ,(make-sbf/state '((b . 1))))
(b . ,(make-tbf/state '((a . -1)) -1))))))
(check-true (normalized-tbn?
(make-tbn `((a . ,(make-sbf/state '((a . 1) (b . -1))))
(b . ,(make-tbf/state '((a . -1) (b . 1)) -1))))))))
;;; Normalizes a TBN.
;;;
;;; For every TBF, removes the inputs that are not in the variables of
;;; the TBN, and adds missing inputs with 0 weight.
(define (normalize-tbn tbn)
(define vars-0 (for/hash ([(x _) (in-hash tbn)]) (values x 0)))
(define (normalize-tbf tbf)
;; Only keep the inputs which are also the variables of tbn.
(define w-pruned (hash-intersect tbn (tbf/state-w tbf)
#:combine (λ (_ w) w)))
;; Put in the missing inputs with weight 0.
(define w-complete (hash-union vars-0 w-pruned #:combine (λ (_ w) w)))
(tbf/state w-complete (tbf/state-θ tbf)))
(for/hash ([(x tbf) (in-hash tbn)]) (values x (normalize-tbf tbf))))
(module+ test
(test-case "normalize-tbn"
(check-equal? (normalize-tbn
(hash 'a (make-sbf/state '((b . 1) (c . 3)))
'b (make-tbf/state '((a . -1)) -1)))
(hash
'a
(tbf/state '#hash((a . 0) (b . 1)) 0)
'b
(tbf/state '#hash((a . -1) (b . 0)) -1)))))
;;; Compacts (and denormalizes) a TBF by removing all inputs which
;;; are 0.
(define (compact-tbf tbf)
(tbf/state
(for/hash ([(k v) (in-hash (tbf/state-w tbf))]
#:unless (zero? v))
(values k v))
(tbf/state-θ tbf)))
(module+ test
(test-case "compact-tbf"
(check-equal? (compact-tbf (tbf/state (hash 'a 0 'b 1 'c 2 'd 0) 2))
(tbf/state '#hash((b . 1) (c . 2)) 2))))
;;; Compacts a TBN by removing all inputs which are 0 or which are not
;;; variables of the network.
(define (compact-tbn tbn)
(define (remove-0-non-var tbf)
(tbf/state
(for/hash ([(x w) (in-hash (tbf/state-w tbf))]
#:when (hash-has-key? tbn x)
#:unless (zero? w))
(values x w))
(tbf/state-θ tbf)))
(for/hash ([(x tbf) (in-hash tbn)])
(values x (remove-0-non-var tbf))))
(module+ test
(test-case "compact-tbn"
(check-equal?
(compact-tbn (hash 'a (tbf/state (hash 'a 0 'b 1 'c 3 'd 0) 0)
'b (tbf/state (hash 'a -1 'b 1) -1)))
(hash
'a
(tbf/state '#hash((b . 1)) 0)
'b
(tbf/state '#hash((a . -1) (b . 1)) -1)))))
;;; Given TBN, produces a sexp containing the description of the
;;; functions of the TBN that Org-mode can interpret as a table.
;;;
;;; Like print-org-tbfs/state, if #:headers is #f, does not print the
;;; names of the inputs of the TBFs. If #:headers is #t, the output
;;; starts by a list giving the names of the variables, as well as the
;;; symbol 'θ to represent the column giving the thresholds of the
;;; TBF.
;;;
;;; If #:func-names is #t, the first column of the table gives the
;;; variable which the corresponding TBF updates.
;;;
;;; If both #:func-names and #:headers are #t, the first cell of the
;;; first column contains the symbol '-.
(define (print-org-tbn tbn
#:headers [headers #t]
#:func-names [func-names #t])
(define ntbn (normalize-tbn tbn))
(define vars-tbfs (hash-map ntbn (λ (x tbf) (cons x tbf)) #t))
(define tbfs (map cdr vars-tbfs))
(define tbfs-table (print-org-tbfs/state tbfs #:headers headers))
(cond
[(eq? func-names #t)
(define vars (map car vars-tbfs))
(define col-1 (if headers (cons '- vars) vars))
(for/list ([var (in-list col-1)] [row (in-list tbfs-table)])
(cons var row))]
[else
tbfs-table]))
(module+ test
(test-case "print-org-tbn"
(define tbn (make-tbn `((a . ,(make-sbf/state '((b . 1))))
(b . ,(make-tbf/state '((a . -1)) -1)))))
(check-equal? (print-org-tbn tbn)
'((- a b θ) (a 0 1 0) (b -1 0 -1)))))
;;; Given an SBN, produces a sexp containing the description of the
;;; functions of the SBN that Org-mode can interpret as a table.
;;; This function is therefore very similar to print-org-tbn.
;;;
;;; Like print-org-tbfs/state, if #:headers is #f, does not print the
;;; names of the inputs of the TBFs. If #:headers is #t, the output
;;; starts by a list giving the names of the variables.
;;;
;;; If #:func-names is #t, the first column of the table gives the
;;; variable which the corresponding TBF updates.
;;;
;;; If both #:func-names and #:headers are #t, the first cell of the
;;; first column contains the symbol '-.
(define (print-org-sbn sbn
#:headers [headers #t]
#:func-names [func-names #t])
(define tab (print-org-tbn sbn #:headers headers #:func-names func-names))
(define-values (tab-no-θ _) (multi-split-at
tab
(- (length (car tab)) 1)))
tab-no-θ)
(module+ test
(test-case "print-org-sbn"
(define sbn (hash
'a
(tbf/state (hash 'b 2) 0)
'b
(tbf/state (hash 'a 2) 0)))
(check-equal? (print-org-sbn sbn)
'((- a b) (a 0 2) (b 2 0)))))
;;; Given a TBN, constructs its interaction graph. The nodes of this
;;; graph are labeled with pairs (variable name . threshold), while
;;; the edges are labelled with the weights.
;;;
;;; If #:zero-edges is #t, the edges with zero weights will appear in
;;; the interaction graph.
(define (tbn-interaction-graph tbn
#:zero-edges [zero-edges #t])
(define ntbn (normalize-tbn tbn))
(define ig (weighted-graph/directed
(if zero-edges
(for*/list ([(tar tbf) (in-hash ntbn)]
[(src w) (in-hash (tbf/state-w tbf))])
(list w src tar))
(for*/list ([(tar tbf) (in-hash ntbn)]
[(src w) (in-hash (tbf/state-w tbf))]
#:unless (zero? w))
(list w src tar)))))
(update-graph ig #:v-func (λ (x) (cons x (tbf/state-θ (hash-ref ntbn x))))))
(module+ test
(test-case "tbn-interaction-graph"
(define tbn (make-tbn `((a . ,(make-sbf/state '((b . 1))))
(b . ,(make-tbf/state '((a . -1)) -1)))))
(check-equal? (graphviz (tbn-interaction-graph tbn))
"digraph G {\n\tnode0 [label=\"'(b . -1)\\n\"];\n\tnode1 [label=\"'(a . 0)\\n\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"0\"];\n\t\tnode1 -> node1 [label=\"0\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"1\"];\n\t\tnode1 -> node0 [label=\"-1\"];\n\t}\n}\n")
(check-equal? (graphviz (tbn-interaction-graph tbn #:zero-edges #f))
"digraph G {\n\tnode0 [label=\"'(b . -1)\\n\"];\n\tnode1 [label=\"'(a . 0)\\n\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"1\"];\n\t\tnode1 -> node0 [label=\"-1\"];\n\t}\n}\n")))
;;; Pretty prints the node labels of the interaction graph of a TBN.
(define (pretty-print-tbn-interaction-graph ig)
(update-graph ig #:v-func (match-lambda
[(cons var weight) (~a var ":" weight)])))
(module+ test
(test-case "pretty-print-tbn-interaction-graph"
(define tbn (make-tbn `((a . ,(make-sbf/state '((b . 1))))
(b . ,(make-tbf/state '((a . -1)) -1)))))
(check-equal? (graphviz (pretty-print-tbn-interaction-graph (tbn-interaction-graph tbn)))
"digraph G {\n\tnode0 [label=\"b:-1\"];\n\tnode1 [label=\"a:0\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node0 [label=\"0\"];\n\t\tnode1 -> node1 [label=\"0\"];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node1 [label=\"1\"];\n\t\tnode1 -> node0 [label=\"-1\"];\n\t}\n}\n")))
;;; Given an SBN, constructs its interaction graph. As in
;;; tbn-interaction-graph, the nodes of this graph are labeled with
;;; the variable names, while the edges are labelled with the weights.
;;;
;;; If #:zero-edges is #t, the edges with zero weights will appear in
;;; the interaction graph.
(define (sbn-interaction-graph sbn
#:zero-edges [zero-edges #t])
(update-graph (tbn-interaction-graph sbn #:zero-edges zero-edges)
#:v-func (match-lambda
[(cons var _) var])))
(module+ test
(test-case "sbn-interaction-graph"
(define sbn (hash
'a
(tbf/state (hash 'b 2) 0)
'b
(tbf/state (hash 'a 2) 0)))
(check-equal? (graphviz (sbn-interaction-graph sbn))
"digraph G {\n\tnode0 [label=\"b\"];\n\tnode1 [label=\"a\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node1 [label=\"2\"];\n\t\tnode0 -> node0 [label=\"0\"];\n\t\tnode1 -> node1 [label=\"0\"];\n\t}\n\tsubgraph D {\n\t}\n}\n")))