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

Last change on this file since 31375 was 31375, checked in by Ivan Raikov, 7 years ago

nemo: formatting fixes in nmodl backend

File size: 53.1 KB
Line 
1;;       
2;;
3;; An extension for translating NEMO models to NMODL descriptions.
4;;
5;; Copyright 2008-2014 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 srfi-1 srfi-13 srfi-69)
26
27        (require-extension lolevel posix datatype matchable strictly-pretty 
28                           varsubst datatype 
29                           nemo-core nemo-utils nemo-gate-complex nemo-synapse)
30        (require-library ersatz-lib)
31
32        (import (prefix ersatz-lib ersatz: ))
33
34
35(define (safe-car x)
36  (and x (car x)))
37
38(define (safe-cadr x)
39  (and x (cadr x)))
40
41
42(define nmodl-ops
43  `(+ - * / > < <= >= = ^))
44
45
46(define (nmodl-name s)
47  (let ((cs (string->list (->string s))))
48    (let loop ((lst (list)) (cs cs))
49      (if (null? cs) (string->symbol (list->string (reverse lst)))
50          (let* ((c (car cs))
51                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c)
52                           (else #\_))))
53            (loop (cons c1 lst) (cdr cs)))))))
54                           
55
56(define (nmodl-state-name n s)
57  (nmodl-name (if n (s+ n s) s)))
58
59(define builtin-consts
60  (append `(celsius diam)
61          (map (lambda (x) (nmodl-name (first x))) nemo:math-constants)))
62
63(define builtin-fns
64  `(+ - * / pow neg abs atan asin acos sin cos exp ln
65      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
66      > < <= >= = and or round ceiling floor max min
67      ))
68
69(define-datatype useion useion?
70  (UseIon (name symbol?) (read list?) (write list?) (valence (lambda (x) (or (not x) (integer? x)))))
71  (NonSpecific (name symbol?)))
72
73
74(define (consolidate-useions useions)
75  (let recur ((useions useions) (ax '()))
76    (if (null? useions) ax
77        (let ((u (car useions)))
78          (cases useion u
79                 (UseIon (name read write valence)
80                         (let ((v (lookup-def name ax)))
81                           (if (not v) 
82                               (recur (cdr useions) (cons (cons name u) ax))
83                               (cases useion v 
84                                      (UseIon (_ read1 write1 valence1)
85                                         (if (and valence valence1 (not (equal? valence valence1)))
86                                             (error 'nemo-nmodl "ionic species has different declared valences" name valence valence1)
87                                             (recur (cdr useions)
88                                                    (alist-update name (UseIon name
89                                                                               (delete-duplicates (append read read1) eq?)
90                                                                               (delete-duplicates (append write write1) eq?)
91                                                                               (or valence valence1)) ax))))
92                                      (NonSpecific (name)
93                                                   (error 'nemo-nmodl "previously declared ionic species appears as non-specific" name)))
94                               )))
95                 (NonSpecific (name)
96                              (recur (cdr useions) (cons (cons name u) ax)))
97                 )
98          ))
99    ))
100                                     
101                                     
102                               
103
104(define (rhsvars rhs)
105  (enum-freevars rhs (list) (list)))
106
107
108(define (rewrite-pow expr)
109  (match expr
110         (('pow x y)  (if (and (integer? y)  (positive? y))
111                          (if (> y 1)  (let ((tmp (gensym "x")))
112                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
113                              x)
114                          (if (and (number? y) (zero? y)) 1.0 expr)))
115         (else expr)))
116
117
118(define (rhsexpr/NMODL expr)
119  (match expr 
120         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr/NMODL x)) es)))
121         (('pow x y)  (cond ((and (integer? y) (= y 1)) x)
122                            ((and (number? y) (zero? y)) 1.0)
123                            (else expr)))
124         (('let bnds body) `(let ,(map (lambda (x) (list (car x) (rhsexpr/NMODL (cadr x)))) bnds) ,(rhsexpr/NMODL body)))
125         ((s . es)    (if (symbol? s)   (cons (if (member s builtin-fns) s (nmodl-name s)) 
126                                              (map (lambda (x) (rhsexpr/NMODL x)) es)) expr))
127         (id          (if (symbol? id) (nmodl-name id) id))))
128
129
130(define-syntax pp
131  (syntax-rules ()
132    ((pp indent val ...) (ppf indent (quasiquote val) ...))))
133
134
135(define (letblk/NMODL e1 e2)
136  (cond ((equal? e1 (doc:empty)) (doc:group (doc:nest 2 e2)))
137        ((equal? e2 (doc:empty)) (doc:group (doc:nest 2 e1)))
138        (else (doc:connect (doc:group (doc:nest 2 e1))
139                           (doc:group (doc:nest 2 e2))))))
140       
141(define ifthen/NMODL  (doc:ifthen 0 (doc:text "if") (doc:text "") (doc:text "else")))
142(define group/NMODL   (doc:block 2 (doc:text "(") (doc:text ")")))
143(define block/NMODL   (doc:block 2 (doc:text "{") (doc:text "}")))
144(define binop/NMODL   (doc:binop 2))
145
146(define (format-op/NMODL indent op args)
147  (let ((op1 (doc:text (->string op))))
148    (let ((res
149           (if (null? args) op1
150               (match args
151                      ((x)           (doc:connect op1 x))
152                      ((x y)         (binop/NMODL x op1 y))
153                      ((x y z)       (binop/NMODL x op1 (binop/NMODL y op1 z)))
154                      (lst           (let* ((n   (length lst))
155                                            (n/2 (inexact->exact (round (/ n 2)))))
156                                       (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 
157                                                    (format-op/NMODL indent op (drop lst n/2 )))))))))
158      res)))
159
160
161(define (format-conseq-op/NMODL indent op args)
162  (let ((op1 (doc:text (->string op))))
163    (if (null? args) op1
164        (match args
165               ((x)      (doc:concat (list op1 x)))
166               ((x y)    (doc:concat (intersperse (list x op1 y) (doc:space))))
167               ((x y z)  (doc:concat (intersperse (list x op1 y op1 z) (doc:space))))
168               (lst      (let* ((n   (length lst))
169                                (n/2 (inexact->exact (round (/ n 2)))))
170                           (doc:concat 
171                            (intersperse 
172                             (list (format-conseq-op/NMODL indent op (take lst n/2 )) op1 
173                                   (format-conseq-op/NMODL indent op (drop lst n/2 )))
174                             (doc:space)))))))))
175
176(define (format-fncall/NMODL indent op args)
177  (let ((op1 (doc:text (->string op))))
178    (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args)))))
179
180(define (name-normalize expr)
181  (match expr 
182         (('if c t e)  `(if ,(name-normalize c) ,(name-normalize t) ,(name-normalize e)))
183         (('let bs e)
184          `(let ,(map (lambda (b) `(,(car b) ,(name-normalize (cadr b)))) bs) ,(name-normalize e)))
185         ((f . es) 
186          (cons (if (member f builtin-fns) f (nmodl-name f)) (map name-normalize es)))
187         ((? symbol? ) (nmodl-name expr))
188         ((? atom? ) expr)))
189
190
191(define (canonicalize-expr/NMODL expr)
192  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) 
193                                      nemo:binding? identity nemo:bind 
194                                      nemo:subst-term)))
195    (let* ((expr1 (if-convert expr))
196           (expr2 (subst-convert expr1 subst-empty))
197           (expr3 (let-lift expr2))
198           (expr4 (name-normalize expr3)))
199      expr4)))
200
201
202(define (format-expr/NMODL indent expr . rest) 
203  (let-optionals rest ((rv #f))
204   (let ((indent+ (+ 2 indent)))
205    (match expr
206       (('let bindings body)
207        (letblk/NMODL
208         (fold-right 
209           (lambda (x ax)
210             (let ((res
211                    (letblk/NMODL
212                     (match (second x)
213                            (('if c t e)
214                             (ifthen/NMODL
215                              (group/NMODL (format-expr/NMODL indent c))
216                              (block/NMODL (format-expr/NMODL indent t (first x)))
217                              (block/NMODL (format-expr/NMODL indent e (first x)))))
218                            (else
219                             (format-op/NMODL indent+ " = "
220                                              (list (format-expr/NMODL indent (first x) )
221                                                    (format-expr/NMODL indent (second x))))))
222                     ax)))
223               res
224               ))
225           (doc:empty) bindings)
226         (match body
227                (('let _ _) (format-expr/NMODL indent body rv))
228                (else
229                 (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
230                   (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
231                       body1))))))
232       
233       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))
234
235       ((op . rest) 
236       (let ((op (case op ((pow)  '^) ((abs) 'fabs) ((ln) 'log) (else op))))
237         (let ((fe
238                (if (member op nmodl-ops)
239                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
240                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
241                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
242                      (case op
243                        ((/) 
244                         (format-op/NMODL indent op 
245                                          (map (lambda (x) 
246                                                 (let ((fx (format-expr/NMODL indent+ x)))
247                                                   (if (or (symbol? x) (number? x)) fx
248                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
249                        ((*) 
250                         (format-op/NMODL indent op 
251                                          (map (lambda (x) 
252                                                 (let ((fx (format-expr/NMODL indent+ x)))
253                                                   (if (or (symbol? x) (number? x)) fx
254                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
255                       
256                        ((^) 
257                         (format-op/NMODL indent op 
258                                          (map (lambda (x) 
259                                                 (let ((fx (format-expr/NMODL indent+ x)))
260                                                   (if (or (symbol? x)  (number? x)) fx
261                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
262                       
263                        (else
264                         (format-op/NMODL indent op 
265                                          (map (lambda (x) 
266                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
267                   
268                    (let ((op (case op ((neg) '-) (else op))))
269                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
270           (if rv 
271               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
272               fe))))
273     
274      (else  (let ((fe (doc:text (->string expr))))
275               (if rv 
276                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
277                   fe)))))))
278               
279
280         
281(define (expr->string/NMODL x . rest)
282  (let-optionals rest ((rv #f) (width 72))
283    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
284 
285
286(define (format-conseq/NMODL indent expr . rest) 
287  (let-optionals rest ((rv #f))
288   (let ((indent+ (+ 2 indent)))
289    (match expr
290       (('let bindings body)
291        (letblk/NMODL
292         (fold-right 
293           (lambda (x ax)
294             (letblk/NMODL
295              (match (second x)
296                     (('if c t e)
297                      (ifthen/NMODL
298                       (group/NMODL (format-conseq/NMODL indent c))
299                       (block/NMODL (format-conseq/NMODL indent t (first x)))
300                       (block/NMODL (format-conseq/NMODL indent e (first x)))))
301                     (else
302                      (format-conseq-op/NMODL indent+ " = "
303                                       (list (format-conseq/NMODL indent (first x) )
304                                             (format-conseq/NMODL indent (second x))))))
305              ax))
306           (doc:empty) bindings)
307         (let ((body1 (doc:nest indent (format-conseq/NMODL indent body))))
308           (if rv  (format-conseq-op/NMODL indent " = " (list (format-conseq/NMODL indent+ rv ) body1))
309               body1))))
310       
311       (('if . rest) (error 'format-conseq/NMODL "invalid if statement " expr))
312
313       ((op . rest) 
314        (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
315          (let ((fe
316                (if (member op nmodl-ops)
317                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
318                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
319                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
320                      (case op
321                        ((/) 
322                         (format-conseq-op/NMODL indent op 
323                                          (map (lambda (x) 
324                                                 (let ((fx (format-conseq/NMODL indent+ x)))
325                                                   (if (or (symbol? x) (number? x)) fx
326                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
327                        ((*) 
328                         (format-conseq-op/NMODL indent op 
329                                          (map (lambda (x) 
330                                                 (let ((fx (format-conseq/NMODL indent+ x)))
331                                                   (if (or (symbol? x) (number? x)) fx
332                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
333                       
334                        ((^) 
335                         (format-conseq-op/NMODL indent op 
336                                          (map (lambda (x) 
337                                                 (let ((fx (format-conseq/NMODL indent+ x)))
338                                                   (if (or (symbol? x)  (number? x)) fx
339                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
340                       
341                        (else
342                         (format-conseq-op/NMODL indent op 
343                                          (map (lambda (x) 
344                                                 (let ((fx (format-conseq/NMODL indent+ x))) fx)) rest)))))
345                   
346                    (case op
347                      ((neg) (format-conseq-op/NMODL indent '* (map (lambda (x) (format-conseq/NMODL indent+ x)) 
348                                                             (cons "(-1)" rest))))
349                      (else  (format-fncall/NMODL indent op (map (lambda (x) (format-conseq/NMODL indent+ x)) 
350                                                                 rest)))))))
351
352           (if rv (format-conseq-op/NMODL indent " = " (list (format-conseq/NMODL indent+ rv ) fe)) fe))))
353     
354      (else  (let ((fe (doc:text (->string expr))))
355               (if rv 
356                   (format-conseq-op/NMODL indent " = " (list (format-conseq/NMODL indent+ rv ) fe))
357                   fe)))))))
358               
359
360(define (reaction-keqs n initial open transitions power)
361  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) 
362                                       nemo:binding? identity nemo:bind nemo:subst-term))
363         (state-list     (let loop ((lst (list)) (tlst transitions))
364                           (if (null? tlst)  (delete-duplicates lst eq?)
365                               (match (car tlst) 
366                                      (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
367                                       (loop (cons* s0 s1 lst) (cdr tlst)))
368                                      (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
369                                       (loop (cons* s0 s1 lst) (cdr tlst)))
370                                      (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
371                                       (loop (cons* s0 s1 lst) (cdr tlst)))
372                                      (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr1 rate-expr2)
373                                       (loop (cons* s0 s1 lst) (cdr tlst)))
374                                      (else
375                                       (nemo:error 'nemo:nmodl-reaction-keqs: "invalid transition equation " 
376                                                   (car tlst) " in state complex " n)))
377                               )))
378         (state-subs     (fold (lambda (s ax) (subst-extend s (nmodl-state-name n s) ax)) subst-empty state-list)))
379    ;; generate kinetic equations for each edge in the transitions system
380    (list n 
381          (map
382           (lambda (e) 
383             (match e
384                    (('-> s0 s1 rexpr)
385                     (let ((i  (lookup-def s0 state-subs))
386                           (j  (lookup-def s1 state-subs)))
387                       `(-> ,i ,j ,(canonicalize-expr/NMODL 
388                                    (subst-convert rexpr state-subs)))))
389                   
390                    ((s0 '-> s1 rexpr)
391                     (let ((i  (lookup-def s0 state-subs))
392                           (j  (lookup-def s1 state-subs)))
393                       `(-> ,i ,j ,(canonicalize-expr/NMODL 
394                                    (subst-convert rexpr state-subs)))))
395                   
396                    (('<-> s0 s1 rexpr1 rexpr2)
397                     (let ((i  (lookup-def s0 state-subs))
398                           (j  (lookup-def s1 state-subs)))
399                       `(<-> ,i ,j 
400                             ,(canonicalize-expr/NMODL (subst-convert rexpr1 state-subs))
401                             ,(canonicalize-expr/NMODL (subst-convert rexpr2 state-subs)))))
402                   
403                    ((s0 '<-> s1 rexpr1 rexpr2)
404                     (let ((i  (lookup-def s0 state-subs))
405                           (j  (lookup-def s1 state-subs)))
406                       `(<-> ,i ,j 
407                             ,(canonicalize-expr/NMODL (subst-convert rexpr1 state-subs))
408                             ,(canonicalize-expr/NMODL (subst-convert rexpr2 state-subs)))))
409                   
410                   
411                    (else (nemo:error 'nemo:nmodl-reaction-keqs: "invalid transition equation " 
412                                      e " in state complex " n))))
413           transitions))))
414       
415
416(define (poset->kinetic-eq-defs poset sys kinetic)
417  (fold-right
418   (lambda (lst ax)
419     (fold  (lambda (x ax) 
420              (match-let (((i . n)  x))
421                         (let ((en (hash-table-ref sys n)))
422                           (if (and (member n kinetic) (nemo:quantity? en))
423                               (cases nemo:quantity en
424                                      (REACTION  (name initial open transitions conserve power u) 
425                                                 (cons (reaction-keqs name initial open transitions power) ax))
426                                      (else  ax))
427                               ax))))
428            ax lst))
429   (list) poset))
430
431
432(define (member-imports x imports)
433  (safe-car (member x imports (lambda (x y) (equal? x (cadr y))))))
434
435
436(define (instantiate-template tmpl tmpl-vars)
437    (let ((ctx (ersatz:init-context models: tmpl-vars )))
438      (display
439       (ersatz:eval-statements 
440        tmpl
441        env: (ersatz:template-std-env autoescape: #f)
442        models: tmpl-vars ctx: ctx
443        ))
444      ))
445
446
447(define (conserve-conseq->string/NMODL x val . rest)
448  (let-optionals rest ((width 72))
449    (s+ "CONSERVE " (sdoc->string (doc:format width (format-conseq/NMODL 2 x #f))) 
450        " = " (number->string val))))
451
452 
453(define fn-template
454  (ersatz:statements-from-string
455   (ersatz:template-std-env autoescape: #f) 
456#<<EOF
457
458FUNCTION {{functionName}} ({{join(",", functionVars)}}) {
459{% if (!(localVars == [])) %}
460LOCAL {{join(",", localVars)}}
461{% endif %}
462{{ exprString }}
463} 
464
465EOF
466))
467
468
469(define (fn-translator n proc)
470  (let ((lst (procedure-data proc))
471        (indent+ 2))
472   
473    (let ((rt       (lookup-def 'rt lst))
474          (formals  (lookup-def 'formals lst))
475          (vars     (lookup-def 'vars lst))
476          (body     (lookup-def 'body lst)))
477     
478      (let* ((body0 (rhsexpr/NMODL body))
479             (body1 (canonicalize-expr/NMODL body0))
480             (lbs   (enum-bnds body1 (list)))
481             (tmpl-vars
482              `(
483                (functionName . ,(ersatz:sexpr->tvalue (nmodl-name n)))
484                (functionVars . ,(ersatz:sexpr->tvalue vars))
485                (localVars    . ,(if (null? lbs) (ersatz:Tlist '()) (ersatz:sexpr->tvalue lbs)))
486                (exprString   . ,(ersatz:Tstr (expr->string/NMODL body1 (nmodl-name n))))
487              ))
488             )
489
490        (instantiate-template fn-template tmpl-vars)
491        ))
492    ))
493
494
495(define prelude-template
496  (ersatz:statements-from-string
497   (ersatz:template-std-env autoescape: #f) 
498#<<EOF
499TITLE {{modelName}}
500
501COMMENT
502This file was generated by {{nemoVersionString}} on {{currentTimestamp}}
503ENDCOMMENT
504
505EOF
506))
507
508
509(define neuron-template
510  (ersatz:statements-from-string
511   (ersatz:template-std-env autoescape: #f) 
512#<<EOF
513
514NEURON {
515
516{% if (hasEvents) %}
517POINT_PROCESS {{modelName}}
518{% endif %}
519
520{# NMODL has a line character limit, so we limit the number of entries in each RANGE stmt to 10 #}
521
522COMMENT 
523 exports
524ENDCOMMENT
525
526{% for exportGroup in groupBy(10, exports) %}
527RANGE {{join(",", exportGroup)}}
528{% endfor %}
529
530{% if (!(currents == [])) %}
531RANGE {{join(",", currents)}}
532{% endif %}
533
534{#
535   if rev potential is defined for this ion, declare the ionic current
536   and reversal potential as range variables, otherwise declare only
537   the ionic current as a range variable
538#}
539
540{% for p in permeatingIons %}
541{% if (p.species == "non-specific") %}
542RANGE {{p.e}}
543{% elseif (p.erev) %}
544RANGE {{p.i}}, {{p.e}}
545{% else %}
546RANGE {{p.i}}
547{% endif %}
548{% endfor %}
549
550{% for p in poolIons %}
551RANGE {{p.in}}, {{p.out}}
552{% endfor %}
553
554{% if (accumulatingIons == []) %}
555{% for p in poolIons %}
556RANGE {{p.in}}, {{p.out}}
557{% endfor %}
558{% for m in modulatingIons %}
559RANGE {{m.in}}, {{m.out}}
560{% endfor %}
561{% else %}
562{% for a in accumulatingIons %}
563RANGE {{a.i}}
564{% endfor %}
565{% endif %}
566
567COMMENT 
568range parameters
569ENDCOMMENT
570
571{% for parameterGroup in groupBy(10, rangeParameters) %}
572RANGE {{join(",", parameterGroup)}}
573{% endfor %}
574
575COMMENT 
576use ions
577ENDCOMMENT
578
579{% for useIon in useIons %}
580{% if (useIon.nonSpecific) %}
581NONSPECIFIC_CURRENT {{useIon.name}}
582{% elseif (useIon.valence && (!(useIon.write == [])) && (!(useIon.read == [])) ) %}
583USEION {{useIon.name}} READ {{join (", ", useIon.read)}} WRITE {{join (", ", useIon.write)}} VALENCE {{useIon.valence}}
584{% elseif (useIon.valence && (useIon.write == []) && (!(useIon.read == [])) ) %}
585USEION {{useIon.name}} READ {{join (", ", useIon.read)}} VALENCE {{useIon.valence}}
586{% elseif ((!(useIon.write == [])) && (!(useIon.read == [])) ) %}
587USEION {{useIon.name}} READ {{join (", ", useIon.read)}} WRITE {{join (", ", useIon.write)}} 
588{% elseif ((useIon.write == []) && (!(useIon.read == [])) ) %}
589USEION {{useIon.name}} READ {{join (", ", useIon.read)}} 
590{% endif %}
591{% endfor %}
592}
593
594EOF
595))
596
597
598
599(define parameter-template
600  (ersatz:statements-from-string
601   (ersatz:template-std-env autoescape: #f) 
602#<<EOF
603PARAMETER {
604{% if (!(parameterLocals == [])) %}
605  LOCAL {{join(",1", parameterLocals)}}
606{% endif %}
607
608{% for parameterDef in parameterDefs %}
609{{parameterDef}}
610{% endfor %}
611
612}
613
614EOF
615))
616
617
618(define state-template
619  (ersatz:statements-from-string
620   (ersatz:template-std-env autoescape: #f) 
621#<<EOF
622STATE {
623{% for stateDef in stateDefs %}
624{{stateDef}}
625{% endfor %}
626}
627
628EOF
629))
630
631(define assigned-template
632  (ersatz:statements-from-string
633   (ersatz:template-std-env autoescape: #f) 
634#<<EOF
635ASSIGNED {
636{% for assignedDef in assignedDefs %}
637{{assignedDef}}
638{% endfor %}
639}
640
641EOF
642))
643
644
645(define asgns-template
646  (ersatz:statements-from-string
647   (ersatz:template-std-env autoescape: #f) 
648#<<EOF
649{% if (!(assignedEqDefs == [])) %}
650PROCEDURE asgns () {
651{% if (!(assignedEqLocals == [])) %}
652LOCAL {{join(",", assignedEqLocals)}}
653{% endif %}
654{% for assignedEqDef in assignedEqDefs %}
655{{assignmentEqDef}}
656{% endfor %}
657}
658
659{% endif %}
660EOF
661))
662
663
664(define reactions-template
665  (ersatz:statements-from-string
666   (ersatz:template-std-env autoescape: #f) 
667#<<EOF
668{% if (!(reactionEqDefs == [])) %}
669PROCEDURE reactions () {
670{% if (!(reactionLocals == [])) %}
671LOCAL {{join(",3", reactionLocals)}}
672{% endif %}
673{% for reactionEqDef in reactionEqDefs %}
674{{reactionEqDef}}
675{% endfor %}
676}
677
678{% endif %}
679EOF
680))
681
682
683(define pools-template
684  (ersatz:statements-from-string
685   (ersatz:template-std-env autoescape: #f) 
686#<<EOF
687{% if (!(poolIons == [])) %}
688PROCEDURE pools () {
689{% for poolIon in poolIons %}
690{{poolIon.in}} = {{poolIon.inq}}
691{{poolIon.out}} = {{poolIon.outq}}
692{% endfor %}
693}
694
695{% endif %}
696EOF
697))
698
699
700
701(define (nemo:nmodl-translator sys . rest)
702  (define (cid x)  (second x))
703  (define (cn x)   (first x))
704
705  (let-optionals rest ((method 'cnexp) (kinetic (list)) (linear? #f))
706  (match-let ((($ nemo:quantity 'DISPATCH  dis) (hash-table-ref sys (nemo-intern 'dispatch))))
707    (let ((eval-const  (let ((eval-const (dis 'eval-const)))
708                         (lambda (x q) (eval-const sys x q))))
709          (imports     ((dis 'imports)  sys))
710          (exports     ((dis 'exports)  sys))
711          )
712      (let* (
713             (indent        0)
714             (indent+       (+ 2 indent ))
715             (sysname       (nmodl-name ((dis 'sysname) sys)))
716             (consts        ((dis 'consts)  sys))
717             (asgns         ((dis 'asgns)   sys))
718             (states        ((dis 'states)  sys))
719             (kinetic       (or kinetic '()))
720             (kinetic       (delete-duplicates
721                             (cond ((eq? kinetic 'all) (filter-map first states))
722                                   ((symbol? kinetic) 
723                                    (let ((sk (->string kinetic)))
724                                      (filter-map
725                                       (lambda (s) (and s (and (string-suffix? sk (->string s)) s)) )
726                                       (map first states))))
727                                   (else
728                                    (let ((kinetic (map ->string kinetic))
729                                          (ss      (map first states)))
730                                      (concatenate
731                                       (map (lambda (sk)
732                                              (filter-map (lambda (s) (and (string-suffix? sk (->string s)) s))
733                                                          ss))
734                                            kinetic)))))))
735             (reactions     ((dis 'reactions) sys))
736             (rates         ((dis 'rates) sys))
737             (defuns        ((dis 'defuns)  sys))
738             (components    ((dis 'components) sys))
739             (g             (match-let (((state-list asgn-list g) ((dis 'depgraph*) sys))) g))
740             (poset         (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
741             
742             (gate-complex-info    (nemo:gate-complex-query sys))
743             (gate-complexes       (lookup-def 'gate-complexes gate-complex-info))
744             (perm-ions     (map (match-lambda ((comp i e erev val) 
745                                                `(,comp ,(nmodl-name i) ,(nmodl-name e) ,erev ,val))
746                                               ((comp i e erev) 
747                                                `(,comp ,(nmodl-name i) ,(nmodl-name e) ,erev #f)))
748                                 (lookup-def 'perm-ions gate-complex-info)))
749             (acc-ions      (delete-duplicates 
750                             (map (match-lambda ((comp i in out)
751                                                 `(,comp ,@(map nmodl-name (list i in out)))))
752                                  (lookup-def 'acc-ions gate-complex-info))
753                             (lambda (x y) (eq? (car x) (car y)))))
754             (mod-ions      (lookup-def 'mod-ions gate-complex-info))
755             (epools        (lookup-def 'pool-ions gate-complex-info))
756             (pool-ions     (pool-ion-name-map nmodl-name epools))
757
758             (i-gates       (lookup-def 'i-gates gate-complex-info))
759
760             (synapse-info  (nemo:post-synaptic-conductance-query sys))
761             (isyns         (lookup-def 'i-synapses synapse-info))
762             (pscs          (lookup-def 'post-synaptic-conductances synapse-info))
763
764
765             (has-kinetic?  (or (not (null? (filter (lambda (x) (member (car x) kinetic)) states)))))
766             (has-ode?      (or (not (null? (filter (lambda (x) (not (member (car x) kinetic))) states)))
767                                (not (null? pool-ions))))
768
769             (parameter-defs (filter-map
770                              (lambda (nv)
771                                (and (not (member (first nv) builtin-consts))
772                                     (let ((v1 (canonicalize-expr/NMODL (second nv))))
773                                       (list (first nv) v1))))
774                              consts))
775
776             (external-eq-defs   (sys->external-eq-defs sys nmodl-name rhsexpr/NMODL canonicalize-expr/NMODL
777                                                        namespace-filter: (lambda (x) (not (equal? x 'event)))))
778             (asgn-eq-defs       (poset->asgn-eq-defs poset sys nmodl-name rhsexpr/NMODL canonicalize-expr/NMODL))
779             (asgn-eq-defs       (append asgn-eq-defs
780                                         (filter-map
781                                          (lambda (gate-complex) 
782                                           
783                                            (let* ((label             (first gate-complex))
784                                                   (n                 (second gate-complex))
785                                                   (subcomps          ((dis 'component-subcomps) sys n))
786                                                   (permeability      (lookup-def 'permeability subcomps))
787                                                   (permion           (lookup-def 'permeating-ion subcomps))
788                                                   (permqs            (and permion ((dis 'component-exports) sys (cid permion))))
789                                                   )
790                                             
791                                              (if (and permion (null? permqs) (not permeability))
792                                                  (nemo:error 'nemo:nmodl-translator: "permeating-ion component in complex " label
793                                                          " does not export any quantities; it must export reversal potential quantity"))
794
795                                              (if (and permion (not (null? permqs)))
796                                                 
797                                                  (case (cn permion)
798                                                    ((non-specific)
799                                                     (let* ((e      (nmodl-name 'e))
800                                                            (elocal (car permqs)))
801                                                       (and (not (equal? e elocal))
802                                                           (list e (nmodl-name elocal)))))
803                                                   
804                                                    (else
805                                                     (let* ((e (nmodl-name (s+ 'e (cn permion))))
806                                                            (elocal (car permqs)))
807                                                       (and (not (equal? e elocal))
808                                                           (list e (nmodl-name elocal)))))
809                                                    ) #f)
810                                              ))
811                                          gate-complexes)
812                                         ))
813             (reaction-eq-defs   (poset->reaction-eq-defs poset sys nmodl-name nmodl-state-name rhsexpr/NMODL canonicalize-expr/NMODL)) 
814             (rate-eq-defs       (reverse (poset->rate-eq-defs poset sys method nmodl-name nmodl-state-name rhsexpr/NMODL canonicalize-expr/NMODL 
815                                                               kinetic: kinetic)))
816             (kstate-eq-defs     (poset->kinetic-eq-defs poset sys kinetic))
817             (conserve-eq-defs   (poset->state-conserve-eq-defs poset sys nmodl-name nmodl-state-name))
818             (state-init-defs    (poset->init-defs poset sys nmodl-name nmodl-state-name rhsexpr/NMODL canonicalize-expr/NMODL))
819
820             (transient-event-defs  (poset->transient-event-defs poset sys method nmodl-name nmodl-state-name rhsexpr/NMODL canonicalize-expr/NMODL builtin-fns)) 
821             (has-events?           (not (null? transient-event-defs)))
822
823             (useions   (append
824
825                         ;; Synaptic currents are modeled as non-specific currents.
826                         (map (lambda (isyn) (NonSpecific (nmodl-name (first isyn)))) isyns)
827
828                         ;; NEURON distinguishes between different
829                         ;; calcium pools by calling their ions ca2,
830                         ;; ca3, etc. This means that it is possible
831                         ;; to have calcium buffer ca2 that imports
832                         ;; ica to estimate the current calcium
833                         ;; concentration. So we check if the current
834                         ;; model is importing currents from different
835                         ;; species and generate useion statements to
836                         ;; cover this case.
837                         
838                         (filter-map (lambda (x) (and (equal? (third x) 'ion-currents) 
839                                                      (let* ((n (nmodl-name (second x)))
840                                                             (ion (nmodl-name (string-drop (->string n) 1))))
841                                                        (UseIon ion (list n) (list) #f ))))
842                                     imports)
843                         
844                         ;; For every current defined in the current
845                         ;; model, we must generate useion statements
846                         ;; for the current and optionally reversal
847                         ;; potential and ionic concentrations
848                         (filter-map (lambda (x)
849                                       (case (first x)
850
851                                         ((non-specific) 
852                                          (NonSpecific (second x)))
853
854                                         (else
855                                          (cond
856                                           ((fourth x) ;; there is erev present, i.e. ohmic channel
857                                               (let* ((ion    (first x))
858
859                                                      ;; this handles a special case when a mechanism is defined as
860                                                      ;; ohmic (i.e. with reversal potential), but uses dynamic ionic
861                                                      ;; concentrations to compute reversal potential;
862                                                      ;; in this case, the reversal potential is computed
863                                                      ;; in the mechanism at each timestep and we must not do USEION READ e...
864
865                                                      (concqs  (filter identity
866                                                                       (list (safe-cadr (member-imports (string->symbol (s+ ion 'i)) imports))
867                                                                             (safe-cadr (member-imports (string->symbol (s+ ion 'o)) imports)))))
868
869                                                      ;; if ionic concentrations are not imported in this mechanism,
870                                                      ;; just use the reversal potential set for this ionic species
871
872                                                      (readqs (if (null? concqs) (list (third x)) concqs))
873
874                                                      (writeqs (list (second x)))
875
876                                                      (valence (and (fifth x) (inexact->exact (eval-const (fifth x) (fifth x)))))
877                                                      )
878
879                                                 (UseIon ion readqs writeqs valence)))
880                                           
881                                           (else ;; no erev present, probably a concentration-based channel
882                                            (let* ((ion    (first x))
883
884                                                   (concqs  (filter identity
885                                                                    (list (safe-cadr (member-imports (string->symbol (s+ ion 'i)) imports))
886                                                                          (safe-cadr (member-imports (string->symbol (s+ ion 'o)) imports)))))
887                                                   
888                                                   (readqs concqs)
889                                                   
890                                                   (writeqs (list (second x)))
891                                                   
892                                                   (valence (and (fifth x) (inexact->exact (eval-const (fifth x) (fifth x)))))
893                                                   )
894
895                                                 (UseIon ion readqs writeqs valence)))
896                                         ))
897                                       ))
898                                     (delete-duplicates perm-ions (lambda (x y) (eq? (car x) (car y)) ))
899                                     )
900                         
901                         (if (null? acc-ions)
902
903                             (append
904
905                              (map (lambda (pool-ion)
906                                     (let ((valence (pool-ion-valence pool-ion)))
907                                       (UseIon (pool-ion-name pool-ion) 
908                                               (list (pool-ion-cur pool-ion))
909                                               (list (pool-ion-in pool-ion ) (pool-ion-out pool-ion ))
910                                               (and valence (inexact->exact (eval-const valence valence)))
911                                               )))
912                                   pool-ions)
913
914                              (map (lambda (mod-ion)
915                                     (let ((valence (fourth mod-ion)))
916                                       (let ((read-ions (filter (lambda (x) 
917                                                                  (and x (member-imports x imports)))
918                                                                (list (second mod-ion) (third mod-ion))))
919                                             (valence (and valence (inexact->exact (eval-const valence valence)))))
920                                       (if (null? read-ions)
921                                           (let ((ion-name (car mod-ion)))
922                                             (nemo:error 'nemo:nmodl-translator: "there are no imported quantities for modulating ion " ion-name
923                                                         "; the model must import " (s+ ion-name 'i) " or " (s+ ion-name 'o) " or both")))
924                                       (UseIon (first mod-ion) read-ions (list) valence))))
925                                   mod-ions))
926
927                             (map (lambda (acc-ion)
928                                    (let ((pool-ion (assoc (first acc-ion) (map (lambda (p) (cons (pool-ion-name p) p)) pool-ions))))
929                                      (if pool-ion
930                                          (let ((pool-ion (cdr pool-ion)))
931                                            (UseIon (first acc-ion) 
932                                                    (list (third acc-ion) (fourth acc-ion) (pool-ion-in pool-ion))
933                                                    (list (second acc-ion) (pool-ion-out pool-ion ))
934                                                    #f))
935                                          (UseIon (first acc-ion) 
936                                                  (list (third acc-ion) (fourth acc-ion))
937                                                  (list (second acc-ion))
938                                                  #f))))
939                                  acc-ions)
940                         )))
941
942             (useions   (consolidate-useions useions))
943
944
945             (i-eqs (filter-map
946                       (lambda (gate-complex) 
947                         
948                         (let* ((label             (first gate-complex))
949                                (n                 (second gate-complex))
950                                (subcomps          ((dis 'component-subcomps) sys n))
951                                (acc               (lookup-def 'accumulating-substance subcomps))
952                                (perm              (lookup-def 'permeating-ion subcomps))
953                                (permqs            (and perm ((dis 'component-exports) sys (cid perm))))
954                                (pore              (lookup-def 'pore subcomps))
955                                (permeability      (lookup-def 'permeability subcomps))
956                                (gates             (filter (lambda (x) (equal? (car x) 'gate)) subcomps))
957                                (sts               (map (lambda (gate) ((dis 'component-exports) sys (cid gate))) gates)))
958                           
959
960                           (if (and pore (null? permqs))
961                               (nemo:error 'nemo:nmodl-translator: "ion channel definition " label
962                                              "permeating-ion component lacks exported quantities"))
963                           
964                           (for-each
965                            (lambda (st)
966                              (if (null? st)
967                                  (nemo:error 'nemo:nmodl-translator: "ion channel definition " label
968                                              "gate component lacks exported quantities")))
969                            sts)
970                           
971                           (if (not (or pore permeability))
972                               (nemo:error 'nemo:nmodl-translator: "ion channel definition " label
973                                              "lacks any pore or permeability components"))
974                           
975                           (cond ((and perm permeability (pair? gates))
976                                  (let* ((i     (nmodl-name (s+ 'i (cn perm))))
977                                         (pmax  (car ((dis 'component-exports) sys (cid permeability))))
978                                         (pwrs  (map (lambda (st) (map (lambda (n) (state-power sys n)) st)) sts))
979                                         (gpwrs (map (lambda (st pwr) (map (lambda (s p) (if p `(pow ,s ,p) s)) st pwr)) sts pwrs))
980                                         (gion  `(* ,pmax ,(sum (map (lambda (gpwr) 
981                                                                       (match gpwr ((x)  x) (else `(* ,@gpwr))))
982                                                                     gpwrs))))
983                                         )
984                                    (list i #f gion (nmodl-name (s+ 'i_ label) ))))
985                                 
986                                 ((and perm pore (pair? gates))
987                                 
988                                  (case (cn perm)
989                                    ((non-specific)
990                                     (let* ((i      (nmodl-name 'i))
991                                            (e      (car permqs))
992                                            (gmax   (car ((dis 'component-exports) sys (cid pore))))
993                                            (pwrs   (map (lambda (st) (map (lambda (n) (state-power sys n)) st)) sts))
994                                            (gpwrs  (map (lambda (st pwr) (map (lambda (s p) (if p `(pow ,s ,p) s)) st pwr)) sts pwrs))
995                                            (gion   `(* ,gmax ,(sum (map (lambda (gpwr) 
996                                                                          (match gpwr ((x)  x) (else `(* ,@gpwr))))
997                                                                        gpwrs))))
998                                            )
999                                       (list i e gion (nmodl-name (s+ 'i_ label) ))))
1000                                   
1001                                    (else
1002                                     (let* ((i          (nmodl-name (s+ 'i (cn perm))))
1003                                            (e          (car permqs))
1004                                            (gmax       (car ((dis 'component-exports) sys (cid pore))))
1005                                            (pwrs  (map (lambda (st) (map (lambda (n) (state-power sys n)) st)) sts))
1006                                            (gpwrs (map (lambda (st pwr) (map (lambda (s p) (if p `(pow ,s ,p) s)) st pwr)) sts pwrs))
1007                                            (gion  `(* ,gmax ,(sum (map (lambda (gpwr) 
1008                                                                          (match gpwr ((x)  x) (else `(* ,@gpwr))))
1009                                                                        gpwrs))))
1010                                            )
1011                                       (list i e gion (nmodl-name (s+ 'i_ label)))))))
1012                                 
1013                                 ((and perm pore)
1014                                  (case (cn perm)
1015                                    ((non-specific)
1016                                     (let* ((i      (nmodl-name 'i))
1017                                            (e      (car permqs))
1018                                            (gmax   (car ((dis 'component-exports) sys (cid pore)))))
1019                                       (list i e gmax (nmodl-name (s+ 'i_ label)))))
1020                                   
1021                                    (else
1022                                     (nemo:error 'nemo:nmodl-translator: "ion channel definition " label
1023                                                 (s+ "(" n ")")
1024                                                 "lacks gate component"))))
1025                                 
1026                                 ((and acc pore (pair? gates))
1027                                  (let* ((i     (nmodl-name (s+ 'i (cn acc))))
1028                                         (gmax  (car ((dis 'component-exports) sys (cid pore))))
1029                                         (pwrs  (map (lambda (st) (map (lambda (n) (state-power sys n)) st)) sts))
1030                                         (gpwrs (map (lambda (st pwr) (map (lambda (s p) (if p `(pow ,s ,p) s)) st pwr)) sts pwrs))
1031                                         (gion  `(* ,gmax ,(sum (map (lambda (gpwr) 
1032                                                                       (match gpwr ((x)  x) (else `(* ,@gpwr))))
1033                                                                     gpwrs))))
1034                                         )
1035                                    (list i #f gion (nmodl-name (s+ 'i_ label) ))))
1036                                 
1037                                 (else (nemo:error 'nemo:nmodl-translator: "invalid ion channel definition " 
1038                                                   label))
1039                                 )))
1040                       gate-complexes))
1041
1042               (i-eqs  (fold  (lambda (i-gate ax) 
1043                                (let ((i-gate-var (first i-gate)))
1044                                  (cons (list (nmodl-name 'i) #f i-gate-var (s+ 'i_ (second i-gate)) ) ax)))
1045                              i-eqs i-gates))
1046
1047               (i-eqs (fold (lambda (isyn psc ax)
1048                              (cons (list (first isyn) (third isyn) (second isyn) (s+ 'i_ (first psc))) ax))
1049                            i-eqs isyns pscs))
1050               
1051               (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
1052
1053               (i-eqs  (fold (lambda (b ax) 
1054                               (match b 
1055                                      ((and ps ((i e gion ii) . rst))
1056                                       (let loop ((ps ps) (summands (list)) (eqs (list)))
1057                                         (if (null? ps)
1058                                             
1059                                             (let* ((sum0  (sum summands))
1060                                                    (sum1  (rhsexpr/NMODL sum0))
1061                                                    (sum2  (canonicalize-expr/NMODL sum1)))
1062                                               (append eqs (list (list i sum2)) ax))
1063                                             
1064                                             (match-let (((i e gion ii) (car ps)))
1065                                                       
1066                                                        (loop (cdr ps) 
1067                                                              (cons ii summands) 
1068                                                              (let* ((expr0 (rhsexpr/NMODL (if e `(* ,gion (- v ,e)) gion)))
1069                                                                     (expr1 (canonicalize-expr/NMODL expr0)))
1070                                                                (cons (list ii expr1) eqs)))))))
1071                                     
1072                                      ((i e gion ii)
1073                                       (let* ((expr0  (rhsexpr/NMODL (if e `(* ,gion (- v ,e)) gion)))
1074                                              (expr1  (canonicalize-expr/NMODL expr0)))
1075                                         (cons (list i expr1) ax)))
1076                                     
1077                                      (else ax)))
1078                                (list) i-bkts))
1079               
1080               (current-locals (find-locals (map second i-eqs)))
1081
1082               (parameter-locals  (find-locals (map second parameter-defs)))
1083               
1084               (state-defs 
1085                (append
1086                 (map (lambda (st)
1087                        (if (pair? st) (nmodl-state-name (first st) (second st)) 
1088                            (nmodl-name st)))
1089                      states)
1090                 (map nmodl-name reactions)))
1091               
1092               (assigned-defs
1093                (filter-map
1094                 (lambda (x) 
1095                   (let ((x1 (nmodl-name x)))
1096                     (and (not (or (member x1 state-defs) (assoc x1 parameter-defs)))
1097                          x1)))
1098                 (delete-duplicates
1099                  (append asgns
1100                          (filter-map first imports)
1101                          (filter-map (lambda (x) (and (not (equal? (third x) 'event)) (second x))) imports)
1102                          (map second perm-ions) (map third perm-ions)
1103                          (map second acc-ions)  (map fourth acc-ions)
1104                          (map pool-ion-in pool-ions) (map pool-ion-out pool-ions)
1105                          (map (lambda (gate-complex) (nmodl-name (s+ 'i_ (first gate-complex)))) gate-complexes )
1106                          (map (lambda (i-gate) (nmodl-name (s+ 'i_ (second i-gate)))) i-gates )
1107                          (map (lambda (isyn) (nmodl-name (first isyn))) isyns )
1108                          (map (lambda (psc) (nmodl-name (s+ 'i_ (first psc)))) pscs )
1109                          ))
1110                 ))
1111
1112               (asgn-locals (find-locals (map second asgn-eq-defs)))
1113
1114               (reaction-locals (find-locals (map second reaction-eq-defs)))
1115
1116               )
1117             
1118        (let* (
1119               (tenv-enter
1120                (lambda (x env)
1121                  (let ((k (car x)) (v (cdr x)))
1122                    (print "k = " k " v = " v)
1123                    (cons (cons k (if (null? v) (ersatz:Tlist '()) (ersatz:sexpr->tvalue v))) env))))
1124
1125               (tmpl-env
1126                (fold tenv-enter '()
1127                `(
1128                  (modelName         . ,sysname)
1129                  (currentTimestamp  . ,(seconds->string (current-seconds)))
1130                  (nemoVersionString . ,(nemo:version-string))
1131                  (exports           . ,(map nmodl-name exports))
1132                  (currents          . ,(append
1133                                         (map (lambda (gate-complex) (nmodl-name (s+ 'i_ (first gate-complex)))) gate-complexes )
1134                                         (map (lambda (i-gate) (nmodl-name (s+ 'i_ (second i-gate)))) i-gates )))
1135                  (permeatingIons    . ,(map
1136                                         (match-lambda
1137                                          ((comp i e erev val) 
1138                                           `((species . ,comp) (i . ,(nmodl-name i)) 
1139                                             (e . ,(nmodl-name e)) (erev . ,erev) (valence . ,val)))
1140                                          ((comp i e erev) 
1141                                           `((species . ,comp) (i . ,(nmodl-name i)) 
1142                                             (e . ,(nmodl-name e)) (erev . ,erev))))
1143                                         perm-ions))
1144                  (modulatingIons     . ,(filter-map
1145                                          (match-lambda 
1146                                           ((ion in-conc out-conc val)
1147                                            (let ((qs (filter (lambda (x) (and x (member-imports x imports)) )
1148                                                              (list in-conc out-conc))))
1149                                              (and (not (null? qs))
1150                                                   `((in . ,in-conc) (out . ,out-conc))))))
1151                                           mod-ions))
1152                  (accumulatingIons   . ,(map
1153                                          (match-lambda ((comp i in out)
1154                                                         `((species . ,comp) (i . ,(nmodl-name i))
1155                                                           (in . ,(nmodl-name in)) (out . ,(nmodl-name out)))))
1156                                          acc-ions))
1157
1158                  (poolIons           . ,(map
1159                                          (lambda (pool-ion)
1160                                            `((ion      . ,(pool-ion-name pool-ion))
1161                                              (inq      . ,(pool-ion-inq pool-ion))
1162                                              (outq     . ,(pool-ion-outq pool-ion))
1163                                              (cur      . ,(pool-ion-cur pool-ion))
1164                                              (in       . ,(pool-ion-in pool-ion))
1165                                              (out      . ,(pool-ion-out pool-ion))
1166                                              (valence  . ,(pool-ion-valence pool-ion))))
1167                                          pool-ions))
1168                 
1169                  (useIons            . ,(map
1170                                          (lambda (x) 
1171                                            (let ((u (cdr x)))
1172                                              (print "u = " u)
1173                                              (cases useion u
1174                                                     (UseIon (name read write valence)
1175                                                             `((nonSpecific . #f)
1176                                                               (name . ,name)
1177                                                               (read . ,read)
1178                                                               (write . ,write)
1179                                                               (valence . ,valence)))
1180                                                     (NonSpecific (name)
1181                                                                  `((nonSpecific . #t)
1182                                                                    (name . ,name))))
1183                                              ))
1184                                          useions))
1185
1186                  (rangeParameters    .  ,(let* (
1187                                                 (param-names  (map (compose nmodl-name first) parameter-defs))
1188                                                 (is-const?    (lambda (x) (member x param-names)))
1189                                                 )
1190                                           (delete-duplicates 
1191                                            (fold (lambda (def ax) 
1192                                                    (let* ((rhs   (second def))
1193                                                           (vars  (cond ((nemo:rhs? rhs)
1194                                                                         (rhsvars rhs))
1195                                                                        ((extended-procedure? rhs)
1196                                                                         (let* ((fd  (procedure-data rhs))
1197                                                                                (cs  (lookup-def 'consts fd)))
1198                                                                           (map (compose nmodl-name first) cs)
1199                                                                           ))
1200                                                                        (else '())
1201                                                                        ))
1202                                                           )
1203                                                      (append (filter is-const? vars) ax)))
1204                                                  (list) 
1205                                                  (append asgn-eq-defs rate-eq-defs reaction-eq-defs defuns )))))
1206                 
1207                  (parameterLocals . ,parameter-locals)
1208
1209                  (parameterDefs . ,(map (lambda (def)
1210                                           (let ((n (nmodl-name (first def))) (b (second def)))
1211                                             (expr->string/NMODL b n)))
1212                                         parameter-defs))
1213
1214                  (stateDefs . ,state-defs )
1215
1216                  (assignedDefs . ,assigned-defs)
1217
1218                  (assignedEqLocals . ,asgn-locals)
1219
1220                  (assignedEqDefs . ,(map (lambda (def)
1221                                            (let ((n (nmodl-name (first def))) (b (second def)))
1222                                              (expr->string/NMODL b n)))
1223                                          asgn-eq-defs))
1224
1225                  (reactionEqLocals . ,reaction-locals)
1226
1227                  (reactionEqDefs . ,(map (lambda (def)
1228                                            (let ((n (nmodl-name (first def))) (b (second def)))
1229                                              (expr->string/NMODL b n)))
1230                                          reaction-eq-defs))
1231                  ))
1232                )
1233
1234               )
1235
1236
1237        (pp indent 
1238            ,(instantiate-template prelude-template tmpl-env)
1239            ,(instantiate-template neuron-template tmpl-env)
1240            ,(instantiate-template parameter-template tmpl-env)
1241            ,(instantiate-template state-template tmpl-env)
1242            ,(instantiate-template assigned-template tmpl-env)
1243            )
1244       
1245           
1246        (for-each (lambda (fndef) 
1247                    (if (not (member (car fndef) builtin-fns))
1248                        (apply fn-translator fndef)))
1249                  defuns)
1250       
1251
1252        (pp indent 
1253            ,(instantiate-template asgns-template tmpl-env)
1254            ,(instantiate-template reactions-template tmpl-env)
1255            ,(instantiate-template pools-template tmpl-env)
1256            )
1257       
1258        (if has-ode?
1259            (let ((locals   (find-locals (map second rate-eq-defs))))
1260              (case method
1261                ((expeuler) (pp indent ,nl (PROCEDURE states () "{")))
1262                (else       (pp indent ,nl (DERIVATIVE states "{"))))
1263
1264              (if (not (null? current-locals)) (pp indent+ (LOCAL ,(slp ", " current-locals))))
1265
1266              (for-each (lambda (def)
1267                          (let ((n (first def))
1268                                (b (second def)))
1269                            (pp indent+ ,(expr->string/NMODL b n))))
1270                        external-eq-defs)
1271             
1272              (if (not (null? asgns))  (pp indent+ (asgns ())))
1273
1274              (let ((prime (case method 
1275                             ((expeuler) identity)
1276                             (else  (lambda (x) (s+ x "'"))))))
1277                (for-each (lambda (def)
1278                            (let ((n (prime (first def)))
1279                                  (b (second def)))
1280                              (pp indent+ ,(expr->string/NMODL b n))))
1281                          rate-eq-defs))
1282              (pp indent "}")))
1283       
1284        (if has-kinetic?
1285            (begin
1286              (pp indent ,nl (KINETIC kstates "{"))
1287
1288              (let* ((exprs             (concatenate (map second kstate-eq-defs)))
1289                     (locals            (concatenate 
1290                                         (find-locals
1291                                          (append (map fourth exprs)
1292                                                  (filter-map (lambda (x) (and (> (length x) 4) (fifth x))) exprs))))))
1293                (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals))))
1294               
1295                (for-each (lambda (def)
1296                            (let ((n (first def))
1297                                  (b (second def)))
1298                              (pp indent+ ,(expr->string/NMODL b n))))
1299                          external-eq-defs)
1300
1301                (if (not (null? asgns))     (pp indent+ (asgns ())))
1302                (for-each
1303                 (lambda (def)
1304                   (let* ((n     (first def))
1305                          (eqs   (let ((eqs (second def)))
1306                                   (let-values (((pair-eqs1 rest)
1307                                                 (partition (lambda (eq) (match eq (('<-> a b r1 r2) eq) (else #f))) eqs)))
1308                                     (let ((pair-eqs2
1309                                            (append
1310                                             (filter-map 
1311                                              (lambda (eq)
1312                                                (match eq
1313                                                       (('-> s0 s1 rexpr) 
1314                                                        (let ((rev
1315                                                               (find (lambda (r) 
1316                                                                       (match r (('-> t0 t1 texpr)
1317                                                                                 (and (equal? s0 t1) (equal? s1 t0) texpr))
1318                                                                              (else #f)))
1319                                                                     eqs)))
1320                                                          (if rev
1321                                                              `(<-> ,s0 ,s1 ,rexpr ,(fourth rev))
1322                                                              (error  'nemo-nmodl "-> kinetic equation not supported in NMODL" eq))))
1323                                                       (('<-> s0 s1 rexpr1 rexpr2)  #f)
1324                                                       ))
1325                                              rest))))
1326                                     (append pair-eqs1 (delete-duplicates 
1327                                                        pair-eqs2 
1328                                                        (lambda (x y) 
1329                                                          (match (list x y)
1330                                                                 ((('<-> s0 s1 s t) ('<-> t0 t1 u v))
1331                                                                  (and (equal? s0 t1) (equal? s1 t0)))
1332                                                                 (else #f)))))
1333                                                                                                         
1334                                     ))
1335                                   ))
1336                          (conserve-eqs  (lookup-def (nmodl-name n) conserve-eq-defs)))
1337                     (for-each
1338                      (lambda (eq)
1339                        (match eq
1340                               (('-> s0 s1 rexpr) 
1341                                (error 'nemo-nmodl "-> kinetic equation not supported in NMODL" eq))
1342                               (('<-> s0 s1 rexpr1 rexpr2) 
1343                                (pp indent+ (~ ,s0 <-> ,s1 (,(expr->string/NMODL rexpr1) #\,
1344                                                            ,(expr->string/NMODL rexpr2) 
1345                                                            ))))
1346                               ))
1347                      eqs)
1348                     (if conserve-eqs
1349                         (for-each (lambda (eq) 
1350                                     (let ((val  (first eq))
1351                                           (expr (third eq)))
1352                                       (pp indent+ ,(conserve-conseq->string/NMODL expr val))))
1353                                   conserve-eqs))
1354                     ))
1355                 kstate-eq-defs))
1356              (pp indent "}")))
1357       
1358       
1359        (let ((locals (find-locals (map second state-init-defs)))) 
1360
1361          (pp indent ,nl (INITIAL "{"))
1362         
1363          (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals))))
1364
1365          (for-each (lambda (def)
1366                      (let ((n (first def))
1367                            (b (second def)))
1368                        (pp indent+ ,(expr->string/NMODL b n))))
1369                    external-eq-defs)
1370
1371          (if (not (null? asgns))  (pp indent+ (asgns ())))
1372
1373          (for-each (lambda (def)
1374                      (let ((n (first def)) (b (second def)))
1375                        (pp indent+ ,(expr->string/NMODL b n)))) 
1376                    state-init-defs)
1377
1378          (if has-kinetic?
1379              (pp indent+
1380                  (SOLVE kstates STEADYSTATE sparse)
1381                  ("reactions ()")
1382                ))
1383         
1384          (for-each
1385           (lambda (gate-complex) 
1386             
1387             (let* ((label             (first gate-complex))
1388                    (n                 (second gate-complex))
1389                    (subcomps          ((dis 'component-subcomps) sys n))
1390                    (perm              (lookup-def 'permeating-ion subcomps))
1391                    (permqs            (and perm ((dis 'component-exports) sys (cid perm))))
1392                    )
1393               
1394               (if perm
1395                   
1396                   (case (cn perm)
1397                     ((non-specific)
1398                      (let* ((e      (nmodl-name 'e))
1399                             (elocal (car permqs)))
1400                        (if (not (equal? e elocal))
1401                            (pp indent+ ,(expr->string/NMODL (nmodl-name elocal) e)))))
1402                     ))
1403                     
1404               ))
1405           gate-complexes)
1406
1407          (if (not (null? pool-ions)) (pp indent+ (pools ())))
1408         
1409          (pp indent "}")
1410
1411          (if has-events?
1412              (let* (
1413                     (locals (find-locals (map second transient-event-defs)))
1414                     (vars   (delete-duplicates
1415                              (filter-map 
1416                               (lambda (x) (let ((ns (third x)))
1417                                           (and (equal? ns 'event) (second x))))
1418                             imports)))
1419                     (external-eq-defs   (sys->external-eq-defs sys nmodl-name rhsexpr/NMODL canonicalize-expr/NMODL
1420                                                                namespace-filter: (lambda (x) (equal? x 'event))))
1421                     )
1422               
1423                (pp indent ,nl (NET_RECEIVE (,(slp ", " vars)) "{"))
1424
1425                (for-each (lambda (def)
1426                            (let ((n (nmodl-name (first def)) )
1427                                  (b (second def)))
1428                              (pp indent+ ,(expr->string/NMODL b n))))
1429                          external-eq-defs)
1430
1431                (for-each (lambda (def)
1432                            (let ((n (nmodl-name (first def)) )
1433                                  (b (second def)))
1434                              (pp indent+ ,(expr->string/NMODL b n))))
1435                          transient-event-defs)
1436
1437                (pp indent "}")
1438                ))
1439           
1440          (pp indent ,nl (PROCEDURE print_state () "{"))
1441
1442          (let ((lst (sort (map (compose ->string first) rate-eq-defs) string<?)))
1443            (for-each (lambda (x)
1444                        (pp indent+ (printf (,(s+ #\" "NMODL state: t = %g v = %g "  x " = %g\\n"  #\") ", t, v, " ,x ))))
1445                      lst))
1446         
1447          (let ((lst (sort (map (compose ->string first) reaction-eq-defs) string<?)))
1448            (for-each (lambda (x)
1449                        (pp indent+ (printf (,(s+ #\" "NMODL state: t = %g v = %g "  x " = %g\\n"  #\") ", t, v, " ,x ))))
1450                      lst))
1451         
1452          (pp indent "}")
1453         
1454          ))
1455      ))
1456  ))
1457))
1458
1459
Note: See TracBrowser for help on using the repository browser.