source: project/release/4/nemo/trunk/nemo-nmodl.scm @ 27321

Last change on this file since 27321 was 27321, checked in by Ivan Raikov, 8 years ago

nemo: extended print_state procedures in NMODL to include t and v state variables

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