source: project/release/3/nemo/trunk/nemo-nmodl.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: 39.2 KB
Line 
1;;       
2;;
3;; An extension for translating NEMO models to NMODL descriptions.
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 environments)
25(require-extension srfi-1)
26(require-extension srfi-13)
27(require-extension utils)
28(require-extension lolevel)
29(require-extension varsubst)
30(require-extension datatype)
31
32(require-extension nemo-core)
33(require-extension nemo-utils)
34
35(define-extension nemo-nmodl)
36
37(declare
38 (lambda-lift)
39 (export  nemo:nmodl-translator))
40
41
42(define (nmodl-name s)
43  (let ((cs (string->list (->string s))))
44    (let loop ((lst (list)) (cs cs))
45      (if (null? cs) (string->symbol (list->string (reverse lst)))
46          (let* ((c (car cs))
47                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c)
48                           (else #\_))))
49            (loop (cons c1 lst) (cdr cs)))))))
50                           
51
52(define (nmodl-state-name n s)
53  (nmodl-name (s+ n s)))
54
55(define (rhsvars rhs)
56  (enum-freevars rhs (list) (list)))
57
58(define (rhsexpr expr)
59  (match expr 
60         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr x)) es)))
61         (('pow x y)  (if (and (integer? y)  (positive? y))
62                          (if (> y 1)  (let ((tmp (gensym "x")))
63                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
64                              x)
65                            expr))
66         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
67         (id          (if (symbol? id) (nmodl-name id) id))))
68
69
70(define-syntax pp
71  (syntax-rules ()
72    ((pp indent val ...) (ppf indent (quasiquote val) ...))))
73
74
75(define (letblk/NMODL e1 e2)
76  (cond ((equal? e1 (doc:empty)) (doc:group (doc:nest 2 e2)))
77        ((equal? e2 (doc:empty)) (doc:group (doc:nest 2 e1)))
78        (else (doc:connect (doc:group (doc:nest 2 e1))
79                           (doc:group (doc:nest 2 e2))))))
80       
81(define ifthen/NMODL  (doc:ifthen 0 (doc:text "if") (doc:text "") (doc:text "else")))
82(define group/NMODL   (doc:block 2 (doc:text "(") (doc:text ")")))
83(define block/NMODL   (doc:block 2 (doc:text "{") (doc:text "}")))
84(define binop/NMODL   (doc:binop 2))
85
86(define (format-op/NMODL indent op args)
87  (let ((op1 (doc:text (->string op))))
88    (let ((res
89           (if (null? args) op1
90               (match args
91                      ((x)           (doc:connect op1 x))
92                      ((x y)         (binop/NMODL x op1 y))
93                      ((x y z)       (binop/NMODL x op1 (binop/NMODL y op1 z)))
94                      (lst           (let* ((n   (length lst))
95                                            (n/2 (inexact->exact (round (/ n 2)))))
96                                       (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 
97                                                    (format-op/NMODL indent op (drop lst n/2 )))))))))
98      res)))
99
100
101(define (format-lineq-op/NMODL indent op args)
102  (let ((op1 (doc:text (->string op))))
103    (if (null? args) op1
104        (match args
105               ((x)      (doc:concat (list op1 x)))
106               ((x y)    (doc:concat (intersperse (list x op1 y) (doc:space))))
107               ((x y z)  (doc:concat (intersperse (list x op1 y op1 z) (doc:space))))
108               (lst      (let* ((n   (length lst))
109                                (n/2 (inexact->exact (round (/ n 2)))))
110                           (doc:concat 
111                            (intersperse 
112                             (list (format-lineq-op/NMODL indent op (take lst n/2 )) op1 
113                                   (format-lineq-op/NMODL indent op (drop lst n/2 )))
114                             (doc:space)))))))))
115
116(define (format-fncall/NMODL indent op args)
117  (let ((op1 (doc:text (->string op))))
118    (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args)))))
119
120(define nmodl-builtin-consts
121  `(celsius diam))
122
123(define nmodl-ops
124  `(+ - * / > < <= >= = ^))
125
126(define builtin-fns
127  `(+ - * / pow neg abs atan asin acos sin cos exp ln
128      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
129      > < <= >= = and or round ceiling floor max min
130      fpvector-ref))
131
132(define (name-normalize expr)
133  (match expr 
134         (('if c t e)  `(if ,(name-normalize c) ,(name-normalize t) ,(name-normalize e)))
135         (('let bs e)
136          `(let ,(map (lambda (b) `(,(car b) ,(name-normalize (cadr b)))) bs) ,(name-normalize e)))
137         ((f . es) 
138          (cons f (map name-normalize es)))
139         ((? symbol? ) (nmodl-name expr))
140         ((? atom? ) expr)))
141
142
143(define (canonicalize-expr/NMODL expr)
144  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
145    (let* ((expr1 (if-convert expr))
146           (expr2 (subst-convert expr1 subst-empty))
147           (expr3 (let-lift expr2))
148           (expr4 (name-normalize expr3)))
149      expr4)))
150
151
152(define (format-expr/NMODL indent expr . rest) 
153  (let-optionals rest ((rv #f))
154   (let ((indent+ (+ 2 indent)))
155    (match expr
156       (('let bindings body)
157        (letblk/NMODL
158         (fold-right 
159           (lambda (x ax)
160             (let ((res
161                    (letblk/NMODL
162                     (match (second x)
163                            (('if c t e)
164                             (ifthen/NMODL
165                              (group/NMODL (format-expr/NMODL indent c))
166                              (block/NMODL (format-expr/NMODL indent t (first x)))
167                              (block/NMODL (format-expr/NMODL indent e (first x)))))
168                            (else
169                             (format-op/NMODL indent+ " = "
170                                              (list (format-expr/NMODL indent (first x) )
171                                                    (format-expr/NMODL indent (second x))))))
172                     ax)))
173               res
174               ))
175           (doc:empty) bindings)
176         (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
177           (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
178               body1))))
179       
180       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))
181
182       ((op . rest) 
183       (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
184         (let ((fe
185                (if (member op nmodl-ops)
186                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
187                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
188                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
189                      (case op
190                        ((/) 
191                         (format-op/NMODL indent op 
192                                          (map (lambda (x) 
193                                                 (let ((fx (format-expr/NMODL indent+ x)))
194                                                   (if (or (symbol? x) (number? x)) fx
195                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
196                        ((*) 
197                         (format-op/NMODL indent op 
198                                          (map (lambda (x) 
199                                                 (let ((fx (format-expr/NMODL indent+ x)))
200                                                   (if (or (symbol? x) (number? x)) fx
201                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
202                       
203                        ((^) 
204                         (format-op/NMODL indent op 
205                                          (map (lambda (x) 
206                                                 (let ((fx (format-expr/NMODL indent+ x)))
207                                                   (if (or (symbol? x)  (number? x)) fx
208                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
209                       
210                        (else
211                         (format-op/NMODL indent op 
212                                          (map (lambda (x) 
213                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
214                   
215                    (let ((op (case op ((neg) '-) (else op))))
216                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
217           (if rv 
218               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
219               fe))))
220     
221      (else  (let ((fe (doc:text (->string expr))))
222               (if rv 
223                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
224                   fe)))))))
225               
226
227         
228(define (expr->string/NMODL x . rest)
229  (let-optionals rest ((rv #f) (width 72))
230    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
231 
232
233(define (format-lineq/NMODL indent expr . rest) 
234  (let-optionals rest ((rv #f))
235   (let ((indent+ (+ 2 indent)))
236    (match expr
237       (('let bindings body)
238        (letblk/NMODL
239         (fold-right 
240           (lambda (x ax)
241             (letblk/NMODL
242              (match (second x)
243                     (('if c t e)
244                      (ifthen/NMODL
245                       (group/NMODL (format-lineq/NMODL indent c))
246                       (block/NMODL (format-lineq/NMODL indent t (first x)))
247                       (block/NMODL (format-lineq/NMODL indent e (first x)))))
248                     (else
249                      (format-lineq-op/NMODL indent+ " = "
250                                       (list (format-lineq/NMODL indent (first x) )
251                                             (format-lineq/NMODL indent (second x))))))
252              ax))
253           (doc:empty) bindings)
254         (let ((body1 (doc:nest indent (format-lineq/NMODL indent body))))
255           (if rv  (format-lineq-op/NMODL indent " = " (list (format-lineq/NMODL indent+ rv ) body1))
256               body1))))
257       
258       (('if . rest) (error 'format-lineq/NMODL "invalid if statement " expr))
259
260       ((op . rest) 
261        (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
262          (let ((fe
263                (if (member op nmodl-ops)
264                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
265                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
266                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
267                      (case op
268                        ((/) 
269                         (format-lineq-op/NMODL indent op 
270                                          (map (lambda (x) 
271                                                 (let ((fx (format-lineq/NMODL indent+ x)))
272                                                   (if (or (symbol? x) (number? x)) fx
273                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
274                        ((*) 
275                         (format-lineq-op/NMODL indent op 
276                                          (map (lambda (x) 
277                                                 (let ((fx (format-lineq/NMODL indent+ x)))
278                                                   (if (or (symbol? x) (number? x)) fx
279                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
280                       
281                        ((^) 
282                         (format-lineq-op/NMODL indent op 
283                                          (map (lambda (x) 
284                                                 (let ((fx (format-lineq/NMODL indent+ x)))
285                                                   (if (or (symbol? x)  (number? x)) fx
286                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
287                       
288                        (else
289                         (format-lineq-op/NMODL indent op 
290                                          (map (lambda (x) 
291                                                 (let ((fx (format-lineq/NMODL indent+ x))) fx)) rest)))))
292                   
293                    (case op
294                      ((neg) (format-lineq-op/NMODL indent '* (map (lambda (x) (format-lineq/NMODL indent+ x)) 
295                                                             (cons "(-1)" rest))))
296                      (else  (format-fncall/NMODL indent op (map (lambda (x) (format-lineq/NMODL indent+ x)) 
297                                                                 rest)))))))
298
299           (if rv (format-lineq-op/NMODL indent " = " (list (format-lineq/NMODL indent+ rv ) fe)) fe))))
300     
301      (else  (let ((fe (doc:text (->string expr))))
302               (if rv 
303                   (format-lineq-op/NMODL indent " = " (list (format-lineq/NMODL indent+ rv ) fe))
304                   fe)))))))
305               
306
307         
308(define (lineq->string/NMODL x val . rest)
309  (let-optionals rest ((width 72))
310    (s+ "~ " (sdoc->string (doc:format width (format-lineq/NMODL 2 x #f))) 
311        " = " (number->string val))))
312 
313         
314(define (conserve-lineq->string/NMODL x val . rest)
315  (let-optionals rest ((width 72))
316    (s+ "CONSERVE " (sdoc->string (doc:format width (format-lineq/NMODL 2 x #f))) 
317        " = " (number->string val))))
318 
319
320(define (make-define-fn table? min-v max-v with depend)
321  (lambda (indent n proc)
322    (let ((lst (procedure-data proc))
323          (indent+ (+ 2 indent)))
324      (let ((rt       (lookup-def 'rt lst))
325            (formals  (lookup-def 'formals lst))
326            (vars     (lookup-def 'vars lst))
327            (body     (lookup-def 'body lst)))
328        (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" ))
329        (let* ((body1 (canonicalize-expr/NMODL (rhsexpr body)))
330               (lbs   (enum-bnds body1 (list))))
331          (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " lbs))))
332          (if (and table? min-v max-v with)
333              (match vars
334                     (('v)  (pp indent+ (TABLE ,@(if depend `(DEPEND ,depend) `(""))
335                                               FROM ,min-v TO ,max-v WITH ,with)))
336                     (else  (void))))
337          (pp indent+ ,(expr->string/NMODL body1 n)))
338        (pp indent "}"))) 
339    ))
340
341(define (define-state indent n)
342  (pp indent (,n)))
343
344(define (expeuler dt name rhs)
345  (define (isname? x) (equal? x name))
346  (let ((res 
347         (match rhs
348                ((or ('- A ('* B (and x (? isname?))))
349                     ('+ ('neg ('* B (and x (? isname?)))) A))
350                 (let ((xexp (string->symbol (s+ x 'exp))))
351                   `(let ((,xexp (exp (* (neg ,B) ,dt))))
352                      (+ (* ,x ,xexp)  (* (- 1 ,xexp) (/ ,A ,B))))))
353
354                ((or ('- A ('* (and x (? isname?)) . B))
355                     ('+ ('neg ('* (and x (? isname?)) . B)) A))
356                 (let ((xexp (string->symbol (s+ x 'exp)))
357                       (B1   (if (null? (cdr B)) (car B) `(* ,@B))))
358                   `(let ((,xexp (exp (* (neg ,B1) ,dt))))
359                      (+ (* ,x ,xexp)  (* (- 1 ,xexp) (/ ,A ,B1))))))
360               
361                (('+ ('neg ('* (and x1 (? isname?)) Alpha))
362                     ('* ('- 1 (and x2 (? isname?))) Beta))
363                 (let ((A  Alpha)
364                       (B  `(+ ,Alpha ,Beta)))
365                   (let ((xexp (string->symbol (s+ x1 'exp))))
366                     `(let ((,xexp (exp (* (neg ,B) ,dt))))
367                        (+ (* ,x1 ,xexp) (* (- 1 ,xexp) (/ ,A ,B)))))))
368               
369                (('let bnds body)
370                 `(let ,bnds ,(expeuler dt name body)))
371               
372                (else (nemo:error 'nemo:expeuler ": unable to rewrite equation " rhs 
373                                  "in exponential Euler form")))))
374
375    res))
376 
377
378(define (state-eqs n initial open transitions power method)
379  (match-let (((g  node-subs)  (transitions-graph n open transitions nmodl-state-name)))
380     (let* ((out-edges  (g 'out-edges))
381            (in-edges   (g 'in-edges))
382            (nodes   ((g 'nodes)))
383            (snode   (find (lambda (s) (not (eq? (second s) open))) nodes)))
384       ;; generate differential equations for each state in the transitions system
385      (let ((eqs    (fold (lambda (s ax) 
386                            (if (= (first snode) (first s) ) ax
387                                (let* ((out   (out-edges (first s)))
388                                       (in    (in-edges (first s)))
389                                       (open? (eq? (second s) open))
390                                       (name  (nmodl-name (lookup-def (second s) node-subs))))
391                                  (let* ((rhs1  (cond ((and (not (null? out)) (not (null? in)))
392                                                       `(+ (neg ,(sum (map third out)))
393                                                           ,(sum (map third in))))
394                                                      ((and (not (null? out)) (null? in))
395                                                       `(neg ,(sum (map third out))))
396                                                      ((and (null? out) (not (null? in)))
397                                                       (sum (map third in)))))
398                                         (fbody0 (rhsexpr rhs1)))
399                                    (case method
400                                      ((expeuler)  (cons (list name (canonicalize-expr/NMODL (expeuler 'dt name fbody0))) 
401                                                         ax))
402                                      (else        (cons (list (s+ name "'") (canonicalize-expr/NMODL fbody0))
403                                                         ax))
404                                      )))))
405                          (list) nodes)))
406        eqs))))
407           
408       
409
410(define (kstate-eqs n initial open transitions power)
411  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
412         (state-list     (let loop ((lst (list)) (tlst transitions))
413                           (if (null? tlst)  (delete-duplicates lst eq?)
414                               (match (car tlst) 
415                                      (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
416                                       (loop (cons* s0 s1 lst) (cdr tlst)))
417                                      (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
418                                       (loop (cons* s0 s1 lst) (cdr tlst)))
419                                      (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
420                                       (loop (cons* s0 s1 lst) (cdr tlst)))
421                                      (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
422                                       (loop (cons* s0 s1 lst) (cdr tlst)))
423                                      (else
424                                       (nemo:error 'nemo:nmodl-kstate-eqs ": invalid transition equation " 
425                                                   (car tlst) " in state complex " n))
426                                      (else (loop lst (cdr tlst)))))))
427         (state-subs     (fold (lambda (s ax) (subst-extend s (nmodl-state-name n s) ax)) subst-empty state-list)))
428    ;; generate kinetic equations for each edge in the transitions system
429    (list n
430          (map
431           (lambda (e) 
432             (match e
433                    (('-> s0 s1 rexpr)
434                     (let ((i  (lookup-def s0 state-subs))
435                           (j  (lookup-def s1 state-subs)))
436                       `(-> ,i ,j ,(subst-convert rexpr state-subs))))
437                   
438                    ((s0 '-> s1 rexpr)
439                     (let ((i  (lookup-def s0 state-subs))
440                           (j  (lookup-def s1 state-subs)))
441                       `(-> ,i ,j ,(subst-convert rexpr state-subs))))
442                   
443                    (('<-> s0 s1 rexpr1 rexpr2)
444                     (let ((i  (lookup-def s0 state-subs))
445                           (j  (lookup-def s1 state-subs)))
446                       `(<-> ,i ,j ,(subst-convert rexpr1 state-subs) ,(subst-convert rexpr2 state-subs))))
447                   
448                    ((s0 '<-> s1 rexpr1 rexpr2)
449                     (let ((i  (lookup-def s0 state-subs))
450                           (j  (lookup-def s1 state-subs)))
451                       `(<-> ,i ,j ,(subst-convert rexpr1 state-subs) ,(subst-convert rexpr2 state-subs))))
452                   
453                   
454                    (else (nemo:error 'nemo:nmodl-kstate-eqs ": invalid transition equation " 
455                                      e " in state complex " n))))
456           transitions))))
457       
458
459
460(define (state-init n init)
461  (let* ((init  (rhsexpr init))
462         (init1 (canonicalize-expr/NMODL init)))
463    (list (nmodl-name n) init1)))
464
465
466(define (state-lineqs n transitions lineqs)
467  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
468         (state-list     (let loop ((lst (list)) (tlst transitions))
469                           (if (null? tlst)  (delete-duplicates lst eq?)
470                               (match (car tlst) 
471                                      (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
472                                       (loop (cons* s0 s1 lst) (cdr tlst)))
473                                      (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
474                                       (loop (cons* s0 s1 lst) (cdr tlst)))
475                                      (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
476                                       (loop (cons* s0 s1 lst) (cdr tlst)))
477                                      (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
478                                       (loop (cons* s0 s1 lst) (cdr tlst)))
479                                      (else
480                                       (nemo:error 'nemo:state-lineq ": invalid transition equation " 
481                                                   (car tlst) " in state complex " n))
482                                      (else (loop lst (cdr tlst)))))))
483         (state-subs     (fold (lambda (s ax) (subst-extend s (nmodl-state-name n s) ax)) subst-empty state-list))
484         (lineqs1        (map (lambda (lineq) (match lineq ((i '= . expr) `(,i = . ,(subst-convert expr state-subs)))))
485                              lineqs)))
486    (list (nmodl-name n) lineqs1)))
487
488(define (asgn-eq n rhs)
489  (let* ((fbody   (rhsexpr rhs))
490         (fbody1  (canonicalize-expr/NMODL fbody)))
491    (list (nmodl-name n) fbody1)))
492
493
494(define (stcomp-eq n open transitions)
495  (list (nmodl-name n) (nmodl-name (nmodl-state-name n open))))
496
497
498(define (poset->asgn-eq-defs poset sys)
499  (fold-right
500   (lambda (lst ax)
501     (fold  (lambda (x ax) 
502              (match-let (((i . n)  x))
503                         (let ((en (environment-ref sys n)))
504                           (if (nemo:quantity? en)
505                               (cases nemo:quantity en
506                                      (ASGN  (name value rhs) (cons (asgn-eq name rhs) ax))
507                                      (else  ax))
508                               ax))))
509            ax lst))
510   (list) poset))
511
512
513(define (poset->state-eq-defs poset sys kinetic method)
514  (fold-right
515   (lambda (lst ax)
516     (fold  (lambda (x ax) 
517              (match-let (((i . n)  x))
518                         (let ((en (environment-ref sys n)))
519                           (if (and (not (member n kinetic)) (nemo:quantity? en))
520                               (cases nemo:quantity en
521                                      (TSCOMP  (name initial open transitions conserve power) 
522                                               (append (state-eqs name initial open transitions power method) ax))
523                                      (else  ax))
524                               ax))))
525            ax lst))
526   (list) poset))
527
528
529(define (poset->kstate-eq-defs poset sys kinetic)
530  (fold-right
531   (lambda (lst ax)
532     (fold  (lambda (x ax) 
533              (match-let (((i . n)  x))
534                         (let ((en (environment-ref sys n)))
535                           (if (and (member n kinetic) (nemo:quantity? en))
536                               (cases nemo:quantity en
537                                      (TSCOMP  (name initial open transitions conserve power) 
538                                               (cons (kstate-eqs name initial open transitions power) ax))
539                                      (else  ax))
540                               ax))))
541            ax lst))
542   (list) poset))
543
544
545(define (poset->stcomp-eq-defs poset sys)
546  (fold-right
547   (lambda (lst ax)
548     (fold  (lambda (x ax) 
549              (match-let (((i . n)  x))
550                         (let ((en (environment-ref sys n)))
551                           (if (nemo:quantity? en)
552                               (cases nemo:quantity en
553                                      (TSCOMP  (name initial open transitions conserve power) 
554                                               (cons (stcomp-eq name open transitions) ax))
555                                      (else  ax))
556                               ax))))
557            ax lst))
558   (list) poset))
559
560(define (poset->state-init-defs poset sys)
561  (fold-right
562   (lambda (lst ax)
563     (fold  (lambda (x ax) 
564              (match-let (((i . n)  x))
565                         (let ((en (environment-ref sys n)))
566                           (if (nemo:quantity? en)
567                               (cases nemo:quantity en
568                                      (TSCOMP  (name initial open transitions conserve power)
569                                               (if (nemo:rhs? initial)
570                                                   (cons* (state-init name initial) 
571                                                          (state-init (nmodl-state-name name open) name) ax) 
572                                                   ax))
573                                      (else  ax))
574                               ax))))
575            ax lst))
576   (list) poset))
577
578
579(define (poset->state-init-eq-defs poset sys)
580  (fold-right
581   (lambda (lst ax)
582     (fold  (lambda (x ax) 
583              (match-let (((i . n)  x))
584                         (let ((en (environment-ref sys n)))
585                           (if (nemo:quantity? en)
586                               (cases nemo:quantity en
587                                      (TSCOMP (name initial open transitions conserve power)
588                                              (if (and (list? initial) (every nemo:lineq? initial))
589                                                  (cons (state-lineqs name transitions initial) ax) 
590                                                  ax))
591                                      (else  ax))
592                               ax))))
593            ax lst))
594   (list) poset))
595
596
597(define (poset->state-conserve-eq-defs poset sys)
598  (fold-right
599   (lambda (lst ax)
600     (fold  (lambda (x ax) 
601              (match-let (((i . n)  x))
602                         (let ((en (environment-ref sys n)))
603                           (if (nemo:quantity? en)
604                               (cases nemo:quantity en
605                                      (TSCOMP (name initial open transitions conserve power)
606                                              (if (and (list? conserve) (every nemo:lineq? conserve))
607                                                  (cons (state-lineqs name transitions conserve) ax) 
608                                                  ax))
609                                      (else  ax))
610                               ax))))
611            ax lst))
612   (list) poset))
613
614
615(define (find-locals defs)
616  (concatenate (map (lambda (def) (match def (('let bnds _) (map first bnds)) (else (list)))) defs)))
617
618
619(define (state-power sys n)
620  (let ((en (environment-ref sys n)))
621    (if (nemo:quantity? en)
622        (cases nemo:quantity en
623               (TSCOMP  (name initial open transitions conserve power)  power)
624               (else  #f))  #f)))
625
626
627(define (bucket-partition p lst)
628  (let loop ((lst lst) (ax (list)))
629    (if (null? lst) ax
630        (let ((x (car lst)))
631          (let bkt-loop ((old-bkts ax) (new-bkts (list)))
632            (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts))
633                (if (p x (caar old-bkts ))
634                    (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts)))
635                    (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts)))))))))
636
637
638(define (collect-epools sys)
639   (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref sys (nemo-intern 'dispatch))))
640      (let recur ((comp-name (nemo-intern 'toplevel)) (ax (list)))
641        (let* ((comp-symbols   ((dis 'component-symbols)   sys comp-name))
642               (subcomps       ((dis 'component-subcomps)  sys comp-name)))
643          (fold recur 
644                (fold (lambda (sym ax)
645                        (let ((en (environment-ref sys sym)))
646                          (match en
647                                 ((or (('decaying 'pool)  ('name (? symbol? ion)) . alst)
648                                      (('decaying-pool)   ('name (? symbol? ion)) . alst))
649                                  (cons (list ion alst) ax))
650                                 (else ax)))) ax comp-symbols)
651                (map third subcomps))))))
652
653
654(define (nemo:nmodl-translator sys . rest)
655  (define (cid x)  (second x))
656  (define (cn x)   (first x))
657  (let-optionals rest ((method 'cnexp) (table? #f) (min-v -100) (max-v 100) (step 0.5) 
658                       (depend #f)  (kinetic (list)) (linear? #f))
659  (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref sys (nemo-intern 'dispatch))))
660    (let ((imports  ((dis 'imports)  sys))
661          (exports  ((dis 'exports)  sys)))
662      (let* ((indent      0)
663             (indent+     (+ 2 indent ))
664             (table-with  (and table? (inexact->exact (round (/ (abs (- max-v min-v)) step)))))
665             (eval-const  (dis 'eval-const))
666             (sysname     (nmodl-name ((dis 'sysname) sys)))
667             (deps*       ((dis 'depgraph*) sys))
668             (consts      ((dis 'consts)  sys))
669             (asgns       ((dis 'asgns)   sys))
670             (states      ((dis 'states)  sys))
671             (kinetic     (if (eq? kinetic 'all) (delete-duplicates (map first states)) kinetic))
672             (stcomps     ((dis 'stcomps) sys))
673             (defuns      ((dis 'defuns)  sys))
674             (components  ((dis 'components) sys))
675             (ionchs      (filter-map (match-lambda ((name 'ion-channel id) (list name id)) (else #f)) components))
676             (epools      (collect-epools sys)))
677
678        (match-let (((state-list asgn-list g) deps*))
679         (let* ((poset             (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
680                (asgn-eq-defs      (poset->asgn-eq-defs poset sys))
681                (perm-ions         (fold (lambda (ionch ax) 
682                                           (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
683                                                  (perm      (lookup-def 'permeating-substance subcomps)))
684                                             (if perm 
685                                                 (case (cn perm)
686                                                   ((non-specific)   
687                                                    (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
688                                                           (i    (nmodl-name 'i))
689                                                           (e    (nmodl-name 'e)))
690                                                      (cons `(,(cn perm) ,i ,e ,erev) ax)))
691                                                   (else (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
692                                                                (i    (nmodl-name (s+ 'i (cn perm))))
693                                                                (e    (nmodl-name (s+ 'e (cn perm)))))
694                                                           (cons `(,(cn perm) ,i ,e ,erev) ax))))
695                                                 ax)))
696                                         (list) ionchs))
697               (acc-ions           (fold (lambda (ionch ax) 
698                                           (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
699                                                  (acc   (lookup-def 'accumulating-substance subcomps))
700                                                  (i     (and acc (nmodl-name (s+ 'i (cn acc)))))
701                                                  (in    (and acc (nmodl-name (s+ (cn acc) 'i))))
702                                                  (out   (and acc (nmodl-name (s+ (cn acc) 'o)))))
703                                             (if acc  (cons `(,(cn acc) ,i ,in ,out) ax) ax)))
704                                         (list) ionchs))
705               (pool-ions          (map (lambda (ep)
706                                          (let ((ion (car ep)))
707                                            `(,(nmodl-name ion) ,(nmodl-name (s+ 'i ion)) ,(nmodl-name (s+ ion 'i)))))
708                                        epools))
709               (i-gates           (fold (lambda (ionch ax) 
710                                           (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
711                                                  (i-gate-comp    (lookup-def 'binary-gate subcomps)))
712                                             (if i-gate-comp
713                                                 (let* ((i-gate-exps  ((dis 'component-exports) sys (cid i-gate-comp)))
714                                                        (asgn-names   asgns)
715                                                        (i-gate-var   (find (lambda (x) (member x asgn-names)) 
716                                                                            i-gate-exps)))
717                                                   (if (not i-gate-var)
718                                                       (nemo:error 'nemo:nmodl-translator 
719                                                                   ": binary gate in channel " (cn ionch)
720                                                                   " must export an assignment"))
721                                                   (cons (list i-gate-var ) ax))
722                                                 ax)))
723                                         (list) ionchs))
724               (has-kinetic?       (or (not (null? (filter (lambda (x) (member (car x) kinetic)) states)))))
725               (has-ode?           (or (not (null? (filter (lambda (x) (not (member (car x) kinetic))) states)))
726                                       (not (null? pool-ions)))))
727
728
729           (for-each
730            (lambda (a)
731              (let ((acc-ion   (car a)))
732                (if (assoc acc-ion perm-ions)
733                    (nemo:error 'nemo:nmodl-translator 
734                                ": ion species " acc-ion " cannot be declared as both accumulating and permeating"))))
735            acc-ions)
736
737           (for-each
738            (lambda (p)
739              (let ((pool-ion  (car p)))
740                (if (assoc pool-ion perm-ions)
741                    (nemo:error 'nemo:nmodl-translator 
742                                ": ion species " pool-ion " cannot be declared as both pool and permeating"))))
743            pool-ions)
744
745           (pp indent ,nl (TITLE ,sysname))
746           
747           (pp indent ,nl (NEURON "{"))
748           (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
749
750           (for-each (lambda (x)
751                       (case (first x)
752                         ((non-specific) 
753                          (pp indent+ (RANGE ,(third x))
754                              (NONSPECIFIC_CURRENT ,(second x))))
755                         (else
756                          (pp indent+ (RANGE ,(second x))
757                              (USEION ,(first x) READ ,(third x) WRITE ,(second x))))))
758                     (delete-duplicates perm-ions (lambda (x y) (eq? (car x) (car y)))))
759
760           (for-each (lambda (acc-ion)
761                       (let ((pool-ion (assoc (first acc-ion) pool-ions)))
762                         (if pool-ion
763                             (pp indent+ (RANGE ,(second acc-ion))
764                                 (USEION ,(first acc-ion) 
765                                         READ  ,(sl\ ", " (list (third acc-ion) (fourth acc-ion) (second pool-ion)))
766                                         WRITE ,(sl\ ", " (list (second acc-ion) (third pool-ion )))))
767                             (pp indent+ (RANGE ,(second acc-ion))
768                                 (USEION ,(first acc-ion) 
769                                         READ ,(sl\ ", "  (list (third acc-ion) (fourth acc-ion) ))
770                                         WRITE ,(second acc-ion))))))
771                       (delete-duplicates acc-ions (lambda (x y) (eq? (car x) (car y)))))
772
773           (let* ((const-names   (map first consts))
774                  (is-const?     (lambda (x) (member x const-names)))
775                  (range-consts  (delete-duplicates 
776                                  (fold (lambda (def ax) 
777                                          (let* ((rhs   (second def))
778                                                 (vars  (rhsvars rhs)))
779                                            (append (filter is-const? vars) ax)))
780                                        (list) asgn-eq-defs ))))
781             (if (not (null? range-consts)) (pp indent+ (RANGE ,(sl\ ", " range-consts)))))
782           
783           
784           (pp indent "}")
785           
786           
787           (pp indent ,nl (PARAMETER "{"))
788           (let* ((const-defs (filter-map
789                               (lambda (nv)
790                                 (and (not (member (first nv) nmodl-builtin-consts))
791                                      (let ((v1 (canonicalize-expr/NMODL (second nv))))
792                                        (list (first nv) v1))))
793                                   consts))
794                  (locals  (find-locals (map second const-defs))))
795             (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
796             (for-each (lambda (def)
797                         (let ((n (first def)) (b (second def)))
798                           (pp indent+ ,(expr->string/NMODL b n)))) const-defs)
799             (for-each (lambda (ep)
800                         (let* ((ep-name     (first ep))
801                                (ep-props    (second ep))
802                                (init-expr   (lookup-def 'initial ep-props))
803                                (temp-expr   (lookup-def 'temp-adj ep-props))
804                                (beta-expr   (lookup-def 'beta ep-props))
805                                (depth-expr  (lookup-def 'depth ep-props))
806                                (init-name   (nmodl-name (s+ ep-name '-init)))
807                                (temp-name   (nmodl-name (s+ ep-name '-temp-adj)))
808                                (beta-name   (nmodl-name (s+ ep-name '-beta)))
809                                (depth-name  (nmodl-name (s+ ep-name '-depth))))
810                           (if (or (not beta-expr) (not depth-expr) (not init-expr))
811                               (nemo:error 'nemo:nmodl-translator 
812                                           ": ion pool " ep-name " requires initial value, depth and beta parameters"))
813                           (let ((temp-val  (and temp-expr (eval-const sys temp-expr)))
814                                 (init-val  (eval-const sys init-expr))
815                                 (beta-val  (eval-const sys beta-expr))
816                                 (depth-val (eval-const sys depth-expr)))
817                             (pp indent+ ,(expr->string/NMODL init-val init-name))
818                             (pp indent+ ,(expr->string/NMODL temp-val temp-name))
819                             (pp indent+ ,(expr->string/NMODL beta-val beta-name))
820                             (pp indent+ ,(expr->string/NMODL depth-val depth-name)))))
821                       epools))
822           (case method  ((expeuler)  (pp indent+ dt)))
823           (pp indent "}")
824           
825           (let* ((define-fn (make-define-fn table? min-v max-v table-with depend)))
826             (for-each (lambda (fndef) 
827                         (if (not (member (car fndef) builtin-fns))
828                             (apply define-fn (cons indent fndef)))) 
829                       defuns))
830           
831           
832           (pp indent ,nl (STATE "{"))
833           (for-each (lambda (st)
834                       (if (pair? st) 
835                           (apply define-state (list indent+ (nmodl-state-name (first st) (second st))))
836                           (apply define-state (list indent+ st))))
837                     states)
838           (for-each (lambda (st) (apply define-state (list indent+ st)))
839                     stcomps)
840           (for-each (lambda (pool-ion) (apply define-state (list indent+ (first pool-ion))))
841                     pool-ions)
842           (pp indent "}")
843           
844           (pp indent ,nl (ASSIGNED "{"))
845           (let* ((asgns0 (append asgns (map first imports) 
846                                  (map second perm-ions) (map third perm-ions)
847                                  (map second acc-ions)  (map fourth acc-ions)
848                                  (map second pool-ions) (map third pool-ions)
849                                  ))
850                  (asgns1 (delete-duplicates asgns0)))
851             (for-each (lambda (x) (pp indent+ ,(nmodl-name x))) asgns1)
852             (pp indent "}"))
853           
854           (if (not (null? asgns))
855               (begin
856                 (pp indent ,nl (PROCEDURE rates () "{"))
857                 (let ((locals    (find-locals (map second asgn-eq-defs))) )
858                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))))
859#|
860                 (if (and table? min-v max-v table-with)
861                     (pp indent+ (TABLE ,(sl\ ", " (map first asgn-eq-defs))
862                                  ,@(if depend `(DEPEND ,depend) `(""))
863                                  FROM ,min-v TO ,max-v WITH ,table-with)))
864|#
865
866                 (for-each (lambda (def)
867                             (let ((n (nmodl-name (first def)) )
868                                   (b (second def)))
869                               (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs)
870                 (pp indent "}")))
871             
872           (if (not (null? stcomps))
873               (begin
874                 (pp indent ,nl (PROCEDURE stcomps () "{"))
875                 (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
876                        (locals    (find-locals (map second eq-defs))) )
877                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
878                   (for-each (lambda (def)
879                               (let ((n (first def)) (b (second def)))
880                                 (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
881                 
882                 (pp indent "}")))
883
884           (if (not (null? pool-ions))
885               (begin
886                 (pp indent ,nl (PROCEDURE pools () "{"))
887                 (for-each (lambda (pool-ion)
888                             (pp indent+ (,(third pool-ion) = ,(first pool-ion))))
889                           pool-ions)
890                 (pp indent "}")))
891
892           (pp indent ,nl (BREAKPOINT "{"))
893           (let* ((i-eqs (filter-map
894                          (lambda (ionch) 
895
896                            (let* ((label     (first ionch))
897                                   (n         (second ionch))
898                                   (subcomps  ((dis 'component-subcomps) sys n))
899                                   (acc       (lookup-def 'accumulating-substance subcomps))
900                                   (perm      (lookup-def 'permeating-substance subcomps))
901                                   (permqs    (and perm ((dis 'component-exports) sys (cid perm))))
902                                   (pore      (lookup-def 'pore subcomps))
903                                   (gate      (lookup-def 'gate subcomps))
904                                   (sts       (and gate ((dis 'component-exports) sys (cid gate)))))
905
906                              (if (not pore)
907                                  (nemo:error 'nemo:nmodl-translator ": ion channel definition " label
908                                              "lacks any pore components"))
909
910                              (cond ((and perm pore gate)
911                                     (case (cn perm)
912                                       ((non-specific)
913                                        (let* ((i     (nmodl-name 'i))
914                                               (e     (car permqs))
915                                               (gmax  (car ((dis 'component-exports) sys (cid pore))))
916                                               (pwrs  (map (lambda (n) (state-power sys n)) sts))
917                                               (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))
918                                               (gion  `(* ,gmax ,@sptms)))
919                                          (list i e gion)))
920                                       (else
921                                        (let* ((i     (nmodl-name (s+ 'i (cn perm))))
922                                               (e     (nmodl-name (s+ 'e (cn perm))))
923                                               (gmax  (car ((dis 'component-exports) sys (cid pore))))
924                                               (pwrs  (map (lambda (n) (state-power sys n)) sts))
925                                               (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))
926                                               (gion  `(* ,gmax ,@sptms)))
927                                          (list i e gion)))))
928
929                                    ((and perm pore)
930                                     (case (cn perm)
931                                       ((non-specific)
932                                        (let* ((i     (nmodl-name 'i))
933                                               (e     (car permqs))
934                                               (gmax  (car ((dis 'component-exports) sys (cid pore)))))
935                                          (list i e gmax)))
936                                       (else
937                                        (nemo:error 'nemo:nmodl-translator ": ion channel definition " label
938                                                    "lacks permeating-substance or accumulating-substance "
939                                                    "component"))))
940
941                                      ((and acc pore gate)
942                                       (let* ((i     (nmodl-name (s+ 'i (cn acc))))
943                                              (gmax  (car ((dis 'component-exports) sys (cid pore))))
944                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
945                                              (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))
946                                              (gion  `(* ,gmax ,@sptms)))
947                                         (list i #f gion)))
948
949                                      (else (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " 
950                                                        label))
951                                      )))
952                          ionchs))
953                  (i-eqs  (fold  (lambda (i-gate ax) 
954                                   (let ((i-gate-var (first i-gate)))
955                                     (cons (list (nmodl-name 'i) #f i-gate-var) ax)))
956                                 i-eqs i-gates))
957                  (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
958                  (i-eqs  (fold (lambda (b ax) 
959                                  (match b 
960                                         ((and ps ((i e gion) . rst))
961                                          (let loop ((ps ps) (summands (list)))
962                                            (if (null? ps)
963                                                (let* ((sum0  (sum summands))
964                                                       (sum1  (rhsexpr sum0))
965                                                       (sum2  (canonicalize-expr/NMODL sum1)))
966                                                  (cons (list i sum2) ax))
967                                                (match-let (((i e gion) (car ps)))
968                                                  (loop (cdr ps) (cons (if e `(* ,gion (- v ,e)) gion) summands))))))
969                                           
970                                         ((i e gion)
971                                          (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
972                                                 (expr1  (canonicalize-expr/NMODL expr0)))
973                                            (cons (list i expr1) ax)))
974                                         
975                                         (else ax)))
976                                (list) i-bkts))
977                  (locals (find-locals (map second i-eqs))))
978             (if (not (null? locals))    (pp indent+ (LOCAL ,(sl\ ", " locals))))
979             (if (not (null? asgns))     (pp indent+ (rates ())))
980             (if has-ode?
981                 (case method
982                   ((#f expeuler)  (pp indent+ (SOLVE states)))
983                   (else           (pp indent+ (SOLVE states METHOD ,method)))))
984             (if has-kinetic?   (pp indent+  (SOLVE kstates METHOD sparse)))
985             (if (not (null? stcomps))   (pp indent+ (stcomps ())))
986             (if (not (null? pool-ions)) (pp indent+ (pools ())))
987             (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
988             (pp indent "}"))
989           
990           (if has-ode?
991               (let* ((state-eq-defs  (reverse (poset->state-eq-defs poset sys kinetic method)))
992                      (pool-eq-defs
993                       (map (lambda (ep)
994                              (let* ((ep-name     (first ep))
995                                     (pool-ion    (assoc ep-name pool-ions))
996                                     (i-name      (second pool-ion))
997                                     (init-name   (nmodl-name (s+ ep-name '-init)))
998                                     (temp-name   (nmodl-name (s+ ep-name '-temp-adj)))
999                                     (beta-name   (nmodl-name (s+ ep-name '-beta)))
1000                                     (depth-name  (nmodl-name (s+ ep-name '-depth)))
1001                                     (rhs         `(let ((F 96485.0))
1002                                                     (- (/ (neg ,i-name) (* 2 F ,init-name ,depth-name)) 
1003                                                        (* ,ep-name ,beta-name . 
1004                                                           ,(if temp-name (list temp-name) (list)))))))
1005                                (case method
1006                                  ((expeuler)  `(,ep-name ,(canonicalize-expr/NMODL (expeuler 'dt ep-name rhs))))
1007                                  (else        `(,(s+ ep-name "'") ,(canonicalize-expr/NMODL rhs))))))
1008                            epools))
1009                      (eq-defs (append pool-eq-defs state-eq-defs))
1010                      (locals  (find-locals (map second eq-defs))))
1011                 (case method
1012                   ((expeuler) (pp indent ,nl (PROCEDURE states () "{")))
1013                   (else       (pp indent ,nl (DERIVATIVE states "{"))))
1014                 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
1015                 (for-each (lambda (def)
1016                             (let ((n (first def)) (b (second def)))
1017                               (pp indent+ ,(expr->string/NMODL b n)))) 
1018                           eq-defs)
1019                 (pp indent "}")))
1020
1021           (if has-kinetic?
1022               (begin
1023                 (pp indent ,nl (KINETIC kstates "{"))
1024                 (let* ((keq-defs          (poset->kstate-eq-defs poset sys kinetic))
1025                        (locals            (concatenate (find-locals (map third (map second keq-defs)))))
1026                        (conserve-eq-defs  (poset->state-conserve-eq-defs poset sys)))
1027                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
1028                   (for-each
1029                    (lambda (def)
1030                      (let* ((n             (first def))
1031                             (eqs           (second def))
1032                             (conserve-eqs  (lookup-def n conserve-eq-defs)))
1033                       
1034                        (for-each
1035                         (lambda (eq)
1036                           (match eq
1037                                  (('-> s0 s1 rexpr) 
1038                                   (pp indent+ (~ ,s0 -> ,s1 (,(expr->string/NMODL rexpr)))))
1039                                  (('<-> s0 s1 rexpr1 rexpr2) 
1040                                   (pp indent+ (~ ,s0 <-> ,s1 (,(expr->string/NMODL rexpr1) #\,
1041                                                               ,(expr->string/NMODL rexpr2) 
1042                                                               ))))
1043                                  ))
1044                           eqs)
1045                        (if conserve-eqs
1046                            (for-each (lambda (eq) 
1047                                      (let ((val  (first eq))
1048                                            (expr (third eq)))
1049                                        (pp indent+ ,(conserve-lineq->string/NMODL expr val))))
1050                                    conserve-eqs))
1051                        ))
1052                    keq-defs))
1053                 (pp indent "}")))
1054           
1055           
1056           (let* ((init-defs         (poset->state-init-defs poset sys))
1057                  (init-eq-defs      (poset->state-init-eq-defs poset sys))
1058                  (locals            (concatenate (find-locals (map second init-defs)))) )
1059               (pp indent ,nl (INITIAL "{"))
1060               (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
1061               (if (not (null? asgns))  (pp indent+ (rates ())))
1062               (for-each (lambda (def)
1063                           (let ((n (first def)) (b (second def)))
1064                             (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
1065               (cond ((and linear? (not (null? init-eq-defs)) )
1066                    (pp indent+ (SOLVE initial_equilibrium)))
1067                   (has-kinetic?
1068                    (pp indent+ (SOLVE kstates STEADYSTATE sparse))))
1069               
1070               (pp indent "}")
1071
1072               (if (and linear? (not (null? init-eq-defs)) )
1073                   (begin
1074                     (pp indent ,nl (LINEAR initial_equilibrium "{"))
1075                     (for-each
1076                      (lambda (x) 
1077                        (let ((lineqs  (second x)))
1078                          (for-each (lambda (eq) 
1079                                      (let ((val  (first eq))
1080                                            (expr (third eq)))
1081                                        (pp indent+ ,(lineq->string/NMODL expr val))))
1082                                    lineqs)))
1083                      init-eq-defs)
1084                     (pp indent "}")))
1085               ))))
1086        ))))
Note: See TracBrowser for help on using the repository browser.