#lang racket

;;; dds/networks

;;; This module provides some quick definitions for and analysing
;;; network models.  A network is a set of variables which are updated
;;; according to their corresponding update functions.  The variables
;;; to be updated at each step are given by the mode.
;;;
;;; This model can generalise Boolean networks, TBANs, multivalued
;;; networks, etc.

(require "utils.rkt" graph)

(provide
 ;; Functions
 (contract-out [update (-> network? state? (listof variable?) state?)]
               [make-state (-> (listof (cons/c symbol? any/c)) state?)]
               [make-network-from-functions (-> (listof (cons/c symbol? update-function/c)) network?)]
               [update-function-form->update-function (-> update-function-form? update-function/c)]
               [network-form->network (-> network-form? network?)]
               [make-network-from-forms (-> (listof (cons/c symbol? update-function-form?))
                                            network?)]
               [list-interactions (-> network-form? variable? (listof variable?))]
               [build-interaction-graph (-> network-form? graph?)]
               [build-all-states (-> (listof (cons/c variable? generic-set?)) (listof state?))]
               [build-all-states-same-domain (-> (listof variable?) generic-set? (listof state?))]
               [make-same-domains (-> (listof variable?) generic-set? (hash/c variable? generic-set?))]
               [make-boolean-domains (-> (listof variable?) (hash/c variable? (list/c #f #t)))]
               [get-interaction-sign (-> network-form? (hash/c variable? generic-set?) variable? variable? (or/c '+ '- '0))]
               [build-signed-interaction-graph (-> network-form? (hash/c variable? generic-set?) graph?)])
 ;; Predicates
 (contract-out [variable? (-> any/c boolean?)]
               [state? (-> any/c boolean?)]
               [update-function-form? (-> any/c boolean?)]
               [network-form? (-> any/c boolean?)])
 ;; Contracts
 (contract-out [state/c contract?]
               [network/c contract?]
               [update-function/c contract?])
 ;; Syntax
 st nn)


;;; =================
;;; Basic definitions
;;; =================

(define variable? symbol?)

;;; A state of a network is a mapping from the variables of the
;;; network to their values.
(define state? variable-mapping?)
(define state/c (flat-named-contract 'state state?))

;;; An update function is a function computing a value from the given
;;; state.
(define update-function/c (-> state? any/c))

;;; A network is a mapping from its variables to its update functions.
(define network? variable-mapping?)
(define network/c (flat-named-contract 'network network?))

;;; Given a state s updates all the variables from xs.  This
;;; corresponds to a parallel mode.
(define (update n   ; the network
                s   ; the state to operate on
                xs) ; the variables to update
  (let ([new-s (hash-copy s)])
    (for ([x xs])
      (let ([f (hash-ref n x)])
        (hash-set! new-s x (f s))))
    new-s))

;;; A version of make-immutable-hash restricted to creating network
;;; states (see contract).
(define (make-state mappings) (make-immutable-hash mappings))

;;; A shortcut for make-state.
(define-syntax-rule (st mappings) (make-state mappings))

;;; A version of make-immutable-hash restricted to creating networks.
(define (make-network-from-functions funcs) (make-immutable-hash funcs))


;;; =================================
;;; Syntactic description of networks
;;; =================================

;;; An update function form is any form which can appear as a body of
;;; a function and which can be evaluated with eval.  For example,
;;; '(and x y (not z)) or '(+ 1 a (- b 10)).
(define update-function-form? any/c)

;;; A Boolean network form is a mapping from its variables to the
;;; forms of their update functions.
(define network-form? variable-mapping?)

;;; Build an update function from an update function form.
(define (update-function-form->update-function form)
  (λ (s) (eval-with s form)))

;;; Build a network from a network form.
(define (network-form->network bnf)
  (make-immutable-hash
   (hash-map bnf (λ (x form)
                   (cons x (update-function-form->update-function form))))))

;;; Build a network from a list of pairs of forms of update functions.
(define (make-network-from-forms forms)
  (network-form->network (make-immutable-hash forms)))

;;; A shortcut for make-network-from-forms.
(define-syntax-rule (nn forms) (make-network-from-forms forms))


;;; ============================
;;; Inferring interaction graphs
;;; ============================

;;; I allow any syntactic forms in definitions of Boolean functions.
;;; I can still find out which Boolean variables appear in those
;;; syntactic form, but I have no reliable syntactic means of finding
;;; out what kind of action do they have (inhibition or activation)
;;; since I cannot do Boolean minimisation (e.g., I cannot rely on not
;;; appearing before a variable, since (not (not a)) is equivalent
;;; to a).  On the other hand, going through all Boolean states is
;;; quite resource-consuming and thus not always useful.
;;;
;;; In this section I provide inference of both unsigned and signed
;;; interaction graphs, but since the inference of signed interaction
;;; graphs is based on analysing the dynamics of the networks, it may
;;; be quite resource-consuming.

;;; 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)))

;;; 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
    (hash-map n (λ (var _)
                  (cons var (list-interactions n var)))))))

;;; Given a list of pairs mapping variables to generic sets of their
;;; possible values, constructs the list of all possible states.
(define (build-all-states vars-domains)
  (let ([vars (map car vars-domains)]
        [domains (map cdr vars-domains)])
    (for/list ([s (apply cartesian-product domains)])
      (make-state (for/list ([var vars] [val s])
                    (cons var val))))))

;;; Given a list of variables and a domain common to all of them,
;;; builds the list of all possible states.
(define (build-all-states-same-domain vars domain)
  (build-all-states (for/list ([v vars]) (cons v domain))))

;;; Makes a hash set mapping all variables to a single domain.
(define (make-same-domains vars domain)
  (make-immutable-hash (for/list ([var vars]) (cons var domain))))

;;; Makes a hash set mapping all variables to the Boolean domain.
(define (make-boolean-domains vars)
  (make-same-domains vars '(#f #t)))

;;; Given two interacting variables of a network form and the domains
;;; of the variables, returns '+ if the interaction is monotonously
;;; increasing, '- if it is monotonously decreasing, and '0 otherwise.
;;;
;;; This function does not check whether the two variables indeed
;;; interact.  Its behaviour is undefined if the variables do not
;;; interact.
;;;
;;; /!\ This function iterates through almost all of the states of the
;;; network, so its performance decreases very quickly with network
;;; size.
(define (get-interaction-sign network-form doms x y)
  (let* ([dom-x (hash-ref doms x)]
         [dom-y (hash-ref doms y)]
         [network (network-form->network network-form)]
         ;; Replace the domain of x by a dummy singleton.
         [doms-no-x (hash-set doms x '(#f))]
         ;; Build all the states, but as if x were not there: since I
         ;; replace its domain by a singleton, all states will contain
         ;; the same value for x.
         [states-no-x (build-all-states (hash->list doms-no-x))]
         ;; Go through all states, then through all ordered pairs of
         ;; values of x, generate pairs of states (s1, s2) such that x
         ;; has a smaller value in s1, and check that updating y in s1
         ;; yields a smaller value than updating y in s2.  I rely on
         ;; the fact that the domains are ordered.
         [x-y-interactions (for*/list ([s states-no-x]
                                       [x1 dom-x] ; ordered pairs of values of x
                                       [x2 (cdr (member x1 dom-x))])
                             (let* ([s1 (hash-set s x x1)] ; s1(x) < s2(x)
                                    [s2 (hash-set s x x2)]
                                    [y1 ((hash-ref network y) s1)]
                                    [y2 ((hash-ref network y) s2)])
                               ;; y1 <= y2?
                               (<= (index-of dom-y y1) (index-of dom-y y2))))])
    (cond
      ;; If, in all interactions, y1 <= y2, then we have an
      ;; increasing/promoting interaction between x and y.
      [(andmap (λ (x) (eq? x #t)) x-y-interactions) '+]
      ;; If, in all interactions, y1 > y2, then we have an
      ;; decreasing/inhibiting interaction between x and y.
      [(andmap (λ (x) (eq? x #f)) x-y-interactions) '-]
      ;; Otherwise the interaction is neither increasing nor
      ;; decreasing.
      [else '0])))

;;; Constructs a signed interaction graph of a given network form,
;;; given the ordered domains of its variables.  The order on the
;;; domains determines the signs which will appear on the interaction
;;; graph.
;;;
;;; /!\ This function iterates through almost all states of the
;;; network for every arrow in the unsigned interaction graph, so its
;;; performance decreases very quickly with the size of the network.
(define (build-signed-interaction-graph network-form doms)
  (let ([ig (build-interaction-graph network-form)])
    (weighted-graph/directed
     (for/list ([e (in-edges ig)])
       (match-let ([(list x y) e])
         (list (match (get-interaction-sign network-form doms x y)
                 ['+ 1] ['- -1] ['0 0])
               x y))))))