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

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

Include support for complex prefixes in the names of transition states.

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