source: project/release/3/nemo/trunk/nemo-utils.scm @ 12624

Last change on this file since 12624 was 12624, checked in by Ivan Raikov, 13 years ago

Factoring out the code for creating graph representation of the kinetic equations.

File size: 6.9 KB
Line 
1;;       
2;;
3;; Utility procedures for NEMO code generators.
4;;
5;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;; General Public License for more details.
16;;
17;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20
21(require-extension syntax-case)
22(require-extension matchable)
23(require-extension strictly-pretty)
24(require-extension nemo-core)
25(require-extension srfi-1)
26(require-extension srfi-13)
27(require-extension varsubst)
28(require-extension digraph)
29
30(define-extension nemo-utils)
31
32
33
34(declare
35 (lambda-lift)
36 (export  lookup-def binding? bind
37          enum-bnds enum-freevars sum subst-term
38          if-convert let-enum let-elim let-lift
39          s+ sw+ sl\ nl spaces ppf
40          transitions-graph
41          ))
42
43
44
45(define (lookup-def k lst . rest)
46  (let-optionals rest ((default #f))
47      (let ((kv (assoc k lst)))
48        (if (not kv) default
49            (match kv ((k v) v) (else (cdr kv)))))))
50
51
52(define (enum-bnds expr ax)
53  (match expr 
54         (('if . es)        (fold enum-bnds ax es))
55         (('let bnds body)  (enum-bnds body (append (map car bnds) (fold enum-bnds ax (map cadr bnds)))))
56         ((s . es)          (if (symbol? s)  (fold enum-bnds ax es) ax))
57         (else ax)))
58
59
60(define (enum-freevars expr bnds ax)
61  (match expr 
62         (('if . es) 
63          (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
64         (('let bnds body) 
65          (let ((bnds1 (append (map first bnds) bnds)))
66            (enum-freevars body bnds1 (fold (lambda (x ax) (enum-freevars x bnds ax)) ax (map second bnds)))))
67         ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
68         (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
69
70
71(define (sum lst)
72  (if (null? lst) lst
73      (match lst
74             ((x)   x)
75             ((x y) `(+ ,x ,y))
76             ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
77             ((x . rest) `(+ ,x ,(sum rest))))))
78
79
80(define (subst-term t subst k)
81  (match t
82         (('if c t e)
83          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
84         (('let bs e)
85          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
86         ((f . es)
87          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
88         ((? symbol? )  (lookup-def t subst t))
89         ((? atom? ) t)))
90
91(define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
92
93(define (bind ks vs e) `(let ,(zip ks vs) ,e))
94
95(define (if-convert expr)
96  (match expr 
97         (('if c t e) 
98          (let ((r (gensym "if")))
99            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
100               ,r)))
101         (('let bs e)
102          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
103         ((f . es)
104          (cons f (map if-convert es)))
105         ((? atom? ) expr)))
106
107         
108(define (let-enum expr ax)
109  (match expr
110         (('let ((x ('if c t e))) y)
111          (let ((ax (fold let-enum ax (list c ))))
112            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
113
114         (('let bnds body)  (let-enum body (append ax bnds)))
115
116         (('if c t e)  (let-enum ax c))
117
118         ((f . es)  (fold let-enum ax es))
119
120         (else ax)))
121
122
123(define (let-elim expr)
124  (match expr
125         (('let ((x ('if c t e))) y)
126          (if (eq? x y)  y expr))
127
128         (('let bnds body) (let-elim body))
129
130         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
131
132         ((f . es)  `(,f . ,(map let-elim es)))
133
134         (else expr)))
135 
136
137(define (let-lift expr)
138  (let ((bnds (let-enum expr (list))))
139    (if (null? bnds) expr
140        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
141
142
143(define (s+ . lst)    (string-concatenate (map ->string lst)))
144(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
145(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
146(define nl "\n")
147(define (spaces n)    (list->string (list-tabulate n (lambda (x) #\space))))
148
149(define (ppf indent . lst)
150  (let ((sp (spaces indent)))
151    (for-each (lambda (x)
152                (and x (match x 
153                              ((i . x1) (if (and (number? i) (positive? i))
154                                            (for-each (lambda (x) (ppf (+ indent i) x)) x1)
155                                            (print sp (sw+ x))))
156                              (else   (print sp (if (list? x) (sw+ x) x))))))
157              lst)))
158
159
160(define (transitions-graph n open transitions state-name)
161  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
162         (g          (make-digraph n (string-append (->string n) " transitions graph")))
163         (add-node!  (g 'add-node!))
164         (add-edge!  (g 'add-edge!))
165         (out-edges  (g 'out-edges))
166         (in-edges   (g 'in-edges))
167         (node-info  (g 'node-info))
168         (node-list  (let loop ((lst (list)) (tlst transitions))
169                       (if (null? tlst)  (delete-duplicates lst eq?)
170                           (match (car tlst) 
171                                  (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
172                                   (loop (cons* s0 s1 lst) (cdr tlst)))
173                                  (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
174                                   (loop (cons* s0 s1 lst) (cdr tlst)))
175                                  (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
176                                   (loop (cons* s0 s1 lst) (cdr tlst)))
177                                  (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
178                                   (loop (cons* s0 s1 lst) (cdr tlst)))
179                                  (else
180                                   (nemo:error 'state-eqs ": invalid transition equation " 
181                                                  (car tlst) " in state complex " n))
182                                  (else (loop lst (cdr tlst)))))))
183         (node-ids      (list-tabulate (length node-list) identity))
184         (name->id-map  (zip node-list node-ids))
185         (node-subs     (fold (lambda (s ax) (subst-extend s (state-name n s) ax)) subst-empty node-list)))
186    ;; insert state nodes in the dependency graph
187    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
188    (let* ((nodes  ((g 'nodes)))
189           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
190           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes))))
191           (add-tredge (lambda (s0 s1 rexpr1 rexpr2)
192                         (let ((i   (car (alist-ref s0 name->id-map)))
193                               (j   (car (alist-ref s1 name->id-map)))
194                               (x0  (if (eq? s0 (second snode)) snex s0))
195                               (x1  (if (eq? s1 (second snode)) snex s1)))
196                           (add-edge! (list i j `(* ,(subst-convert x0 node-subs) 
197                                                    ,(subst-convert rexpr1 node-subs))))
198                           (if rexpr2 (add-edge! (list j i `(* ,(subst-convert x1 node-subs) 
199                                                               ,(subst-convert rexpr2 node-subs)))))))))
200      ;; create rate edges in the graph
201      (for-each (lambda (e) 
202                  (match e
203                         (('-> s0 s1 rexpr)  (add-tredge s0 s1 rexpr #f))
204                         ((s0 '-> s1 rexpr)  (add-tredge s0 s1 rexpr #f))
205                         (('<-> s0 s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
206                         ((s0 '<-> s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
207                         ))
208                transitions)
209
210      (list g node-subs))))
211
Note: See TracBrowser for help on using the repository browser.