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

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

More bug fixes.

File size: 24.7 KB
Line 
1
2;; TODO: * uniquify state names in state complexes
3;;       * check that open states are valid
4;;
5;;
6;; An extension for translating NeuroML models to NMODL descriptions.
7;;
8;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
9;;
10;; This program is free software: you can redistribute it and/or
11;; modify it under the terms of the GNU General Public License as
12;; published by the Free Software Foundation, either version 3 of the
13;; License, or (at your option) any later version.
14;;
15;; This program is distributed in the hope that it will be useful, but
16;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;; General Public License for more details.
19;;
20;; A full copy of the GPL license can be found at
21;; <http://www.gnu.org/licenses/>.
22;;
23
24(require-extension syntax-case)
25(require-extension matchable)
26(require-extension strictly-pretty)
27(require-extension environments)
28(require-extension nemo-core)
29(require-extension srfi-1)
30(require-extension srfi-4)
31(require-extension srfi-13)
32(require-extension srfi-14)
33(require-extension runcmd)
34(require-extension utils)
35(require-extension lolevel)
36(require-extension varsubst)
37(require-extension digraph)
38(require-extension datatype)
39
40(define (lookup-def k lst . rest)
41  (let-optionals rest ((default #f))
42      (let ((kv (assoc k lst)))
43        (if (not kv) default
44            (match kv ((k v) v) (else (cdr kv)))))))
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
57(define (enumprocs expr ax)
58  (match expr 
59         (('if . es)  (fold enumprocs ax es))
60         (('let bnds body)  (fold enumprocs (fold enumprocs ax (map cadr bnds)) body))
61         ((s . es)    (if (symbol? s)  (cons s (fold enumprocs ax es)) ax))
62         (else ax)))
63
64(define (enumbnds expr ax)
65  (match expr 
66         (('if . es)        (fold enumbnds ax es))
67         (('let bnds body)  (enumbnds body (append (map car bnds) (fold enumbnds ax (map cadr bnds)))))
68         ((s . es)          (if (symbol? s)  (fold enumbnds ax es) ax))
69         (else ax)))
70
71
72(define (enum-freevars expr bnds ax)
73  (match expr 
74         (('if . es) 
75          (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
76         (('let bnds body) 
77          (let ((bnds1 (append (map first bnds) bnds)))
78            (enum-freevars body bnds1 (fold (lambda (x ax) (enum-freevars x bnds ax)) ax (map second bnds)))))
79         ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
80         (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
81
82(define (rhsvars rhs)
83  (enum-freevars rhs (list) (list)))
84
85(define (rhsexpr expr)
86  (match expr 
87         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr x)) es)))
88         (('pow x y)  (if (and (integer? y)  (positive? y))
89                          (if (> y 1)  (let ((tmp (gensym "x")))
90                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
91                              x)
92                            expr))
93         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
94         (id          id)))
95
96
97;;; Procedures for string concatenation and pretty-printing
98
99(define (s+ . lst)    (string-concatenate (map ->string lst)))
100(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
101(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
102(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
103(define nl "\n")
104
105(define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
106
107(define (ppf indent . lst)
108  (let ((sp (spaces indent)))
109    (for-each (lambda (x)
110                (and x (match x 
111                              ((i . x1) (if (and (number? i) (positive? i))
112                                            (for-each (lambda (x) (ppf (+ indent i) x)) x1)
113                                            (print sp (sw+ x))))
114                              (else   (print sp (if (list? x) (sw+ x) x))))))
115              lst)))
116
117
118(define-syntax pp
119  (syntax-rules ()
120    ((pp indent val ...) (ppf indent (quasiquote val) ...))))
121
122(define ifthen/NMODL  (doc:ifthen 0 (doc:text "if") (doc:text "") (doc:text "else")))
123(define letblk/NMODL  (doc:letblk 2 (doc:empty) (doc:break) (doc:empty)))
124(define group/NMODL   (doc:block 2 (doc:text "(") (doc:text ")")))
125(define block/NMODL   (doc:block 2 (doc:text "{") (doc:text "}")))
126(define binop/NMODL   (doc:binop 2))
127
128(define (format-op/NMODL indent op args)
129  (let ((op1 (doc:text (->string op))))
130    (if (null? args) op1
131        (match args
132               ((x)           (doc:connect op1 x))
133               ((x y)         (binop/NMODL x op1 y))
134               ((x y z)       (binop/NMODL x op1 (binop/NMODL y op1 z)))
135               (lst           (let* ((n   (length lst))
136                                     (n/2 (inexact->exact (round (/ n 2)))))
137                                (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 
138                                         (format-op/NMODL indent op (drop lst n/2 )))))))))
139
140(define (format-fncall/NMODL indent op args)
141  (let ((op1 (doc:text (->string op))))
142    (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args)))))
143
144(define nmodl-builtin-consts
145  `(celsius diam))
146
147(define nmodl-ops
148  `(+ - * / > < <= >= = ^))
149
150(define builtin-fns
151  `(+ - * / pow neg abs atan asin acos sin cos exp ln
152      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
153      > < <= >= = and or round ceiling floor max min
154      fpvector-ref))
155
156(define (sum lst)
157  (if (null? lst) lst
158      (match lst
159             ((x)   x)
160             ((x y) `(+ ,x ,y))
161             ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
162             ((x . rest) `(+ ,x ,(sum rest))))))
163
164
165(define (subst-term t subst k)
166  (match t
167         (('if c t e)
168          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
169         (('let bs e)
170          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
171         ((f . es)
172          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
173         ((? symbol? )  (lookup-def t subst t))
174         ((? atom? ) t)))
175
176(define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
177
178(define (bind ks vs e) `(let ,(zip ks vs) ,e))
179
180
181(define (if-convert expr)
182  (match expr 
183         (('if c t e) 
184          (let ((r (gensym "if")))
185            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
186               ,r)))
187         (('let bs e)
188          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
189         ((f . es)
190          (cons f (map if-convert es)))
191         ((? atom? ) expr)))
192
193         
194(define (let-enum expr ax)
195  (match expr
196         (('let ((x ('if c t e))) y)
197          (let ((ax (fold let-enum ax (list c ))))
198            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
199
200         (('let bnds body)  (let-enum body (append ax bnds)))
201
202         (('if c t e)  (let-enum ax c))
203
204         ((f . es)  (fold let-enum ax es))
205
206         (else ax)))
207
208
209(define (let-elim expr)
210  (match expr
211         (('let ((x ('if c t e))) y)
212          (if (eq? x y)  y expr))
213
214         (('let bnds body) (let-elim body))
215
216         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
217
218         ((f . es)  `(,f . ,(map let-elim es)))
219
220         (else expr)))
221 
222
223(define (let-lift expr)
224  (let ((bnds (let-enum expr (list))))
225    (if (null? bnds) expr
226        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
227
228(define (canonicalize-expr/NMODL expr)
229  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
230    (let* ((expr1 (if-convert expr))
231           (expr2 (subst-convert expr1 subst-empty))
232           (expr3 (let-lift expr2)))
233      expr3)))
234
235(define (format-expr/NMODL indent expr . rest) 
236  (let-optionals rest ((rv #f))
237   (let ((indent+ (+ 2 indent)))
238    (match expr
239       (('let bindings body)
240        (letblk/NMODL
241         (fold-right 
242           (lambda (x ax)
243             (letblk/NMODL
244              (match (second x)
245                     (('if c t e)
246                      (ifthen/NMODL
247                       (group/NMODL (format-expr/NMODL indent c))
248                       (block/NMODL (format-expr/NMODL indent t (first x)))
249                       (block/NMODL (format-expr/NMODL indent e (first x)))))
250                     (else
251                      (format-op/NMODL indent+ " = "
252                                       (list (format-expr/NMODL indent (first x) )
253                                             (format-expr/NMODL indent (second x))))))
254              ax))
255           (doc:empty) bindings)
256         (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
257           (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
258               body1))))
259       
260       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))
261
262       ((op . rest) 
263       (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
264         (let ((fe
265                (if (member op nmodl-ops)
266                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
267                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
268                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
269                      (case op
270                        ((/) 
271                         (format-op/NMODL indent op 
272                                          (map (lambda (x) 
273                                                 (let ((fx (format-expr/NMODL indent+ x)))
274                                                   (if (or (symbol? x) (number? x)) fx
275                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
276                        ((*) 
277                         (format-op/NMODL indent op 
278                                          (map (lambda (x) 
279                                                 (let ((fx (format-expr/NMODL indent+ x)))
280                                                   (if (or (symbol? x) (number? x)) fx
281                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
282                       
283                        ((^) 
284                         (format-op/NMODL indent op 
285                                          (map (lambda (x) 
286                                                 (let ((fx (format-expr/NMODL indent+ x)))
287                                                   (if (or (symbol? x)  (number? x)) fx
288                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
289                       
290                        (else
291                         (format-op/NMODL indent op 
292                                          (map (lambda (x) 
293                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
294                   
295                    (let ((op (case op ((neg) '-) (else op))))
296                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
297           (if rv 
298               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
299               fe))))
300     
301      (else  (let ((fe (doc:text (->string expr))))
302               (if rv 
303                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
304                   fe)))))))
305               
306
307         
308(define (expr->string/NMODL x . rest)
309  (let-optionals rest ((rv #f) (width 72))
310    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
311 
312
313(define (make-define-fn table? min-v max-v with depend)
314  (lambda (indent n proc)
315    (let ((lst (procedure-data proc))
316          (indent+ (+ 2 indent)))
317      (let ((rt       (lookup-def 'rt lst))
318            (formals  (lookup-def 'formals lst))
319            (vars     (lookup-def 'vars lst))
320            (body     (lookup-def 'body lst)))
321        (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" ))
322        (let* ((body1 (canonicalize-expr/NMODL (rhsexpr body)))
323               (lbs   (enumbnds body1 (list))))
324          (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " 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 n)))
331        (pp indent "}"))) 
332    ))
333
334(define (define-state indent n)
335  (pp indent (,n)))
336
337
338(define (state-eqs n initial open transitions power)
339  (let* ((g (make-digraph n (string-append (->string n) " transitions graph")))
340         (add-node!  (g 'add-node!))
341         (add-edge!  (g 'add-edge!))
342         (out-edges  (g 'out-edges))
343         (in-edges   (g 'in-edges))
344         (node-info  (g 'node-info))
345         (node-list  (let loop ((lst (list)) (tlst transitions))
346                       (if (null? tlst)  (delete-duplicates lst eq?)
347                           (match (car tlst) 
348                                  (('-> s0 s1 rate-expr)
349                                   (loop (cons s0 (cons s1 lst)) (cdr tlst)))
350                                  (('-> _)
351                                   (nemo:error 'nemo:nmodl-state-eqs ": invalid transition equation " 
352                                                  (car tlst) " in state complex " n))
353                                  (else (loop lst (cdr tlst)))))))
354         (node-ids      (list-tabulate (length node-list) identity))
355         (name->id-map  (zip node-list node-ids)))
356    ;; insert state nodes in the dependency graph
357    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
358    (let* ((nodes  ((g 'nodes)))
359           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
360           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes)))))
361      ;; create rate edges in the graph
362      (for-each (lambda (e) 
363                  (match e (('-> s0 s1 rate-expr)
364                            (let ((i  (car (alist-ref s0 name->id-map)))
365                                  (j  (car (alist-ref s1 name->id-map)))
366                                  (x  (if (eq? s0 (second snode)) snex s0)))
367                            (add-edge! (list i j `(* ,x ,rate-expr)))))
368                         (else (void))))
369                transitions)
370      ;; generate differential equations for each state in the transitions system
371      (let ((eqs    (fold (lambda (s ax) 
372                            (if (= (first snode) (first s) ) ax
373                                (let* ((out   (out-edges (first s)))
374                                       (in    (in-edges (first s)))
375                                       (open? (eq? (second s) open))
376                                       (name  (second s)))
377                                  (let* ((rhs1  (cond ((and (not (null? out)) (not (null? in)))
378                                                       `(+ (neg ,(sum (map third out)))
379                                                           ,(sum (map third in))))
380                                                      ((and (not (null? out)) (null? in))
381                                                       `(neg ,(sum (map third out))))
382                                                      ((and (null? out) (not (null? in)))
383                                                       (sum (map third in)))))
384                                         (fbody  (rhsexpr rhs1))
385                                         (fbody1 (canonicalize-expr/NMODL fbody)))
386                                    (cons (list (s+ name "'") fbody1) ax)))))
387                          (list) nodes)))
388        eqs))))
389           
390       
391
392
393(define (state-init n init)
394  (let* ((init  (rhsexpr init))
395         (init1 (canonicalize-expr/NMODL init)))
396    (list  n init1)))
397
398(define (asgn-eq n rhs)
399  (let* ((fbody   (rhsexpr rhs))
400         (fbody1  (canonicalize-expr/NMODL fbody)))
401    (list n fbody1)))
402
403
404(define (stcomp-eq n open transitions)
405  (list n open))
406
407
408(define (poset->asgn-eq-defs poset sys)
409  (fold-right
410   (lambda (lst ax)
411     (fold  (lambda (x ax) 
412              (match-let (((i . n)  x))
413                         (let ((en (environment-ref sys n)))
414                           (if (nemo:quantity? en)
415                               (cases nemo:quantity en
416                                      (ASGN  (name value rhs) (cons (asgn-eq name rhs) ax))
417                                      (else  ax))
418                               ax))))
419            ax lst))
420   (list) poset))
421
422
423(define (poset->state-eq-defs poset sys)
424  (fold-right
425   (lambda (lst ax)
426     (fold  (lambda (x ax) 
427              (match-let (((i . n)  x))
428                         (let ((en (environment-ref sys n)))
429                           (if (nemo:quantity? en)
430                               (cases nemo:quantity en
431                                      (TSCOMP  (name initial open transitions power) 
432                                               (append (state-eqs name initial open transitions power) ax))
433                                      (else  ax))
434                               ax))))
435            ax lst))
436   (list) poset))
437
438
439(define (poset->stcomp-eq-defs poset sys)
440  (fold-right
441   (lambda (lst ax)
442     (fold  (lambda (x ax) 
443              (match-let (((i . n)  x))
444                         (let ((en (environment-ref sys n)))
445                           (if (nemo:quantity? en)
446                               (cases nemo:quantity en
447                                      (TSCOMP  (name initial open transitions power) 
448                                               (cons (stcomp-eq name open transitions) ax))
449                                      (else  ax))
450                               ax))))
451            ax lst))
452   (list) poset))
453
454(define (poset->state-init-defs poset sys)
455  (fold-right
456   (lambda (lst ax)
457     (fold  (lambda (x ax) 
458              (match-let (((i . n)  x))
459                         (let ((en (environment-ref sys n)))
460                           (if (nemo:quantity? en)
461                               (cases nemo:quantity en
462                                      (TSCOMP  (name initial open transitions power) 
463                                               (cons* (state-init name initial) (state-init open name) ax))
464                                      (else  ax))
465                               ax))))
466            ax lst))
467   (list) poset))
468
469(define (find-locals defs)
470  (concatenate 
471   (map (lambda (def) (match (second def) (('let bnds _) (map first bnds)) (else (list))))
472        defs)))
473
474
475(define (state-power sys n)
476  (let ((en (environment-ref sys n)))
477    (if (nemo:quantity? en)
478        (cases nemo:quantity en
479               (TSCOMP  (name initial open transitions power)  power)
480               (else  #f))  #f)))
481
482(define (bucket-partition p lst)
483  (let loop ((lst lst) (ax (list)))
484    (if (null? lst) ax
485        (let ((x (car lst)))
486          (let bkt-loop ((old-bkts ax) (new-bkts (list)))
487            (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts))
488                (if (p x (caar old-bkts ))
489                    (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts)))
490                    (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts)))))))))
491
492
493(define (nemo:nmodl-translator sys . rest)
494  (define (cid x) (second x))
495  (define (cn x) (first x))
496  (let-optionals rest ((method 'cnexp) (table? #f) (min-v -100) (max-v 100) (step 0.5) (depend #f) )
497  (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref sys (nemo-intern 'dispatch))))
498    (let ((imports  ((dis 'imports)  sys))
499          (exports  ((dis 'exports)  sys)))
500      (let* ((indent  0)
501             (indent+ (+ 2 indent ))
502             (sysname (nmodl-name ((dis 'sysname) sys)))
503             (deps*   ((dis 'depgraph*) sys))
504             (consts  ((dis 'consts) sys))
505             (asgns   ((dis 'asgns) sys))
506             (states  ((dis 'states) sys))
507             (stcomps ((dis 'stcomps) sys))
508             (defuns  ((dis 'defuns) sys))
509             (components ((dis 'components) sys))
510             (ionchs  (filter-map (match-lambda ((name 'ion-channel id) (list name id)) (else #f)) components))) 
511        (match-let (((state-list asgn-list g) deps*))
512         (let* ((poset          (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
513                (asgn-eq-defs   (poset->asgn-eq-defs poset sys))
514                (perm-ions (delete-duplicates
515                            (fold (lambda (ionch ax) 
516                                    (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
517                                           (perm      (lookup-def 'permeating-substance subcomps)))
518                                      (if perm 
519                                          (case (cn perm)
520                                            ((non-specific)   
521                                             (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
522                                                    (i    (nmodl-name 'i))
523                                                    (e    (nmodl-name 'e)))
524                                               (cons `(,(cn perm) ,i ,e ,erev) ax)))
525                                            (else (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
526                                                         (i    (nmodl-name (s+ 'i (cn perm))))
527                                                         (e    (nmodl-name (s+ 'e (cn perm)))))
528                                                    (cons `(,(cn perm) ,i ,e ,erev) ax))))
529                                          ax)))
530                                  (list) ionchs)
531                            (lambda (x y) (eq? (car x) (car y)))))
532               (acc-ions (delete-duplicates
533                           (fold (lambda (ionch ax) 
534                                  (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
535                                         (acc   (lookup-def 'accumulating-substance subcomps))
536                                         (i     (and acc (nmodl-name (s+ 'i (cn acc)))))
537                                         (in    (and acc (nmodl-name (s+ (cn acc) 'i))))
538                                         (out   (and acc (nmodl-name (s+ (cn acc) 'o)))))
539                                    (if acc  (cons `(,(cn acc) ,i ,in ,out) ax) ax)))
540                                (list) ionchs)
541                           (lambda (x y) (eq? (car x) (car y)))))
542               )
543
544           (pp indent ,nl (TITLE ,sysname))
545           
546           (pp indent ,nl (NEURON "{"))
547           (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
548           (for-each (lambda (x)
549                       (case (first x)
550                         ((non-specific) 
551                          (pp indent+ (RANGE ,(third x))
552                              (NONSPECIFIC_CURRENT ,(second x))))
553                         (else
554                          (pp indent+ (RANGE ,(second x))
555                              (USEION ,(first x) READ ,(third x) WRITE ,(second x))))))
556                     perm-ions)
557           (for-each (lambda (x)
558                       (pp indent+ (RANGE ,(second x))
559                           (USEION ,(first x) READ ,(third x) ", " ,(fourth x) WRITE ,(second x))))
560                     acc-ions)
561           (let* ((const-names   (map first consts))
562                  (is-const?     (lambda (x) (member x const-names)))
563                  (range-consts  (delete-duplicates 
564                                  (fold (lambda (def ax) 
565                                          (let* ((rhs   (second def))
566                                                 (vars  (rhsvars rhs)))
567                                            (append (filter is-const? vars) ax)))
568                                        (list) asgn-eq-defs ))))
569             (if (not (null? range-consts)) (pp indent+ (RANGE ,(sl\ ", " range-consts)))))
570           
571           
572           (pp indent "}")
573           
574           
575           (pp indent ,nl (PARAMETER "{"))
576           (let* ((const-defs (filter-map
577                               (lambda (nv)
578                                 (and (not (member (first nv) nmodl-builtin-consts))
579                                      (let ((v1 (canonicalize-expr/NMODL (second nv))))
580                                        (list (first nv) v1))))
581                                   consts))
582                  (locals  (find-locals const-defs)))
583             (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
584             (for-each (lambda (def)
585                         (let ((n (first def)) (b (second def)))
586                           (pp indent+ ,(expr->string/NMODL b n)))) const-defs))
587           (pp indent "}")
588           
589           (let* ((with      (inexact->exact (round (/ (abs (- max-v min-v)) step))))
590                  (define-fn (make-define-fn table? min-v max-v with depend)))
591             (for-each (lambda (fndef) 
592                         (if (not (member (car fndef) builtin-fns))
593                             (apply define-fn (cons indent fndef)))) 
594                       defuns))
595           
596           
597           (pp indent ,nl (STATE "{"))
598           (for-each (lambda (st) (apply define-state (list indent+ st)))
599                     states)
600           (for-each (lambda (st) (apply define-state (list indent+ st)))
601                     stcomps)
602           (pp indent "}")
603           
604           (pp indent ,nl (ASSIGNED "{"))
605           (let* ((asgns0 (append asgns (map first imports) 
606                                  (map second perm-ions) (map third perm-ions)
607                                  (map second acc-ions) (map fourth acc-ions)))
608                  (asgns1 (delete-duplicates asgns0)))
609             (for-each (lambda (x) (pp indent+ ,x)) asgns1)
610             (pp indent "}")
611             
612             (if (not (null? asgns))
613                 (begin
614                   (pp indent ,nl (PROCEDURE rates () "{"))
615                   (let ((locals    (find-locals asgn-eq-defs))) 
616                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))))
617                   (for-each (lambda (def)
618                               (let ((n (first def)) 
619                                     (b (second def)))
620                                 (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs)
621                   (pp indent "}")))
622             
623             (if (not (null? stcomps))
624                 (begin
625                   (pp indent ,nl (PROCEDURE stcomps () "{"))
626                   (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
627                          (locals    (find-locals eq-defs))) 
628                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
629                     (for-each (lambda (def)
630                                 (let ((n (first def)) (b (second def)))
631                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
632                   
633                   (pp indent "}")))
634             
635             (pp indent ,nl (BREAKPOINT "{"))
636             (let* ((i-eqs (filter-map
637                            (lambda (ionch) 
638                              (let* ((n     (second ionch))
639                                     (subcomps ((dis 'component-subcomps) sys n))
640                                     (acc   (lookup-def 'accumulating-substance subcomps))
641                                     (perm  (lookup-def 'permeating-substance subcomps))
642                                     (pore  (lookup-def 'pore subcomps))
643                                     (gate  (lookup-def 'gate subcomps))
644                                     (sts   (and gate ((dis 'component-exports) sys (cid gate)))))
645                                (cond ((and perm pore gate)
646                                       (case (cn perm)
647                                         ((non-specific)
648                                          (let* ((i     (nmodl-name 'i))
649                                                 (e     (nmodl-name 'e))
650                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
651                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
652                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
653                                            (list i e gion)))
654                                         (else
655                                          (let* ((i     (nmodl-name (s+ 'i (cn perm))))
656                                                 (e     (nmodl-name (s+ 'e (cn perm))))
657                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
658                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
659                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
660                                            (list i e gion)))))
661                                      ((and acc pore gate)
662                                       (let* ((i     (nmodl-name (s+ 'i (cn acc))))
663                                              (gmax  (car ((dis 'component-exports) sys (cid pore))))
664                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
665                                              (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
666                                         (list i #f gion)))
667                                      (else (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " n))
668                                      )))
669                            ionchs))
670                    (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
671                    (i-eqs  (fold (lambda (b ax) 
672                                    (match b 
673                                           ((and ps ((i e gion) . rst)) 
674                                            (let* ((sum   (if e `(* ,(sum (map third ps)) (- v ,e))
675                                                              (sum (map third ps))))
676                                                   (sum0  (rhsexpr sum))
677                                                   (sum1  (canonicalize-expr/NMODL sum0)))
678                                              (cons (list i sum1) ax)))
679                                           
680                                           ((i e gion)
681                                            (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
682                                                   (expr1  (canonicalize-expr/NMODL expr0)))
683                                              (cons (list i expr1) ax)))
684                                           
685                                           
686                                           (else ax)))
687                                  (list) i-bkts))
688                    (locals (find-locals i-eqs)))
689               (if (not (null? locals))   (pp indent+ (LOCAL ,(sl\ ", " locals))))
690               (if (not (null? asgns))    (pp indent+ (rates ())))
691               (if (not method) (pp indent+ (SOLVE states))
692                   (pp indent+ (SOLVE states METHOD ,method)))
693               (if (not (null? stcomps))  (pp indent+ (stcomps ())))
694               (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
695               (pp indent "}"))
696             
697             (if (not (null? states))
698                 (begin
699                   (pp indent ,nl (DERIVATIVE states "{"))
700                   (let* ((eq-defs (reverse (poset->state-eq-defs poset sys)))
701                          (locals (find-locals eq-defs))) 
702                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
703                     (for-each (lambda (def)
704                                 (let ((n (first def)) (b (second def)))
705                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
706                   (pp indent "}")))
707             
708             (pp indent ,nl (INITIAL "{"))
709             (let* ((init-defs  (poset->state-init-defs poset sys))
710                    (locals     (concatenate (find-locals init-defs)))) 
711               (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
712               (if (not (null? asgns))  (pp indent+ (rates ())))
713               (for-each (lambda (def)
714                           (let ((n (first def)) (b (second def)))
715                             (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
716               (for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))
717                         perm-ions))
718             (pp indent "}")
719             
720             )))
721        )))))
Note: See TracBrowser for help on using the repository browser.