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

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

Bug fixes.

File size: 8.3 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 state-lineqs
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
85         (('let bs e)
86          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) 
87             subst))
88
89         ((f . es)
90          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
91
92         ((? symbol? )  (lookup-def t subst t))
93
94         ((? atom? ) t)))
95
96(define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
97
98(define (bind ks vs e) `(let ,(zip ks vs) ,e))
99
100(define (if-convert expr)
101  (match expr 
102         (('if c t e) 
103          (let ((r (gensym "if")))
104            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
105               ,r)))
106         (('let bs e)
107          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
108         ((f . es)
109          (cons f (map if-convert es)))
110         ((? atom? ) expr)))
111
112         
113(define (let-enum expr ax)
114  (match expr
115         (('let ((x ('if c t e))) y)
116          (let ((ax (fold let-enum ax (list c ))))
117            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
118
119         (('let bnds body)  (let-enum body (append ax bnds)))
120
121         (('if c t e)  (let-enum ax c))
122
123         ((f . es)  (fold let-enum ax es))
124
125         (else ax)))
126
127
128(define (let-elim expr)
129  (match expr
130         (('let ((x ('if c t e))) y)
131          (if (eq? x y)  y expr))
132
133         (('let bnds body) (let-elim body))
134
135         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
136
137         ((f . es)  `(,f . ,(map let-elim es)))
138
139         (else expr)))
140 
141
142(define (let-lift expr)
143  (let ((bnds (let-enum expr (list))))
144    (if (null? bnds) expr
145        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
146
147
148(define (s+ . lst)    (string-concatenate (map ->string lst)))
149(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
150(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
151(define nl "\n")
152(define (spaces n)    (list->string (list-tabulate n (lambda (x) #\space))))
153
154(define (ppf indent . lst)
155  (let ((sp (spaces indent)))
156    (for-each (lambda (x)
157                (and x (match x 
158                              ((i . x1) (if (and (number? i) (positive? i))
159                                            (for-each (lambda (x) (ppf (+ indent i) x)) x1)
160                                            (print sp (sw+ x))))
161                              (else   (print sp (if (list? x) (sw+ x) x))))))
162              lst)))
163
164
165(define (transitions-graph n open transitions state-name)
166  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
167         (g          (make-digraph n (string-append (->string n) " transitions graph")))
168         (add-node!  (g 'add-node!))
169         (add-edge!  (g 'add-edge!))
170         (out-edges  (g 'out-edges))
171         (in-edges   (g 'in-edges))
172         (node-info  (g 'node-info))
173         (node-list  (let loop ((lst (list)) (tlst transitions))
174                       (if (null? tlst)  (delete-duplicates lst eq?)
175                           (match (car tlst) 
176                                  (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
177                                   (loop (cons* s0 s1 lst) (cdr tlst)))
178                                  (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
179                                   (loop (cons* s0 s1 lst) (cdr tlst)))
180                                  (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
181                                   (loop (cons* s0 s1 lst) (cdr tlst)))
182                                  (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
183                                   (loop (cons* s0 s1 lst) (cdr tlst)))
184                                  (else
185                                   (nemo:error 'state-eqs ": invalid transition equation " 
186                                                  (car tlst) " in state complex " n))
187                                  (else (loop lst (cdr tlst)))))))
188         (node-ids      (list-tabulate (length node-list) identity))
189         (name->id-map  (zip node-list node-ids))
190         (node-subs     (fold (lambda (s ax) (subst-extend s (state-name n s) ax)) subst-empty node-list)))
191    ;; insert state nodes in the dependency graph
192    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
193    (let* ((nodes  ((g 'nodes)))
194           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
195           (snex   (let ((nodes/s (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes))
196                         (sumvar  (gensym "sum")))
197                     `(let ((,sumvar ,(sum nodes/s))) (- 1 ,sumvar))))
198           (add-tredge (lambda (s0 s1 rexpr1 rexpr2)
199                         (let* ((i   (car (alist-ref s0 name->id-map)))
200                                (j   (car (alist-ref s1 name->id-map)))
201                                (x0  (if (eq? s0 (second snode)) snex s0))
202                                (x1  (if (eq? s1 (second snode)) snex s1))
203                                (ij-expr  `(* ,(subst-convert x0 node-subs) ,(subst-convert rexpr1 node-subs)))
204                                (ji-expr  (and rexpr2
205                                               `(* ,(subst-convert x1 node-subs) ,(subst-convert rexpr2 node-subs)))))
206                           (add-edge! (list i j ij-expr))
207                           (if rexpr2 (add-edge! (list j i ji-expr)))))))
208      ;; create rate edges in the graph
209      (for-each (lambda (e) 
210                  (match e
211                         (('-> s0 s1 rexpr)  (add-tredge s0 s1 rexpr #f))
212                         ((s0 '-> s1 rexpr)  (add-tredge s0 s1 rexpr #f))
213                         (('<-> s0 s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
214                         ((s0 '<-> s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
215                         ))
216                transitions)
217
218      (list g node-subs))))
219
220
221(define (state-lineqs n transitions lineqs state-name)
222  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
223         (state-list     (let loop ((lst (list)) (tlst transitions))
224                           (if (null? tlst)  (delete-duplicates lst eq?)
225                               (match (car tlst) 
226                                      (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
227                                       (loop (cons* s0 s1 lst) (cdr tlst)))
228                                      (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
229                                       (loop (cons* s0 s1 lst) (cdr tlst)))
230                                      (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
231                                       (loop (cons* s0 s1 lst) (cdr tlst)))
232                                      (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
233                                       (loop (cons* s0 s1 lst) (cdr tlst)))
234                                      (else
235                                       (nemo:error 'nemo:state-lineq ": invalid transition equation " 
236                                                   (car tlst) " in state complex " n))
237                                      (else (loop lst (cdr tlst)))))))
238         (state-subs     (fold (lambda (s ax) (subst-extend s (state-name n s) ax)) subst-empty state-list))
239         (lineqs1        (map (lambda (lineq) (match lineq ((i '= . expr) `(,i = . ,(subst-convert expr state-subs)))))
240                              lineqs)))
241    (list n lineqs1)))
Note: See TracBrowser for help on using the repository browser.