2020-02-20 00:56:30 +01:00
|
|
|
|
#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.
|
|
|
|
|
|
2020-10-24 23:51:56 +02:00
|
|
|
|
(require "utils.rkt" "generic.rkt" "functions.rkt"
|
|
|
|
|
graph racket/random racket/hash)
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
|
|
|
|
(provide
|
2020-02-23 11:10:18 +01:00
|
|
|
|
;; Structures
|
|
|
|
|
(struct-out dynamics)
|
2020-07-23 00:11:14 +02:00
|
|
|
|
(contract-out [struct tbf/state ([weights (hash/c variable? number?)]
|
2020-07-23 00:02:35 +02:00
|
|
|
|
[threshold number?])])
|
2020-02-20 14:13:48 +01:00
|
|
|
|
;; Functions
|
2020-02-23 12:10:27 +01:00
|
|
|
|
(contract-out [update (-> network? state? (set/c variable? #:kind 'dont-care) state?)]
|
2020-02-20 00:56:30 +01:00
|
|
|
|
[make-state (-> (listof (cons/c symbol? any/c)) state?)]
|
2020-02-26 15:51:25 +01:00
|
|
|
|
[make-state-booleanize (-> (listof (cons/c symbol? (or/c 0 1))) state?)]
|
2020-02-26 20:47:38 +01:00
|
|
|
|
[booleanize-state (-> state? state?)]
|
2020-02-20 14:13:48 +01:00
|
|
|
|
[make-network-from-functions (-> (listof (cons/c symbol? update-function/c)) network?)]
|
|
|
|
|
[update-function-form->update-function (-> update-function-form? update-function/c)]
|
2020-02-20 00:56:30 +01:00
|
|
|
|
[network-form->network (-> network-form? network?)]
|
|
|
|
|
[make-network-from-forms (-> (listof (cons/c symbol? update-function-form?))
|
2020-02-20 15:17:32 +01:00
|
|
|
|
network?)]
|
2020-02-20 15:56:48 +01:00
|
|
|
|
[list-interactions (-> network-form? variable? (listof variable?))]
|
2020-02-22 22:27:40 +01:00
|
|
|
|
[build-interaction-graph (-> network-form? graph?)]
|
2020-02-23 09:12:01 +01:00
|
|
|
|
[build-all-states (-> domain-mapping/c (listof state?))]
|
2020-02-23 11:51:59 +01:00
|
|
|
|
[make-same-domains (-> (listof variable?) generic-set? domain-mapping/c)]
|
2020-02-23 00:15:18 +01:00
|
|
|
|
[make-boolean-domains (-> (listof variable?) (hash/c variable? (list/c #f #t)))]
|
2020-10-18 22:52:05 +02:00
|
|
|
|
[make-01-domains (-> (listof variable?) (hash/c variable? (list/c 0 1)))]
|
2020-02-23 20:13:37 +01:00
|
|
|
|
[build-all-boolean-states (-> (listof variable?) (listof state?))]
|
2020-10-18 22:52:45 +02:00
|
|
|
|
[build-all-01-states (-> (listof variable?) (listof state?))]
|
2020-03-22 20:43:14 +01:00
|
|
|
|
[get-interaction-sign (-> network? domain-mapping/c variable? variable? (or/c '+ '- '0))]
|
2020-03-22 20:45:11 +01:00
|
|
|
|
[build-signed-interaction-graph/form (-> network-form? domain-mapping/c graph?)]
|
|
|
|
|
[build-boolean-signed-interaction-graph/form (-> network-form? graph?)]
|
2020-03-22 21:00:12 +01:00
|
|
|
|
[build-signed-interaction-graph (-> network? domain-mapping/c graph?)]
|
|
|
|
|
[build-boolean-signed-interaction-graph (-> network? graph?)]
|
2020-02-23 11:25:19 +01:00
|
|
|
|
[make-asyn (-> (listof variable?) mode?)]
|
2020-02-23 11:42:01 +01:00
|
|
|
|
[make-syn (-> (listof variable?) mode?)]
|
|
|
|
|
[make-dynamics-from-func (-> network? (-> (listof variable?) mode?) dynamics?)]
|
|
|
|
|
[make-asyn-dynamics (-> network? dynamics?)]
|
2020-02-23 12:19:47 +01:00
|
|
|
|
[make-syn-dynamics (-> network? dynamics?)]
|
2020-03-04 18:54:36 +01:00
|
|
|
|
[read-org-network-make-asyn (-> string? dynamics?)]
|
|
|
|
|
[read-org-network-make-syn (-> string? dynamics?)]
|
2020-02-23 13:28:51 +01:00
|
|
|
|
[dds-step-one (-> dynamics? state? (set/c state?))]
|
2020-02-23 14:11:55 +01:00
|
|
|
|
[dds-step-one-annotated (-> dynamics? state? (set/c (cons/c modality? state?)))]
|
2020-02-23 18:51:57 +01:00
|
|
|
|
[dds-step (-> dynamics? (set/c state? #:kind 'dont-care) (set/c state?))]
|
|
|
|
|
[dds-build-state-graph (-> dynamics? (set/c state? #:kind 'dont-care) graph?)]
|
2020-02-23 19:24:53 +01:00
|
|
|
|
[dds-build-n-step-state-graph (-> dynamics? (set/c state? #:kind 'dont-care) number? graph?)]
|
2020-02-28 21:46:25 +01:00
|
|
|
|
[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?)]
|
2020-02-23 19:44:55 +01:00
|
|
|
|
[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?)]
|
2020-05-28 00:49:29 +02:00
|
|
|
|
[ppsg (-> graph? graph?)]
|
2020-02-23 20:13:37 +01:00
|
|
|
|
[pretty-print-boolean-state-graph (-> graph? graph?)]
|
2020-05-28 00:49:29 +02:00
|
|
|
|
[ppsgb (-> graph? graph?)]
|
2020-02-28 21:56:42 +01:00
|
|
|
|
[build-full-boolean-state-graph (-> dynamics? graph?)]
|
2020-03-15 16:12:35 +01:00
|
|
|
|
[build-full-boolean-state-graph-annotated (-> dynamics? graph?)]
|
2020-10-18 22:57:08 +02:00
|
|
|
|
[build-full-01-state-graph (-> dynamics? graph?)]
|
|
|
|
|
[build-full-01-state-graph-annotated (-> dynamics? graph?)]
|
2020-03-22 14:34:40 +01:00
|
|
|
|
[tabulate-state (->* (procedure? domain-mapping/c) (#:headers boolean?)
|
|
|
|
|
(listof (listof any/c)))]
|
2020-06-02 21:53:53 +02:00
|
|
|
|
[tabulate-state* (->* ((non-empty-listof procedure?) domain-mapping/c) (#:headers boolean?)
|
|
|
|
|
(listof (listof any/c)))]
|
2020-03-22 14:34:40 +01:00
|
|
|
|
[tabulate-state/boolean (->* (procedure? (listof variable?)) (#:headers boolean?)
|
|
|
|
|
(listof (listof any/c)))]
|
2020-06-02 21:53:53 +02:00
|
|
|
|
[tabulate-state*/boolean (->* ((non-empty-listof procedure?) (listof variable?)) (#:headers boolean?)
|
|
|
|
|
(listof (listof any/c)))]
|
2020-03-22 19:22:54 +01:00
|
|
|
|
[tabulate-network (->* (network? domain-mapping/c) (#:headers boolean?)
|
|
|
|
|
(listof (listof any/c)))]
|
|
|
|
|
[tabulate-boolean-network (->* (network?) (#:headers boolean?)
|
|
|
|
|
(listof (listof any/c)))]
|
2020-03-24 00:18:39 +01:00
|
|
|
|
[table->network (->* ((listof (*list/c any/c any/c))) (#:headers boolean?) network?)]
|
2020-03-22 14:35:26 +01:00
|
|
|
|
[random-function/state (domain-mapping/c generic-set? . -> . procedure?)]
|
2020-03-22 19:28:44 +01:00
|
|
|
|
[random-boolean-function/state ((listof variable?) . -> . procedure?)]
|
|
|
|
|
[random-network (domain-mapping/c . -> . network?)]
|
|
|
|
|
[random-boolean-network ((listof variable?) . -> . network?)]
|
2020-07-22 23:46:58 +02:00
|
|
|
|
[random-boolean-network/vars (number? . -> . network?)]
|
2020-08-01 23:38:24 +02:00
|
|
|
|
[apply-tbf-to-state (-> tbf? state? (or/c 0 1))]
|
2020-07-23 00:11:14 +02:00
|
|
|
|
[tbf/state-w (-> tbf/state? (hash/c variable? number?))]
|
|
|
|
|
[tbf/state-θ (-> tbf/state? number?)]
|
2020-07-23 00:19:25 +02:00
|
|
|
|
[make-tbf/state (-> (listof (cons/c variable? number?)) number? tbf/state?)]
|
2020-10-12 22:53:34 +02:00
|
|
|
|
[make-sbf/state (-> (listof (cons/c variable? number?)) sbf/state?)]
|
2020-10-10 23:23:43 +02:00
|
|
|
|
[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?)
|
2020-10-10 23:51:52 +02:00
|
|
|
|
(listof tbf/state?))]
|
2020-10-12 23:20:48 +02:00
|
|
|
|
[lists->sbfs/state (->* ((listof (listof (or/c number? symbol?))))
|
|
|
|
|
(#:headers boolean?)
|
|
|
|
|
(listof sbf/state?))]
|
2020-10-12 00:24:10 +02:00
|
|
|
|
[read-org-tbfs/state (->* (string?) (#:headers boolean?) (listof tbf/state?))]
|
2020-10-13 23:25:21 +02:00
|
|
|
|
[read-org-sbfs/state (->* (string?) (#:headers boolean?) (listof sbf/state?))]
|
2020-10-12 00:24:10 +02:00
|
|
|
|
[print-org-tbfs/state (->* ((non-empty-listof tbf/state?)) (#:headers boolean?)
|
2020-10-12 00:47:54 +02:00
|
|
|
|
(listof (listof (or/c number? symbol?))))]
|
2020-10-14 00:02:58 +02:00
|
|
|
|
[print-org-sbfs/state (->* ((non-empty-listof tbf/state?)) (#:headers boolean?)
|
|
|
|
|
(listof (listof (or/c number? symbol?))))]
|
2020-10-12 00:47:54 +02:00
|
|
|
|
[tbf/state-tabulate* (->* ((non-empty-listof tbf/state?)) (#:headers boolean?)
|
2020-10-12 00:53:56 +02:00
|
|
|
|
(listof (listof (or/c symbol? number?))))]
|
|
|
|
|
[tbf/state-tabulate (->* (tbf/state?) (#:headers boolean?)
|
2020-10-15 00:33:18 +02:00
|
|
|
|
(listof (listof (or/c symbol? number?))))]
|
2020-10-16 00:55:26 +02:00
|
|
|
|
[make-tbn (-> (listof (cons/c variable? tbf/state?)) tbn?)]
|
2020-10-17 00:45:40 +02:00
|
|
|
|
[tbn->network (-> tbn? network?)]
|
2020-10-17 23:51:51 +02:00
|
|
|
|
[make-sbn (-> (listof (cons/c variable? tbf/state?)) sbn?)]
|
2020-10-22 00:52:06 +02:00
|
|
|
|
[parse-org-tbn (->* ((listof any/c))
|
|
|
|
|
(#:headers boolean? #:func-names boolean?)
|
|
|
|
|
tbn?)]
|
2020-10-17 23:51:51 +02:00
|
|
|
|
[read-org-tbn (->* (string?)
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(#:headers boolean? #:func-names boolean?)
|
|
|
|
|
tbn?)]
|
|
|
|
|
[read-org-sbn (->* (string?)
|
2020-10-17 23:51:51 +02:00
|
|
|
|
(#:headers boolean? #:func-names boolean?)
|
2020-10-23 00:17:36 +02:00
|
|
|
|
tbn?)]
|
2020-10-24 23:15:13 +02:00
|
|
|
|
[build-tbn-state-graph (-> tbn? graph?)]
|
2020-10-24 23:51:56 +02:00
|
|
|
|
[normalized-tbn? (-> tbn? boolean?)]
|
2020-10-31 00:48:00 +01:00
|
|
|
|
[normalize-tbn (-> tbn? normalized-tbn?)]
|
2020-11-02 00:08:49 +01:00
|
|
|
|
[compact-tbf (-> tbf/state? tbf/state?)]
|
2020-11-02 17:58:45 +01:00
|
|
|
|
[compact-tbn (-> tbn? tbn?)]
|
|
|
|
|
[print-org-tbn (->* (tbn?) (#:headers boolean? #:func-names boolean?)
|
|
|
|
|
(listof (listof (or/c number? symbol?))))])
|
2020-02-20 14:13:48 +01:00
|
|
|
|
;; Predicates
|
|
|
|
|
(contract-out [variable? (-> any/c boolean?)]
|
|
|
|
|
[state? (-> any/c boolean?)]
|
|
|
|
|
[update-function-form? (-> any/c boolean?)]
|
2020-02-23 11:10:18 +01:00
|
|
|
|
[network-form? (-> any/c boolean?)]
|
2020-02-23 13:53:02 +01:00
|
|
|
|
[modality? (-> any/c boolean?)]
|
2020-10-12 22:40:03 +02:00
|
|
|
|
[mode? (-> any/c boolean?)]
|
|
|
|
|
[sbf/state? (-> any/c boolean?)])
|
2020-02-20 00:56:30 +01:00
|
|
|
|
;; Contracts
|
2020-02-22 10:37:37 +01:00
|
|
|
|
(contract-out [state/c contract?]
|
2020-02-23 09:12:01 +01:00
|
|
|
|
[update-function/c contract?]
|
2020-07-22 23:45:13 +02:00
|
|
|
|
[domain-mapping/c contract?]
|
2020-10-17 00:45:40 +02:00
|
|
|
|
[tbn? contract?]
|
|
|
|
|
[sbn? contract?]))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(require rackunit))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
|
|
|
|
;;; =================
|
|
|
|
|
;;; 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.
|
2020-02-20 14:13:48 +01:00
|
|
|
|
(define update-function/c (-> state? any/c))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
|
|
|
|
;;; A network is a mapping from its variables to its update functions.
|
2020-03-21 19:19:23 +01:00
|
|
|
|
(define network? (hash/c variable? procedure?))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
|
|
|
|
;;; Given a state s updates all the variables from xs. This
|
|
|
|
|
;;; corresponds to a parallel mode.
|
2020-02-23 09:19:45 +01:00
|
|
|
|
(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)))))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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)))
|
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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)))))
|
|
|
|
|
|
2020-02-23 08:47:16 +01:00
|
|
|
|
;;; A version of make-immutable-hash restricted to creating network
|
|
|
|
|
;;; states (see contract).
|
2020-02-22 23:20:10 +01:00
|
|
|
|
(define (make-state mappings) (make-immutable-hash mappings))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
2020-02-26 15:51:25 +01:00
|
|
|
|
;;; 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)]))))
|
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-02-26 20:47:38 +01:00
|
|
|
|
;;; 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)])))
|
|
|
|
|
|
2020-02-23 08:47:16 +01:00
|
|
|
|
;;; A version of make-immutable-hash restricted to creating networks.
|
2020-02-22 23:22:43 +01:00
|
|
|
|
(define (make-network-from-functions funcs) (make-immutable-hash funcs))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; =================================
|
|
|
|
|
;;; Syntactic description of networks
|
|
|
|
|
;;; =================================
|
|
|
|
|
|
|
|
|
|
;;; An update function form is any form which can appear as a body of
|
|
|
|
|
;;; a function and which can be evaluated with eval. For example,
|
|
|
|
|
;;; '(and x y (not z)) or '(+ 1 a (- b 10)).
|
|
|
|
|
(define update-function-form? any/c)
|
|
|
|
|
|
|
|
|
|
;;; A Boolean network form is a mapping from its variables to the
|
|
|
|
|
;;; forms of their update functions.
|
|
|
|
|
(define network-form? variable-mapping?)
|
|
|
|
|
|
|
|
|
|
;;; Build an update function from an update function form.
|
|
|
|
|
(define (update-function-form->update-function form)
|
2020-02-20 15:36:29 +01:00
|
|
|
|
(λ (s) (eval-with s form)))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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)))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? (f s) #f)))
|
|
|
|
|
|
2020-02-20 00:56:30 +01:00
|
|
|
|
;;; Build a network from a network form.
|
|
|
|
|
(define (network-form->network bnf)
|
2020-02-23 08:57:50 +01:00
|
|
|
|
(for/hash ([(x form) bnf])
|
|
|
|
|
(values x (update-function-form->update-function form))))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? ((hash-ref bn 'a) s) #t)))
|
|
|
|
|
|
2020-02-20 00:56:30 +01:00
|
|
|
|
;;; Build a network from a list of pairs of forms of update functions.
|
|
|
|
|
(define (make-network-from-forms forms)
|
2020-02-22 23:22:43 +01:00
|
|
|
|
(network-form->network (make-immutable-hash forms)))
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? ((hash-ref bn 'a) s) #t)))
|
|
|
|
|
|
2020-02-20 00:56:30 +01:00
|
|
|
|
|
|
|
|
|
;;; ============================
|
|
|
|
|
;;; Inferring interaction graphs
|
|
|
|
|
;;; ============================
|
|
|
|
|
|
|
|
|
|
;;; I allow any syntactic forms in definitions of Boolean functions.
|
|
|
|
|
;;; I can still find out which Boolean variables appear in those
|
|
|
|
|
;;; syntactic form, but I have no reliable syntactic means of finding
|
|
|
|
|
;;; out what kind of action do they have (inhibition or activation)
|
|
|
|
|
;;; since I cannot do Boolean minimisation (e.g., I cannot rely on not
|
|
|
|
|
;;; appearing before a variable, since (not (not a)) is equivalent
|
|
|
|
|
;;; to a). On the other hand, going through all Boolean states is
|
|
|
|
|
;;; quite resource-consuming and thus not always useful.
|
|
|
|
|
;;;
|
|
|
|
|
;;; In this section I provide inference of both unsigned and signed
|
|
|
|
|
;;; interaction graphs, but since the inference of signed interaction
|
|
|
|
|
;;; graphs is based on analysing the dynamics of the networks, it may
|
|
|
|
|
;;; be quite resource-consuming.
|
2020-02-20 15:17:32 +01:00
|
|
|
|
|
|
|
|
|
;;; Lists the variables of the network form appearing in the update
|
|
|
|
|
;;; function form for x.
|
|
|
|
|
(define (list-interactions nf x)
|
|
|
|
|
(set-intersect
|
|
|
|
|
(extract-symbols (hash-ref nf x))
|
|
|
|
|
(hash-keys nf)))
|
2020-02-20 15:56:48 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "list-interactions"
|
|
|
|
|
(define n #hash((a . (+ a b c))
|
|
|
|
|
(b . (- b c))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-true (set=? (list-interactions n 'a) '(a b)))
|
|
|
|
|
(check-true (set=? (list-interactions n 'b) '(b)))))
|
|
|
|
|
|
2020-02-20 15:56:48 +01:00
|
|
|
|
;;; Builds the graph in which the vertices are the variables of a
|
|
|
|
|
;;; given network, and which contains an arrow from a to b whenever a
|
|
|
|
|
;;; appears in (list-interactions a).
|
|
|
|
|
(define (build-interaction-graph n)
|
|
|
|
|
(transpose
|
|
|
|
|
(unweighted-graph/adj
|
2020-02-23 08:57:50 +01:00
|
|
|
|
(for/list ([(var _) n]) (cons var (list-interactions n var))))))
|
2020-02-22 22:27:40 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "build-interaction-graph"
|
|
|
|
|
(define n #hash((a . (+ a b c))
|
|
|
|
|
(b . (- b c))))
|
|
|
|
|
(define ig (build-interaction-graph n))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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))))
|
|
|
|
|
|
2020-02-23 09:12:01 +01:00
|
|
|
|
;;; A domain mapping is a hash set mapping variables to the lists of
|
|
|
|
|
;;; values in their domains.
|
|
|
|
|
(define domain-mapping/c (hash/c variable? list?))
|
|
|
|
|
|
2020-02-23 09:09:43 +01:00
|
|
|
|
;;; Given a hash-set mapping variables to generic sets of their
|
2020-02-22 22:27:40 +01:00
|
|
|
|
;;; possible values, constructs the list of all possible states.
|
|
|
|
|
(define (build-all-states vars-domains)
|
2020-03-22 19:34:08 +01:00
|
|
|
|
(let* ([var-dom-list (hash-map vars-domains (λ (x y) (cons x y)) #t)]
|
2020-02-23 09:09:43 +01:00
|
|
|
|
[vars (map car var-dom-list)]
|
|
|
|
|
[domains (map cdr var-dom-list)])
|
2020-02-22 22:27:40 +01:00
|
|
|
|
(for/list ([s (apply cartesian-product domains)])
|
|
|
|
|
(make-state (for/list ([var vars] [val s])
|
|
|
|
|
(cons var val))))))
|
2020-02-22 22:41:56 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-02-23 00:13:36 +01:00
|
|
|
|
;;; Makes a hash set mapping all variables to a single domain.
|
2020-02-23 00:15:18 +01:00
|
|
|
|
(define (make-same-domains vars domain)
|
2020-02-23 08:57:50 +01:00
|
|
|
|
(for/hash ([var vars]) (values var domain)))
|
2020-02-23 00:13:36 +01:00
|
|
|
|
|
|
|
|
|
;;; Makes a hash set mapping all variables to the Boolean domain.
|
2020-02-23 00:15:18 +01:00
|
|
|
|
(define (make-boolean-domains vars)
|
|
|
|
|
(make-same-domains vars '(#f #t)))
|
2020-02-23 00:13:36 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "make-same-domains, make-boolean-domains"
|
|
|
|
|
(check-equal? (make-boolean-domains '(a b))
|
|
|
|
|
#hash((a . (#f #t)) (b . (#f #t))))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-10-18 22:52:05 +02:00
|
|
|
|
;;; 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))))))
|
|
|
|
|
|
2020-02-23 20:13:37 +01:00
|
|
|
|
;;; Builds all boolean states possible over a given set of variables.
|
|
|
|
|
(define (build-all-boolean-states vars)
|
|
|
|
|
(build-all-states (make-boolean-domains vars)))
|
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-10-18 22:52:45 +02:00
|
|
|
|
;;; 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))))))
|
|
|
|
|
|
2020-03-22 20:43:14 +01:00
|
|
|
|
;;; Given two interacting variables of a network and the domains
|
2020-02-23 00:04:19 +01:00
|
|
|
|
;;; of the variables, returns '+ if the interaction is monotonously
|
|
|
|
|
;;; increasing, '- if it is monotonously decreasing, and '0 otherwise.
|
|
|
|
|
;;;
|
|
|
|
|
;;; This function does not check whether the two variables indeed
|
|
|
|
|
;;; interact. Its behaviour is undefined if the variables do not
|
|
|
|
|
;;; interact.
|
|
|
|
|
;;;
|
|
|
|
|
;;; /!\ This function iterates through almost all of the states of the
|
|
|
|
|
;;; network, so its performance decreases very quickly with network
|
|
|
|
|
;;; size.
|
2020-03-22 20:43:14 +01:00
|
|
|
|
(define (get-interaction-sign network doms x y)
|
2020-02-23 00:04:19 +01:00
|
|
|
|
(let* ([dom-x (hash-ref doms x)]
|
|
|
|
|
[dom-y (hash-ref doms y)]
|
|
|
|
|
;; Replace the domain of x by a dummy singleton.
|
|
|
|
|
[doms-no-x (hash-set doms x '(#f))]
|
|
|
|
|
;; Build all the states, but as if x were not there: since I
|
|
|
|
|
;; replace its domain by a singleton, all states will contain
|
|
|
|
|
;; the same value for x.
|
2020-02-23 09:09:43 +01:00
|
|
|
|
[states-no-x (build-all-states doms-no-x)]
|
2020-02-23 00:04:19 +01:00
|
|
|
|
;; Go through all states, then through all ordered pairs of
|
|
|
|
|
;; values of x, generate pairs of states (s1, s2) such that x
|
|
|
|
|
;; has a smaller value in s1, and check that updating y in s1
|
|
|
|
|
;; yields a smaller value than updating y in s2. I rely on
|
|
|
|
|
;; the fact that the domains are ordered.
|
|
|
|
|
[x-y-interactions (for*/list ([s states-no-x]
|
|
|
|
|
[x1 dom-x] ; ordered pairs of values of x
|
|
|
|
|
[x2 (cdr (member x1 dom-x))])
|
|
|
|
|
(let* ([s1 (hash-set s x x1)] ; s1(x) < s2(x)
|
|
|
|
|
[s2 (hash-set s x x2)]
|
|
|
|
|
[y1 ((hash-ref network y) s1)]
|
|
|
|
|
[y2 ((hash-ref network y) s2)])
|
|
|
|
|
;; y1 <= y2?
|
|
|
|
|
(<= (index-of dom-y y1) (index-of dom-y y2))))])
|
|
|
|
|
(cond
|
|
|
|
|
;; If, in all interactions, y1 <= y2, then we have an
|
|
|
|
|
;; increasing/promoting interaction between x and y.
|
|
|
|
|
[(andmap (λ (x) (eq? x #t)) x-y-interactions) '+]
|
|
|
|
|
;; If, in all interactions, y1 > y2, then we have an
|
|
|
|
|
;; decreasing/inhibiting interaction between x and y.
|
|
|
|
|
[(andmap (λ (x) (eq? x #f)) x-y-interactions) '-]
|
|
|
|
|
;; Otherwise the interaction is neither increasing nor
|
|
|
|
|
;; decreasing.
|
|
|
|
|
[else '0])))
|
2020-02-23 01:00:09 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "get-interaction-sign"
|
|
|
|
|
(define n #hash((a . (not b)) (b . a)))
|
|
|
|
|
(define doms (make-boolean-domains '(a b)))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? (get-interaction-sign (network-form->network n) doms 'a 'b) '+)
|
|
|
|
|
(check-equal? (get-interaction-sign (network-form->network n) doms 'b 'a) '-)))
|
|
|
|
|
|
2020-02-23 01:00:09 +01:00
|
|
|
|
;;; 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.
|
2020-03-22 20:45:11 +01:00
|
|
|
|
(define (build-signed-interaction-graph/form network-form doms)
|
2020-03-22 20:43:14 +01:00
|
|
|
|
(let ([ig (build-interaction-graph network-form)]
|
|
|
|
|
[network (network-form->network network-form)])
|
2020-05-14 01:06:17 +02:00
|
|
|
|
;; 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))
|
2020-02-23 10:00:48 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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) '-)))
|
|
|
|
|
|
2020-02-23 10:00:48 +01:00
|
|
|
|
;;; Calls build-signed-interaction-graph with the Boolean domain for
|
|
|
|
|
;;; all variable.
|
|
|
|
|
;;;
|
|
|
|
|
;;; /!\ The same performance warning applies as for
|
|
|
|
|
;;; build-signed-interaction-graph.
|
2020-03-22 20:45:11 +01:00
|
|
|
|
(define (build-boolean-signed-interaction-graph/form network-form)
|
|
|
|
|
(build-signed-interaction-graph/form
|
|
|
|
|
network-form
|
|
|
|
|
(make-boolean-domains (hash-keys network-form))))
|
2020-02-23 11:10:18 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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) '-)))
|
|
|
|
|
|
2020-03-22 21:00:12 +01:00
|
|
|
|
;;; 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)
|
2020-05-14 01:06:17 +02:00
|
|
|
|
(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)
|
2020-03-22 21:00:12 +01:00
|
|
|
|
|
|
|
|
|
;;; 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))))
|
2020-02-23 11:10:18 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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)))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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
|
2020-05-27 23:39:38 +02:00
|
|
|
|
;;; contain all nodes.
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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)))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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))))
|
|
|
|
|
|
|
|
|
|
|
2020-02-23 11:10:18 +01:00
|
|
|
|
;;; ====================
|
|
|
|
|
;;; Dynamics of networks
|
|
|
|
|
;;; ====================
|
|
|
|
|
|
|
|
|
|
;;; This section contains definitions for building and analysing the
|
|
|
|
|
;;; dynamics of networks.
|
|
|
|
|
|
2020-02-23 13:53:02 +01:00
|
|
|
|
;;; A modality is a set of variable.
|
|
|
|
|
(define modality? (set/c variable?))
|
|
|
|
|
|
|
|
|
|
;;; A mode is a set of modalities.
|
|
|
|
|
(define mode? (set/c modality?))
|
2020-02-23 11:10:18 +01:00
|
|
|
|
|
|
|
|
|
;;; A network dynamics is a network plus a mode.
|
2020-02-23 12:19:47 +01:00
|
|
|
|
(struct dynamics (network mode)
|
|
|
|
|
#:methods gen:dds
|
2020-03-02 12:12:57 +01:00
|
|
|
|
[;; Annotates each result state with the modality which lead to it.
|
2020-02-23 14:11:55 +01:00
|
|
|
|
(define/match (dds-step-one-annotated dyn s)
|
|
|
|
|
[((dynamics network mode) s)
|
|
|
|
|
(for/set ([m mode]) (cons m (update network s m)))])])
|
2020-02-23 11:25:19 +01:00
|
|
|
|
|
|
|
|
|
;;; Given a list of variables, builds the asynchronous mode (a set of
|
|
|
|
|
;;; singletons).
|
|
|
|
|
(define (make-asyn vars)
|
|
|
|
|
(for/set ([v vars]) (set v)))
|
|
|
|
|
|
|
|
|
|
;;; Given a list of variables, builds the synchronous mode (a set
|
|
|
|
|
;;; containing the set of variables).
|
|
|
|
|
(define (make-syn vars) (set (list->set vars)))
|
2020-02-23 11:42:01 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "make-asyn, make-syn"
|
|
|
|
|
(define vars '(a b c))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? (make-asyn vars) (set (set 'a) (set 'b) (set 'c)))
|
|
|
|
|
(check-equal? (make-syn vars) (set (set 'a 'b 'c)))))
|
|
|
|
|
|
2020-02-23 11:42:01 +01:00
|
|
|
|
;;; Given a network, applies a function for building a mode to its
|
|
|
|
|
;;; variables and returns the corresponding network dynamics.
|
|
|
|
|
(define (make-dynamics-from-func network mode-func)
|
|
|
|
|
(dynamics network (mode-func (hash-keys network))))
|
|
|
|
|
|
|
|
|
|
;;; Creates the asynchronous dynamics for a given network.
|
|
|
|
|
(define (make-asyn-dynamics network)
|
|
|
|
|
(make-dynamics-from-func network make-asyn))
|
|
|
|
|
|
|
|
|
|
;;; Creates the synchronous dynamics for a given network.
|
|
|
|
|
(define (make-syn-dynamics network)
|
|
|
|
|
(make-dynamics-from-func network make-syn))
|
2020-02-23 19:24:53 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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)))))
|
|
|
|
|
|
2020-03-04 18:54:36 +01:00
|
|
|
|
;;; Reads an Org-mode-produced sexp, converts it into a network, and
|
|
|
|
|
;;; builds the asyncronous dynamics out of it.
|
|
|
|
|
(define read-org-network-make-asyn (compose make-asyn-dynamics network-form->network read-org-variable-mapping))
|
|
|
|
|
|
|
|
|
|
;;; 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))
|
|
|
|
|
|
2020-02-23 19:24:53 +01:00
|
|
|
|
;;; Pretty-prints a state of the network.
|
|
|
|
|
(define (pretty-print-state s)
|
2020-02-26 21:27:02 +01:00
|
|
|
|
(string-join (hash-map s (λ (key val) (format "~a:~a" key val)) #t)))
|
2020-02-23 19:44:55 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "pretty-print-state"
|
|
|
|
|
(check-equal? (pretty-print-state (make-state '((a . #f) (b . 3) (c . 4))))
|
|
|
|
|
"a:#f b:3 c:4")))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-02-23 19:44:55 +01:00
|
|
|
|
;;; Pretty-prints a state of the network to Boolean values 0 or 1.
|
|
|
|
|
(define (pretty-print-boolean-state s)
|
2020-06-06 08:23:55 +02:00
|
|
|
|
(string-join (hash-map s (λ (key val) (format "~a:~a" key (any->01 val))) #t)))
|
2020-02-23 19:44:55 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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")))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-02-23 19:44:55 +01:00
|
|
|
|
;;; Given a state graph and a pretty-printer for states build a new
|
2020-03-01 15:20:44 +01:00
|
|
|
|
;;; state graph with pretty-printed vertices and edges.
|
2020-02-23 19:44:55 +01:00
|
|
|
|
(define (pretty-print-state-graph-with gr pprinter)
|
2020-03-02 23:59:37 +01:00
|
|
|
|
(update-graph gr #:v-func pprinter #:e-func pretty-print-set-sets))
|
2020-02-23 19:44:55 +01:00
|
|
|
|
|
|
|
|
|
;;; 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.
|
2020-05-28 00:49:29 +02:00
|
|
|
|
(define ppsg pretty-print-state-graph)
|
2020-02-23 19:44:55 +01:00
|
|
|
|
|
|
|
|
|
;;; 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.
|
2020-05-28 00:49:29 +02:00
|
|
|
|
(define ppsgb pretty-print-boolean-state-graph)
|
2020-02-23 20:13:37 +01:00
|
|
|
|
|
|
|
|
|
;;; 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))))))
|
2020-02-28 21:56:42 +01:00
|
|
|
|
|
|
|
|
|
;;; 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))))))
|
2020-03-15 16:12:35 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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)))))
|
|
|
|
|
|
2020-10-18 22:57:08 +02:00
|
|
|
|
;;; Like build-full-boolean-state-graph, but the states are expressed
|
|
|
|
|
;;; in 0 and 1, instead of #f and #t.
|
|
|
|
|
(define (build-full-01-state-graph dyn)
|
|
|
|
|
(dds-build-state-graph
|
|
|
|
|
dyn
|
|
|
|
|
(list->set (build-all-01-states (hash-keys (dynamics-network dyn))))))
|
|
|
|
|
|
|
|
|
|
;;; Like build-full-boolean-state-graph-annotated, but the states are expressed
|
|
|
|
|
;;; in 0 and 1, instead of #f and #t.
|
|
|
|
|
(define (build-full-01-state-graph-annotated dyn)
|
|
|
|
|
(dds-build-state-graph-annotated
|
|
|
|
|
dyn
|
|
|
|
|
(list->set (build-all-01-states (hash-keys (dynamics-network dyn))))))
|
|
|
|
|
|
2020-03-15 16:12:35 +01:00
|
|
|
|
|
2020-03-22 14:40:23 +01:00
|
|
|
|
;;; =================================
|
|
|
|
|
;;; Tabulating functions and networks
|
|
|
|
|
;;; =================================
|
2020-03-15 16:12:35 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-03-22 14:34:40 +01:00
|
|
|
|
;;; 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])
|
2020-06-02 21:29:00 +02:00
|
|
|
|
(define tab (tabulate-state* `(,func) domains #:headers headers))
|
2020-03-22 14:34:40 +01:00
|
|
|
|
(cond
|
|
|
|
|
[headers
|
2020-06-02 21:29:00 +02:00
|
|
|
|
;; Replace 'f1 in the headers by 'f.
|
|
|
|
|
(match tab [(cons hdrs vals)
|
|
|
|
|
(cons (append (drop-right hdrs 1) '(f)) vals)])]
|
2020-03-22 14:34:40 +01:00
|
|
|
|
[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))
|
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "tabulate-state/boolean"
|
|
|
|
|
(define func (λ (st) (not (hash-ref st 'a))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? (tabulate-state/boolean func '(a)) '((a f) (#f #t) (#t #f)))))
|
|
|
|
|
|
2020-06-02 21:28:37 +02:00
|
|
|
|
;;; 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.
|
2020-06-02 21:53:53 +02:00
|
|
|
|
(define (tabulate-state* funcs domains #:headers [headers #t])
|
2020-06-02 21:28:37 +02:00
|
|
|
|
(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.
|
2020-06-02 21:53:53 +02:00
|
|
|
|
(define (tabulate-state*/boolean funcs args #:headers [headers #t])
|
2020-06-02 21:28:37 +02:00
|
|
|
|
(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))))
|
2020-06-02 23:33:34 +02:00
|
|
|
|
(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)))))
|
2020-06-02 21:28:37 +02:00
|
|
|
|
|
2020-03-22 19:22:54 +01:00
|
|
|
|
;;; 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])
|
2020-06-02 23:34:19 +02:00
|
|
|
|
;; I use hash-map with try-order? set to #t to ask the hash table to
|
|
|
|
|
;; sort the keys for me.
|
2020-06-02 23:37:28 +02:00
|
|
|
|
(define-values (vars funcs) (for/lists (l1 l2)
|
2020-06-02 23:34:19 +02:00
|
|
|
|
([pair (hash-map network cons #t)])
|
|
|
|
|
(values (car pair) (cdr pair))))
|
|
|
|
|
(define tab (tabulate-state* funcs domains #:headers headers))
|
2020-03-22 19:22:54 +01:00
|
|
|
|
(cond
|
|
|
|
|
[headers
|
2020-06-02 23:34:19 +02:00
|
|
|
|
;; 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)])]
|
2020-03-22 19:22:54 +01:00
|
|
|
|
[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))
|
2020-03-22 14:40:23 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "tabulate-boolean-network"
|
|
|
|
|
(define bn (network-form->network #hash((a . (not a)) (b . b))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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)))))
|
|
|
|
|
|
|
|
|
|
|
2020-03-23 22:31:58 +01:00
|
|
|
|
;;; ===================================
|
|
|
|
|
;;; Constructing functions and networks
|
|
|
|
|
;;; ===================================
|
2020-03-22 14:40:23 +01:00
|
|
|
|
|
2020-03-24 00:18:39 +01:00
|
|
|
|
;;; Given a table like the one produced by tabulate-network,
|
|
|
|
|
;;; constructs a Boolean network having this behaviour. If headers is
|
|
|
|
|
;;; #t, considers that the first element of the list are the headers
|
|
|
|
|
;;; and reads the names of the variables from them. Otherwise
|
|
|
|
|
;;; generates names for variables of the form xi, where 0 ≤ i < number
|
|
|
|
|
;;; of variables, and treats all rows in the table as defining the
|
|
|
|
|
;;; behaviour of the functions of the network. The columns defining
|
|
|
|
|
;;; the functions are taken to be in the same order as the variables
|
|
|
|
|
;;; in the first half of the function. The headers of the columns
|
|
|
|
|
;;; defining the functions are therefore discarded.
|
|
|
|
|
;;;
|
|
|
|
|
;;; This function relies on table->function, so the same caveats
|
|
|
|
|
;;; apply.
|
|
|
|
|
(define (table->network table #:headers [headers #t])
|
|
|
|
|
(define n (/ (length (car table)) 2))
|
|
|
|
|
;; Get the variable names from the table or generate them, if
|
|
|
|
|
;; necessary.
|
|
|
|
|
(define var-names (cond [headers (take (car table) n)]
|
|
|
|
|
[else (for ([i (in-range n)])
|
|
|
|
|
(symbol->string (format "x~a" i)))]))
|
|
|
|
|
;; Drop the headers if they are present.
|
|
|
|
|
(define tab (cond [headers (cdr table)]
|
|
|
|
|
[else table]))
|
|
|
|
|
;; Split the table into the inputs and the outputs of the functions.
|
|
|
|
|
(define-values (ins outs) (multi-split-at tab n))
|
|
|
|
|
;; Transpose outs to have functions define by lines instead of by
|
|
|
|
|
;; columns.
|
|
|
|
|
(define func-lines (lists-transpose outs))
|
|
|
|
|
;; Make states out of inputs.
|
|
|
|
|
(define st-ins (for/list ([in ins]) (make-state (map cons var-names in))))
|
|
|
|
|
;; Construct the functions.
|
|
|
|
|
(define funcs (for/list ([out func-lines])
|
|
|
|
|
(table->function (for/list ([in st-ins] [o out])
|
|
|
|
|
(list in o)))))
|
|
|
|
|
;; Construct the network.
|
|
|
|
|
(make-network-from-functions (map cons var-names funcs)))
|
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(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))
|
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(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)))))))
|
|
|
|
|
|
2020-03-20 22:22:33 +01:00
|
|
|
|
|
2020-03-22 14:40:23 +01:00
|
|
|
|
;;; =============================
|
|
|
|
|
;;; Random functions and networks
|
|
|
|
|
;;; =============================
|
2020-03-20 22:22:33 +01:00
|
|
|
|
|
2020-03-22 14:35:26 +01:00
|
|
|
|
;;; 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)))
|
2020-03-22 18:40:50 +01:00
|
|
|
|
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(module+ test
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(test-case "random-boolean-function/state"
|
|
|
|
|
(random-seed 0)
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(define f (random-boolean-function/state '(x1 x2)))
|
|
|
|
|
(check-equal? (tabulate-state/boolean f '(x1 x2))
|
2020-05-27 23:39:38 +02:00
|
|
|
|
'((x1 x2 f) (#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t)))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(check-equal? (tabulate-state/boolean f '(x1 x2) #:headers #f)
|
2020-05-27 23:39:38 +02:00
|
|
|
|
'((#f #f #f) (#f #t #f) (#t #f #t) (#t #t #t)))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
(define bn (random-boolean-network/vars 3))
|
|
|
|
|
(check-equal? (tabulate-boolean-network bn)
|
|
|
|
|
'((x0 x1 x2 f-x0 f-x1 f-x2)
|
2020-05-27 23:39:38 +02:00
|
|
|
|
(#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)))))
|
2020-05-22 23:40:40 +02:00
|
|
|
|
|
2020-03-22 18:40:50 +01:00
|
|
|
|
;;; Generates a random network from the given domain mapping.
|
2020-03-22 19:28:44 +01:00
|
|
|
|
(define (random-network domains)
|
2020-03-22 18:40:50 +01:00
|
|
|
|
(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.
|
2020-03-22 19:28:44 +01:00
|
|
|
|
(define (random-boolean-network vars)
|
2020-03-22 18:40:50 +01:00
|
|
|
|
(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.
|
2020-03-22 19:28:44 +01:00
|
|
|
|
(define (random-boolean-network/vars n)
|
2020-03-22 18:40:50 +01:00
|
|
|
|
(random-boolean-network (for/list ([i (in-range n)]) (string->symbol (format "x~a" i)))))
|
2020-07-21 00:13:56 +02:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; ===================
|
|
|
|
|
;;; TBF/TBN and SBF/SBN
|
|
|
|
|
;;; ===================
|
|
|
|
|
|
2020-07-22 23:46:58 +02:00
|
|
|
|
;;; 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.
|
2020-07-22 23:53:20 +02:00
|
|
|
|
(define (apply-tbf-to-state tbf st)
|
2020-07-22 23:46:58 +02:00
|
|
|
|
(apply-tbf tbf (list->vector (hash-map st (λ (_ val) val)))))
|
|
|
|
|
|
|
|
|
|
(module+ test
|
2020-07-23 00:22:39 +02:00
|
|
|
|
(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)))
|
2020-07-23 00:06:26 +02:00
|
|
|
|
|
|
|
|
|
;;; A state TBF is a TBF with named inputs. A state TBF can be
|
|
|
|
|
;;; applied to states in an unambiguous ways.
|
2020-07-23 00:17:17 +02:00
|
|
|
|
(struct tbf/state (weights threshold) #:transparent)
|
2020-07-23 00:06:26 +02:00
|
|
|
|
|
|
|
|
|
;;; Shortcuts for acessing fields of a state/tbf.
|
2020-07-23 00:11:14 +02:00
|
|
|
|
(define tbf/state-w tbf/state-weights)
|
|
|
|
|
(define tbf/state-θ tbf/state-threshold)
|
2020-07-23 00:06:26 +02:00
|
|
|
|
|
2020-07-23 00:19:25 +02:00
|
|
|
|
;;; 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))
|
2020-07-23 00:20:00 +02:00
|
|
|
|
|
|
|
|
|
(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)))
|
|
|
|
|
|
2020-10-12 22:46:21 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-12 22:53:34 +02:00
|
|
|
|
;;; 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))))
|
|
|
|
|
|
2020-08-01 23:24:51 +02:00
|
|
|
|
;;; 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)))
|
|
|
|
|
|
2020-10-10 23:23:43 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-12 23:20:48 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-10 23:51:52 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-13 23:25:21 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-12 00:24:10 +02:00
|
|
|
|
;;; 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)))))
|
2020-10-14 00:07:08 +02:00
|
|
|
|
(if headers
|
|
|
|
|
(cons (append (hash-map (tbf/state-w (car tbfs)) (λ (x _) x) #t) '(θ))
|
|
|
|
|
table)
|
|
|
|
|
table))
|
2020-10-12 00:24:10 +02:00
|
|
|
|
|
|
|
|
|
(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)))
|
2020-10-12 00:47:25 +02:00
|
|
|
|
(check-equal? (print-org-tbfs/state tbfs)
|
|
|
|
|
'((a b θ) (1 2 3) (-2 1 1)))))
|
|
|
|
|
|
2020-10-14 00:02:58 +02:00
|
|
|
|
;;; 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))))
|
|
|
|
|
|
2020-10-12 00:47:54 +02:00
|
|
|
|
;;; 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)))))
|
2020-10-12 00:24:10 +02:00
|
|
|
|
|
2020-10-12 00:53:56 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-15 00:17:15 +02:00
|
|
|
|
;;; 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?))
|
2020-10-15 00:33:18 +02:00
|
|
|
|
|
|
|
|
|
;;; 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)))))
|
2020-10-16 00:55:26 +02:00
|
|
|
|
|
2020-10-17 00:45:40 +02:00
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2020-10-16 00:55:26 +02:00
|
|
|
|
;;; Constructs a network from a network form defining a TBN.
|
|
|
|
|
(define (tbn->network tbn)
|
|
|
|
|
(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))
|
2020-10-17 00:55:20 +02:00
|
|
|
|
(make-state '((a . 0) (b . 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))
|
2020-10-16 00:55:26 +02:00
|
|
|
|
(make-state '((a . 0) (b . 1))))))
|
2020-10-17 23:51:51 +02:00
|
|
|
|
|
2020-10-22 00:52:06 +02:00
|
|
|
|
;;; 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.
|
2020-10-17 23:51:51 +02:00
|
|
|
|
;;;
|
|
|
|
|
;;; 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.
|
2020-10-22 00:52:06 +02:00
|
|
|
|
(define (parse-org-tbn sexp
|
|
|
|
|
#:headers [headers #t]
|
|
|
|
|
#:func-names [func-names #t])
|
2020-10-17 23:51:51 +02:00
|
|
|
|
(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))]))
|
|
|
|
|
|
2020-10-22 00:52:06 +02:00
|
|
|
|
;;; 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)))))
|
2020-10-22 00:59:58 +02:00
|
|
|
|
|
|
|
|
|
;;; 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))
|
|
|
|
|
|
2020-10-17 23:51:51 +02:00
|
|
|
|
(module+ test
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(test-case "read-org-sbn, parse-org-tbn"
|
|
|
|
|
(check-equal? (read-org-sbn "((\"-\" \"x\" \"y\") (\"y\" -1 0) (\"x\" 0 -1))")
|
2020-10-17 23:51:51 +02:00
|
|
|
|
(hash
|
|
|
|
|
'x
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(tbf/state '#hash((x . 0) (y . -1)) 0)
|
2020-10-17 23:51:51 +02:00
|
|
|
|
'y
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(tbf/state '#hash((x . -1) (y . 0)) 0)))
|
|
|
|
|
(check-equal? (read-org-sbn "((\"x\" \"y\") (-1 0) (0 -1))" #:func-names #f)
|
2020-10-17 23:51:51 +02:00
|
|
|
|
(hash
|
|
|
|
|
'x
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(tbf/state '#hash((x . -1) (y . 0)) 0)
|
2020-10-17 23:51:51 +02:00
|
|
|
|
'y
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(tbf/state '#hash((x . 0) (y . -1)) 0)))
|
|
|
|
|
(check-equal? (read-org-sbn "((-1 0) (0 -1))" #:headers #f #:func-names #f)
|
2020-10-17 23:51:51 +02:00
|
|
|
|
(hash
|
|
|
|
|
'x0
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(tbf/state '#hash((x0 . -1) (x1 . 0)) 0)
|
2020-10-17 23:51:51 +02:00
|
|
|
|
'x1
|
2020-10-22 00:59:58 +02:00
|
|
|
|
(tbf/state '#hash((x0 . 0) (x1 . -1)) 0)))))
|
2020-10-23 00:17:36 +02:00
|
|
|
|
|
|
|
|
|
;;; A shortcut for building the state graphs of TBN.
|
|
|
|
|
(define build-tbn-state-graph
|
|
|
|
|
(compose pretty-print-state-graph
|
|
|
|
|
build-full-01-state-graph
|
|
|
|
|
make-syn-dynamics
|
|
|
|
|
tbn->network))
|
2020-10-24 23:15:13 +02:00
|
|
|
|
|
|
|
|
|
;;; 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))))))))
|
2020-10-24 23:51:56 +02:00
|
|
|
|
|
|
|
|
|
;;; 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)))))
|
2020-10-31 00:48:00 +01:00
|
|
|
|
|
|
|
|
|
;;; Compacts (and denormalizes) a TBF by removing all inputs which
|
|
|
|
|
;;; are 0.
|
|
|
|
|
(define (compact-tbf tbf)
|
|
|
|
|
(tbf/state
|
2020-11-01 23:38:08 +01:00
|
|
|
|
(for/hash ([(k v) (in-hash (tbf/state-w tbf))]
|
|
|
|
|
#:unless (zero? v))
|
|
|
|
|
(values k v))
|
2020-10-31 00:48:00 +01:00
|
|
|
|
(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))))
|
2020-11-02 00:08:49 +01:00
|
|
|
|
|
|
|
|
|
;;; 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)))))
|
2020-11-02 17:58:45 +01:00
|
|
|
|
|
|
|
|
|
;;; 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)))))
|
2020-11-02 23:05:05 +01:00
|
|
|
|
(check-equal? (print-org-tbn tbn)
|
|
|
|
|
'((- a b θ) (a 0 1 0) (b -1 0 -1)))))
|