source: project/release/3/nemo/tags/1.11/nemo-nmodl.scm @ 12277

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

Created version 1.11.

File size: 39.5 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) 
721                       (depend #f)  (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) (delete-duplicates (map first 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
741        (match-let (((state-list asgn-list g) deps*))
742         (let* ((poset          (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
743                (asgn-eq-defs   (poset->asgn-eq-defs poset sys))
744                (perm-ions (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               (acc-ions (fold (lambda (ionch ax) 
761                                  (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
762                                         (acc   (lookup-def 'accumulating-substance subcomps))
763                                         (i     (and acc (nmodl-name (s+ 'i (cn acc)))))
764                                         (in    (and acc (nmodl-name (s+ (cn acc) 'i))))
765                                         (out   (and acc (nmodl-name (s+ (cn acc) 'o)))))
766                                    (if acc  (cons `(,(cn acc) ,i ,in ,out) ax) ax)))
767                                (list) ionchs))
768               (pool-ions (map (lambda (ep)
769                                  (let ((ion (car ep)))
770                                    `(,(nmodl-name ion) ,(nmodl-name (s+ 'i ion)) ,(nmodl-name (s+ ion 'i)))))
771                               epools))
772               (has-kinetic? (or (not (null? (filter (lambda (x) (member (car x) kinetic)) states)))))
773               (has-ode?     (or (not (null? (filter (lambda (x) (not (member (car x) kinetic))) states)))
774                                 (not (null? pool-ions)))))
775
776
777           (for-each
778            (lambda (a)
779              (let ((acc-ion   (car a)))
780                (if (assoc acc-ion perm-ions)
781                    (nemo:error 'nemo:nmodl-translator 
782                                ": ion species " acc-ion " cannot be declared as both accumulating and permeating"))))
783            acc-ions)
784
785           (for-each
786            (lambda (p)
787              (let ((pool-ion  (car p)))
788                (if (assoc pool-ion perm-ions)
789                    (nemo:error 'nemo:nmodl-translator 
790                                ": ion species " pool-ion " cannot be declared as both pool and permeating"))))
791            pool-ions)
792
793           (pp indent ,nl (TITLE ,sysname))
794           
795           (pp indent ,nl (NEURON "{"))
796           (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
797           (for-each (lambda (x)
798                       (case (first x)
799                         ((non-specific) 
800                          (pp indent+ (RANGE ,(third x))
801                              (NONSPECIFIC_CURRENT ,(second x))))
802                         (else
803                          (pp indent+ (RANGE ,(second x))
804                              (USEION ,(first x) READ ,(third x) WRITE ,(second x))))))
805                     (delete-duplicates perm-ions (lambda (x y) (eq? (car x) (car y)))))
806
807           (for-each (lambda (acc-ion)
808                       (let ((pool-ion (assoc (first acc-ion) pool-ions)))
809                         (if pool-ion
810                             (pp indent+ (RANGE ,(second acc-ion))
811                                 (USEION ,(first acc-ion) 
812                                         READ  ,(sl\ ", " (list (third acc-ion) (fourth acc-ion) (second pool-ion)))
813                                         WRITE ,(sl\ ", " (list (second acc-ion) (third pool-ion )))))
814                             (pp indent+ (RANGE ,(second acc-ion))
815                                 (USEION ,(first acc-ion) 
816                                         READ ,(sl\ ", "  (list (third acc-ion) (fourth acc-ion) ))
817                                         WRITE ,(second acc-ion))))))
818                       (delete-duplicates acc-ions (lambda (x y) (eq? (car x) (car y)))))
819
820           (let* ((const-names   (map first consts))
821                  (is-const?     (lambda (x) (member x const-names)))
822                  (range-consts  (delete-duplicates 
823                                  (fold (lambda (def ax) 
824                                          (let* ((rhs   (second def))
825                                                 (vars  (rhsvars rhs)))
826                                            (append (filter is-const? vars) ax)))
827                                        (list) asgn-eq-defs ))))
828             (if (not (null? range-consts)) (pp indent+ (RANGE ,(sl\ ", " range-consts)))))
829           
830           
831           (pp indent "}")
832           
833           
834           (pp indent ,nl (PARAMETER "{"))
835           (let* ((const-defs (filter-map
836                               (lambda (nv)
837                                 (and (not (member (first nv) nmodl-builtin-consts))
838                                      (let ((v1 (canonicalize-expr/NMODL (second nv))))
839                                        (list (first nv) v1))))
840                                   consts))
841                  (locals  (find-locals (map second const-defs))))
842             (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
843             (for-each (lambda (def)
844                         (let ((n (first def)) (b (second def)))
845                           (pp indent+ ,(expr->string/NMODL b n)))) const-defs)
846             (for-each (lambda (ep)
847                         (let* ((ep-name     (first ep))
848                                (ep-props    (second ep))
849                                (init-expr   (lookup-def 'initial ep-props))
850                                (temp-expr   (lookup-def 'temp-adj ep-props))
851                                (beta-expr   (lookup-def 'beta ep-props))
852                                (depth-expr  (lookup-def 'depth ep-props))
853                                (init-name   (nmodl-name (s+ ep-name '-init)))
854                                (temp-name   (nmodl-name (s+ ep-name '-temp-adj)))
855                                (beta-name   (nmodl-name (s+ ep-name '-beta)))
856                                (depth-name  (nmodl-name (s+ ep-name '-depth))))
857                           (if (or (not beta-expr) (not depth-expr) (not init-expr))
858                               (nemo:error 'nemo:nmodl-translator 
859                                           ": ion pool " ep-name " requires initial value, depth and beta parameters"))
860                           (let ((temp-val  (and temp-expr (eval-const sys temp-expr)))
861                                 (init-val  (eval-const sys init-expr))
862                                 (beta-val  (eval-const sys beta-expr))
863                                 (depth-val (eval-const sys depth-expr)))
864                             (pp indent+ ,(expr->string/NMODL init-val init-name))
865                             (pp indent+ ,(expr->string/NMODL temp-val temp-name))
866                             (pp indent+ ,(expr->string/NMODL beta-val beta-name))
867                             (pp indent+ ,(expr->string/NMODL depth-val depth-name)))))
868                       epools))
869           (pp indent "}")
870           
871           (let* ((with      (inexact->exact (round (/ (abs (- max-v min-v)) step))))
872                  (define-fn (make-define-fn table? min-v max-v with depend)))
873             (for-each (lambda (fndef) 
874                         (if (not (member (car fndef) builtin-fns))
875                             (apply define-fn (cons indent fndef)))) 
876                       defuns))
877           
878           
879           (pp indent ,nl (STATE "{"))
880           (for-each (lambda (st)
881                       (if (pair? st) 
882                           (apply define-state (list indent+ (nmodl-state-name (first st) (second st))))
883                           (apply define-state (list indent+ st))))
884                     states)
885           (for-each (lambda (st) (apply define-state (list indent+ st)))
886                     stcomps)
887           (for-each (lambda (pool-ion) (apply define-state (list indent+ (first pool-ion))))
888                     pool-ions)
889           (pp indent "}")
890           
891           (pp indent ,nl (ASSIGNED "{"))
892           (let* ((asgns0 (append asgns (map first imports) 
893                                  (map second perm-ions) (map third perm-ions)
894                                  (map second acc-ions)  (map fourth acc-ions)
895                                  (map second pool-ions) (map third pool-ions)
896                                  ))
897                  (asgns1 (delete-duplicates asgns0)))
898             (for-each (lambda (x) (pp indent+ ,(nmodl-name x))) asgns1)
899             (pp indent "}"))
900           
901           (if (not (null? asgns))
902               (begin
903                 (pp indent ,nl (PROCEDURE rates () "{"))
904                 (let ((locals    (find-locals (map second asgn-eq-defs))) )
905                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))))
906                 (for-each (lambda (def)
907                             (let ((n (nmodl-name (first def)) )
908                                   (b (second def)))
909                               (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs)
910                 (pp indent "}")))
911             
912           (if (not (null? stcomps))
913               (begin
914                 (pp indent ,nl (PROCEDURE stcomps () "{"))
915                 (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
916                        (locals    (find-locals (map second eq-defs))) )
917                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
918                   (for-each (lambda (def)
919                               (let ((n (first def)) (b (second def)))
920                                 (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
921                 
922                 (pp indent "}")))
923
924           (if (not (null? pool-ions))
925               (begin
926                 (pp indent ,nl (PROCEDURE pools () "{"))
927                 (for-each (lambda (pool-ion)
928                             (pp indent+ (,(third pool-ion) = ,(first pool-ion))))
929                           pool-ions)
930                 (pp indent "}")))
931             
932           (pp indent ,nl (BREAKPOINT "{"))
933           (let* ((i-eqs (filter-map
934                          (lambda (ionch) 
935
936                            (let* ((label     (first ionch))
937                                   (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                                   (permqs    (and perm ((dis 'component-exports) sys (cid perm))))
942                                   (pore      (lookup-def 'pore subcomps))
943                                   (gate      (lookup-def 'gate subcomps))
944                                   (sts       (and gate ((dis 'component-exports) sys (cid gate)))))
945
946                              (cond ((and perm pore gate)
947                                     (case (cn perm)
948                                       ((non-specific)
949                                        (let* ((i     (nmodl-name 'i))
950                                               (e     (car permqs))
951                                               (gmax  (car ((dis 'component-exports) sys (cid pore))))
952                                               (pwrs  (map (lambda (n) (state-power sys n)) sts))
953                                               (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))
954                                               (gion  `(* ,gmax ,@sptms)))
955                                          (list i e gion)))
956                                       (else
957                                        (let* ((i     (nmodl-name (s+ 'i (cn perm))))
958                                               (e     (nmodl-name (s+ 'e (cn perm))))
959                                               (gmax  (car ((dis 'component-exports) sys (cid pore))))
960                                               (pwrs  (map (lambda (n) (state-power sys n)) sts))
961                                               (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))
962                                               (gion  `(* ,gmax ,@sptms)))
963                                          (list i e gion)))))
964
965                                    ((and perm pore)
966                                     (case (cn perm)
967                                       ((non-specific)
968                                        (let* ((i     (nmodl-name 'i))
969                                               (e     (car permqs))
970                                               (gmax  (car ((dis 'component-exports) sys (cid pore)))))
971                                          (list i e gmax)))
972                                       (else
973                                        (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " label))))
974
975                                      ((and acc pore gate)
976                                       (let* ((i     (nmodl-name (s+ 'i (cn acc))))
977                                              (gmax  (car ((dis 'component-exports) sys (cid pore))))
978                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
979                                              (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))
980                                              (gion  `(* ,gmax ,@sptms)))
981                                         (list i #f gion)))
982                                      (else (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " label))
983                                      )))
984                          ionchs))
985                  (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
986                  (i-eqs  (fold (lambda (b ax) 
987                                  (match b 
988                                         ((and ps ((i e gion) . rst)) 
989                                          (let* ((sum   (if e (sum (map (lambda (b) `(* ,(third b) (- v ,(second b)))) 
990                                                                        ps))
991                                                            (sum (map third ps))))
992                                                 (sum0  (rhsexpr sum))
993                                                 (sum1  (canonicalize-expr/NMODL sum0)))
994                                            (cons (list i sum1) ax)))
995                                           
996                                         ((i e gion)
997                                          (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
998                                                 (expr1  (canonicalize-expr/NMODL expr0)))
999                                              (cons (list i expr1) ax)))
1000                                         
1001                                         (else ax)))
1002                                (list) i-bkts))
1003                  (locals (find-locals (map second i-eqs))))
1004             (if (not (null? locals))    (pp indent+ (LOCAL ,(sl\ ", " locals))))
1005             (if (not (null? asgns))     (pp indent+ (rates ())))
1006             (if has-ode?
1007                 (if (not method) (pp indent+ (SOLVE states))
1008                     (pp indent+ (SOLVE states METHOD ,method))))
1009             (if has-kinetic?   (pp indent+  (SOLVE kstates METHOD sparse)))
1010             (if (not (null? stcomps))   (pp indent+ (stcomps ())))
1011             (if (not (null? pool-ions)) (pp indent+ (pools ())))
1012             (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
1013             (pp indent "}"))
1014           
1015           (if has-ode?
1016               (begin
1017                 (pp indent ,nl (DERIVATIVE states "{"))
1018                 (let* ((state-eq-defs  (reverse (poset->state-eq-defs poset sys kinetic)))
1019                        (pool-eq-defs
1020                         (map (lambda (ep)
1021                                (let* ((ep-name     (first ep))
1022                                       (pool-ion    (assoc ep-name pool-ions))
1023                                       (i-name      (second pool-ion))
1024                                       (init-name   (nmodl-name (s+ ep-name '-init)))
1025                                       (temp-name   (nmodl-name (s+ ep-name '-temp-adj)))
1026                                       (beta-name   (nmodl-name (s+ ep-name '-beta)))
1027                                       (depth-name  (nmodl-name (s+ ep-name '-depth)))
1028                                       (rhs         `(let ((F 96485.0))
1029                                                       (- (/ (neg ,i-name) (* 2 F ,init-name ,depth-name)) 
1030                                                          (* ,beta-name ,ep-name . 
1031                                                             ,(if temp-name (list temp-name) (list)))))))
1032                                  `(,(s+ ep-name "'") ,rhs)))
1033                              epools))
1034                        (eq-defs (append pool-eq-defs state-eq-defs))
1035                        (locals  (find-locals (map second eq-defs))))
1036                   (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
1037                   (for-each (lambda (def)
1038                               (let ((n (first def)) (b (second def)))
1039                                 (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
1040                   
1041                 (pp indent "}")))
1042           
1043           (if has-kinetic?
1044                 (begin
1045                   (pp indent ,nl (KINETIC kstates "{"))
1046                   (let* ((keq-defs (reverse (poset->kstate-eq-defs poset sys kinetic)))
1047                          (locals  (find-locals (map third keq-defs))) )
1048                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
1049                     (for-each (lambda (def)
1050                                 (match def
1051                                        (('-> s0 s1 rexpr) 
1052                                         (pp indent+ (~ ,s0 -> ,s1 (,(expr->string/NMODL rexpr)))))
1053                                        (('<-> s0 s1 rexpr1 rexpr2) 
1054                                         (pp indent+ (~ ,s0 <-> ,s1 (,(expr->string/NMODL rexpr1) #\,
1055                                                                     ,(expr->string/NMODL rexpr2) 
1056                                                                     ))))))
1057                               keq-defs))
1058                   (pp indent "}")))
1059           
1060           
1061           (let* ((init-defs     (poset->state-init-defs poset sys))
1062                  (init-eq-defs  (poset->state-init-eq-defs poset sys))
1063                  (locals        (concatenate (find-locals (map second init-defs)))) )
1064               (pp indent ,nl (INITIAL "{"))
1065               (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
1066               (if (not (null? asgns))  (pp indent+ (rates ())))
1067               (for-each (lambda (def)
1068                           (let ((n (first def)) (b (second def)))
1069                             (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
1070               ;;(for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))  perm-ions)
1071               (if (not (null? init-eq-defs)) (pp indent+ (SOLVE initial_equilibrium)))
1072               (pp indent "}")
1073               (if (not (null? init-eq-defs)) 
1074                   (begin
1075                     (pp indent ,nl (LINEAR initial_equilibrium "{"))
1076                     (for-each
1077                      (lambda (x) 
1078                        (let ((lineqs  (second x)))
1079                          (for-each (lambda (eq) 
1080                                      (let ((val  (first eq))
1081                                            (expr (third eq)))
1082                                        (pp indent+ ,(lineq->string/NMODL expr val))))
1083                                    lineqs)))
1084                      init-eq-defs)
1085                     (pp indent "}")))
1086               ))))
1087        ))))
Note: See TracBrowser for help on using the repository browser.