source: project/release/3/nemo/trunk/nemo-nmodl.scm @ 12238

Last change on this file since 12238 was 12238, checked in by Ivan Raikov, 12 years ago

Bug fixes to the example model.

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