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

Last change on this file since 11996 was 11996, checked in by Ivan Raikov, 12 years ago

Added some useful shortcuts for tau/inf to alpha/beta conversion.

File size: 25.1 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(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 f (map name-normalize es)))
187         ((? symbol? ) (nmodl-name expr))
188         ((? atom? ) expr)))
189
190(define (if-convert expr)
191  (match expr 
192         (('if c t e) 
193          (let ((r (gensym "if")))
194            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
195               ,r)))
196         (('let bs e)
197          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
198         ((f . es)
199          (cons f (map if-convert es)))
200         ((? atom? ) expr)))
201
202         
203(define (let-enum expr ax)
204  (match expr
205         (('let ((x ('if c t e))) y)
206          (let ((ax (fold let-enum ax (list c ))))
207            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
208
209         (('let bnds body)  (let-enum body (append ax bnds)))
210
211         (('if c t e)  (let-enum ax c))
212
213         ((f . es)  (fold let-enum ax es))
214
215         (else ax)))
216
217
218(define (let-elim expr)
219  (match expr
220         (('let ((x ('if c t e))) y)
221          (if (eq? x y)  y expr))
222
223         (('let bnds body) (let-elim body))
224
225         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
226
227         ((f . es)  `(,f . ,(map let-elim es)))
228
229         (else expr)))
230 
231
232(define (let-lift expr)
233  (let ((bnds (let-enum expr (list))))
234    (if (null? bnds) expr
235        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
236
237(define (canonicalize-expr/NMODL expr)
238  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
239    (let* ((expr1 (if-convert expr))
240           (expr2 (subst-convert expr1 subst-empty))
241           (expr3 (let-lift expr2))
242           (expr4 (name-normalize expr3)))
243      expr4)))
244
245(define (format-expr/NMODL indent expr . rest) 
246  (let-optionals rest ((rv #f))
247   (let ((indent+ (+ 2 indent)))
248    (match expr
249       (('let bindings body)
250        (letblk/NMODL
251         (fold-right 
252           (lambda (x ax)
253             (letblk/NMODL
254              (match (second x)
255                     (('if c t e)
256                      (ifthen/NMODL
257                       (group/NMODL (format-expr/NMODL indent c))
258                       (block/NMODL (format-expr/NMODL indent t (first x)))
259                       (block/NMODL (format-expr/NMODL indent e (first x)))))
260                     (else
261                      (format-op/NMODL indent+ " = "
262                                       (list (format-expr/NMODL indent (first x) )
263                                             (format-expr/NMODL indent (second x))))))
264              ax))
265           (doc:empty) bindings)
266         (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
267           (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
268               body1))))
269       
270       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))
271
272       ((op . rest) 
273       (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
274         (let ((fe
275                (if (member op nmodl-ops)
276                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
277                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
278                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
279                      (case op
280                        ((/) 
281                         (format-op/NMODL indent op 
282                                          (map (lambda (x) 
283                                                 (let ((fx (format-expr/NMODL indent+ x)))
284                                                   (if (or (symbol? x) (number? x)) fx
285                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
286                        ((*) 
287                         (format-op/NMODL indent op 
288                                          (map (lambda (x) 
289                                                 (let ((fx (format-expr/NMODL indent+ x)))
290                                                   (if (or (symbol? x) (number? x)) fx
291                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
292                       
293                        ((^) 
294                         (format-op/NMODL indent op 
295                                          (map (lambda (x) 
296                                                 (let ((fx (format-expr/NMODL indent+ x)))
297                                                   (if (or (symbol? x)  (number? x)) fx
298                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
299                       
300                        (else
301                         (format-op/NMODL indent op 
302                                          (map (lambda (x) 
303                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
304                   
305                    (let ((op (case op ((neg) '-) (else op))))
306                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
307           (if rv 
308               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
309               fe))))
310     
311      (else  (let ((fe (doc:text (->string expr))))
312               (if rv 
313                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
314                   fe)))))))
315               
316
317         
318(define (expr->string/NMODL x . rest)
319  (let-optionals rest ((rv #f) (width 72))
320    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
321 
322
323(define (make-define-fn table? min-v max-v with depend)
324  (lambda (indent n proc)
325    (let ((lst (procedure-data proc))
326          (indent+ (+ 2 indent)))
327      (let ((rt       (lookup-def 'rt lst))
328            (formals  (lookup-def 'formals lst))
329            (vars     (lookup-def 'vars lst))
330            (body     (lookup-def 'body lst)))
331        (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" ))
332        (let* ((body1 (canonicalize-expr/NMODL (rhsexpr body)))
333               (lbs   (enumbnds body1 (list))))
334          (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " lbs))))
335          (if (and table? min-v max-v with)
336              (match vars
337                     (('v)  (pp indent+ (TABLE ,@(if depend `(DEPEND ,depend) `(""))
338                                               FROM ,min-v TO ,max-v WITH ,with)))
339                     (else  (void))))
340          (pp indent+ ,(expr->string/NMODL body1 n)))
341        (pp indent "}"))) 
342    ))
343
344(define (define-state indent n)
345  (pp indent (,n)))
346
347
348(define (state-eqs n initial open transitions power)
349  (let* ((g (make-digraph n (string-append (->string n) " transitions graph")))
350         (add-node!  (g 'add-node!))
351         (add-edge!  (g 'add-edge!))
352         (out-edges  (g 'out-edges))
353         (in-edges   (g 'in-edges))
354         (node-info  (g 'node-info))
355         (node-list  (let loop ((lst (list)) (tlst transitions))
356                       (if (null? tlst)  (delete-duplicates lst eq?)
357                           (match (car tlst) 
358                                  (('-> s0 s1 rate-expr)
359                                   (loop (cons s0 (cons s1 lst)) (cdr tlst)))
360                                  (('-> _)
361                                   (nemo:error 'nemo:nmodl-state-eqs ": invalid transition equation " 
362                                                  (car tlst) " in state complex " n))
363                                  (else (loop lst (cdr tlst)))))))
364         (node-ids      (list-tabulate (length node-list) identity))
365         (name->id-map  (zip node-list node-ids)))
366    ;; insert state nodes in the dependency graph
367    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
368    (let* ((nodes  ((g 'nodes)))
369           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
370           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes)))))
371      ;; create rate edges in the graph
372      (for-each (lambda (e) 
373                  (match e (('-> s0 s1 rate-expr)
374                            (let ((i  (car (alist-ref s0 name->id-map)))
375                                  (j  (car (alist-ref s1 name->id-map)))
376                                  (x  (if (eq? s0 (second snode)) snex s0)))
377                            (add-edge! (list i j `(* ,x ,rate-expr)))))
378                         (else (void))))
379                transitions)
380      ;; generate differential equations for each state in the transitions system
381      (let ((eqs    (fold (lambda (s ax) 
382                            (if (= (first snode) (first s) ) ax
383                                (let* ((out   (out-edges (first s)))
384                                       (in    (in-edges (first s)))
385                                       (open? (eq? (second s) open))
386                                       (name  (second s)))
387                                  (let* ((rhs1  (cond ((and (not (null? out)) (not (null? in)))
388                                                       `(+ (neg ,(sum (map third out)))
389                                                           ,(sum (map third in))))
390                                                      ((and (not (null? out)) (null? in))
391                                                       `(neg ,(sum (map third out))))
392                                                      ((and (null? out) (not (null? in)))
393                                                       (sum (map third in)))))
394                                         (fbody  (rhsexpr rhs1))
395                                         (fbody1 (canonicalize-expr/NMODL fbody)))
396                                    (cons (list (s+ name "'") fbody1) ax)))))
397                          (list) nodes)))
398        eqs))))
399           
400       
401
402
403(define (state-init n init)
404  (let* ((init  (rhsexpr init))
405         (init1 (canonicalize-expr/NMODL init)))
406    (list  n init1)))
407
408(define (asgn-eq n rhs)
409  (let* ((fbody   (rhsexpr rhs))
410         (fbody1  (canonicalize-expr/NMODL fbody)))
411    (list n fbody1)))
412
413
414(define (stcomp-eq n open transitions)
415  (list n open))
416
417
418(define (poset->asgn-eq-defs poset sys)
419  (fold-right
420   (lambda (lst ax)
421     (fold  (lambda (x ax) 
422              (match-let (((i . n)  x))
423                         (let ((en (environment-ref sys n)))
424                           (if (nemo:quantity? en)
425                               (cases nemo:quantity en
426                                      (ASGN  (name value rhs) (cons (asgn-eq name rhs) ax))
427                                      (else  ax))
428                               ax))))
429            ax lst))
430   (list) poset))
431
432
433(define (poset->state-eq-defs poset sys)
434  (fold-right
435   (lambda (lst ax)
436     (fold  (lambda (x ax) 
437              (match-let (((i . n)  x))
438                         (let ((en (environment-ref sys n)))
439                           (if (nemo:quantity? en)
440                               (cases nemo:quantity en
441                                      (TSCOMP  (name initial open transitions power) 
442                                               (append (state-eqs name initial open transitions power) ax))
443                                      (else  ax))
444                               ax))))
445            ax lst))
446   (list) poset))
447
448
449(define (poset->stcomp-eq-defs poset sys)
450  (fold-right
451   (lambda (lst ax)
452     (fold  (lambda (x ax) 
453              (match-let (((i . n)  x))
454                         (let ((en (environment-ref sys n)))
455                           (if (nemo:quantity? en)
456                               (cases nemo:quantity en
457                                      (TSCOMP  (name initial open transitions power) 
458                                               (cons (stcomp-eq name open transitions) ax))
459                                      (else  ax))
460                               ax))))
461            ax lst))
462   (list) poset))
463
464(define (poset->state-init-defs poset sys)
465  (fold-right
466   (lambda (lst ax)
467     (fold  (lambda (x ax) 
468              (match-let (((i . n)  x))
469                         (let ((en (environment-ref sys n)))
470                           (if (nemo:quantity? en)
471                               (cases nemo:quantity en
472                                      (TSCOMP  (name initial open transitions power) 
473                                               (cons* (state-init name initial) (state-init open name) ax))
474                                      (else  ax))
475                               ax))))
476            ax lst))
477   (list) poset))
478
479(define (find-locals defs)
480  (concatenate 
481   (map (lambda (def) (match (second def) (('let bnds _) (map first bnds)) (else (list))))
482        defs)))
483
484
485(define (state-power sys n)
486  (let ((en (environment-ref sys n)))
487    (if (nemo:quantity? en)
488        (cases nemo:quantity en
489               (TSCOMP  (name initial open transitions power)  power)
490               (else  #f))  #f)))
491
492(define (bucket-partition p lst)
493  (let loop ((lst lst) (ax (list)))
494    (if (null? lst) ax
495        (let ((x (car lst)))
496          (let bkt-loop ((old-bkts ax) (new-bkts (list)))
497            (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts))
498                (if (p x (caar old-bkts ))
499                    (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts)))
500                    (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts)))))))))
501
502
503(define (nemo:nmodl-translator sys . rest)
504  (define (cid x) (second x))
505  (define (cn x) (first x))
506  (let-optionals rest ((method 'cnexp) (table? #f) (min-v -100) (max-v 100) (step 0.5) (depend #f) )
507  (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref sys (nemo-intern 'dispatch))))
508    (let ((imports  ((dis 'imports)  sys))
509          (exports  ((dis 'exports)  sys)))
510      (let* ((indent  0)
511             (indent+ (+ 2 indent ))
512             (sysname (nmodl-name ((dis 'sysname) sys)))
513             (deps*   ((dis 'depgraph*) sys))
514             (consts  ((dis 'consts) sys))
515             (asgns   ((dis 'asgns) sys))
516             (states  ((dis 'states) sys))
517             (stcomps ((dis 'stcomps) sys))
518             (defuns  ((dis 'defuns) sys))
519             (components ((dis 'components) sys))
520             (ionchs  (filter-map (match-lambda ((name 'ion-channel id) (list name id)) (else #f)) components))) 
521        (match-let (((state-list asgn-list g) deps*))
522         (let* ((poset          (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
523                (asgn-eq-defs   (poset->asgn-eq-defs poset sys))
524                (perm-ions (delete-duplicates
525                            (fold (lambda (ionch ax) 
526                                    (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
527                                           (perm      (lookup-def 'permeating-substance subcomps)))
528                                      (if perm 
529                                          (case (cn perm)
530                                            ((non-specific)   
531                                             (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
532                                                    (i    (nmodl-name 'i))
533                                                    (e    (nmodl-name 'e)))
534                                               (cons `(,(cn perm) ,i ,e ,erev) ax)))
535                                            (else (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
536                                                         (i    (nmodl-name (s+ 'i (cn perm))))
537                                                         (e    (nmodl-name (s+ 'e (cn perm)))))
538                                                    (cons `(,(cn perm) ,i ,e ,erev) ax))))
539                                          ax)))
540                                  (list) ionchs)
541                            (lambda (x y) (eq? (car x) (car y)))))
542               (acc-ions (delete-duplicates
543                           (fold (lambda (ionch ax) 
544                                  (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
545                                         (acc   (lookup-def 'accumulating-substance subcomps))
546                                         (i     (and acc (nmodl-name (s+ 'i (cn acc)))))
547                                         (in    (and acc (nmodl-name (s+ (cn acc) 'i))))
548                                         (out   (and acc (nmodl-name (s+ (cn acc) 'o)))))
549                                    (if acc  (cons `(,(cn acc) ,i ,in ,out) ax) ax)))
550                                (list) ionchs)
551                           (lambda (x y) (eq? (car x) (car y)))))
552               )
553
554           (pp indent ,nl (TITLE ,sysname))
555           
556           (pp indent ,nl (NEURON "{"))
557           (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
558           (for-each (lambda (x)
559                       (case (first x)
560                         ((non-specific) 
561                          (pp indent+ (RANGE ,(third x))
562                              (NONSPECIFIC_CURRENT ,(second x))))
563                         (else
564                          (pp indent+ (RANGE ,(second x))
565                              (USEION ,(first x) READ ,(third x) WRITE ,(second x))))))
566                     perm-ions)
567           (for-each (lambda (x)
568                       (pp indent+ (RANGE ,(second x))
569                           (USEION ,(first x) READ ,(third x) ", " ,(fourth x) WRITE ,(second x))))
570                     acc-ions)
571           (let* ((const-names   (map first consts))
572                  (is-const?     (lambda (x) (member x const-names)))
573                  (range-consts  (delete-duplicates 
574                                  (fold (lambda (def ax) 
575                                          (let* ((rhs   (second def))
576                                                 (vars  (rhsvars rhs)))
577                                            (append (filter is-const? vars) ax)))
578                                        (list) asgn-eq-defs ))))
579             (if (not (null? range-consts)) (pp indent+ (RANGE ,(sl\ ", " range-consts)))))
580           
581           
582           (pp indent "}")
583           
584           
585           (pp indent ,nl (PARAMETER "{"))
586           (let* ((const-defs (filter-map
587                               (lambda (nv)
588                                 (and (not (member (first nv) nmodl-builtin-consts))
589                                      (let ((v1 (canonicalize-expr/NMODL (second nv))))
590                                        (list (first nv) v1))))
591                                   consts))
592                  (locals  (find-locals const-defs)))
593             (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
594             (for-each (lambda (def)
595                         (let ((n (first def)) (b (second def)))
596                           (pp indent+ ,(expr->string/NMODL b n)))) const-defs))
597           (pp indent "}")
598           
599           (let* ((with      (inexact->exact (round (/ (abs (- max-v min-v)) step))))
600                  (define-fn (make-define-fn table? min-v max-v with depend)))
601             (for-each (lambda (fndef) 
602                         (if (not (member (car fndef) builtin-fns))
603                             (apply define-fn (cons indent fndef)))) 
604                       defuns))
605           
606           
607           (pp indent ,nl (STATE "{"))
608           (for-each (lambda (st) (apply define-state (list indent+ st)))
609                     states)
610           (for-each (lambda (st) (apply define-state (list indent+ st)))
611                     stcomps)
612           (pp indent "}")
613           
614           (pp indent ,nl (ASSIGNED "{"))
615           (let* ((asgns0 (append asgns (map first imports) 
616                                  (map second perm-ions) (map third perm-ions)
617                                  (map second acc-ions) (map fourth acc-ions)))
618                  (asgns1 (delete-duplicates asgns0)))
619             (for-each (lambda (x) (pp indent+ ,(nmodl-name x))) asgns1)
620             (pp indent "}")
621             
622             (if (not (null? asgns))
623                 (begin
624                   (pp indent ,nl (PROCEDURE rates () "{"))
625                   (let ((locals    (find-locals asgn-eq-defs))) 
626                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))))
627                   (for-each (lambda (def)
628                               (let ((n (nmodl-name (first def)) )
629                                     (b (second def)))
630                                 (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs)
631                   (pp indent "}")))
632             
633             (if (not (null? stcomps))
634                 (begin
635                   (pp indent ,nl (PROCEDURE stcomps () "{"))
636                   (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
637                          (locals    (find-locals eq-defs))) 
638                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
639                     (for-each (lambda (def)
640                                 (let ((n (first def)) (b (second def)))
641                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
642                   
643                   (pp indent "}")))
644             
645             (pp indent ,nl (BREAKPOINT "{"))
646             (let* ((i-eqs (filter-map
647                            (lambda (ionch) 
648                              (let* ((n     (second ionch))
649                                     (subcomps ((dis 'component-subcomps) sys n))
650                                     (acc   (lookup-def 'accumulating-substance subcomps))
651                                     (perm  (lookup-def 'permeating-substance subcomps))
652                                     (pore  (lookup-def 'pore subcomps))
653                                     (gate  (lookup-def 'gate subcomps))
654                                     (sts   (and gate ((dis 'component-exports) sys (cid gate)))))
655                                (cond ((and perm pore gate)
656                                       (case (cn perm)
657                                         ((non-specific)
658                                          (let* ((i     (nmodl-name 'i))
659                                                 (e     (nmodl-name 'e))
660                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
661                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
662                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
663                                            (list i e gion)))
664                                         (else
665                                          (let* ((i     (nmodl-name (s+ 'i (cn perm))))
666                                                 (e     (nmodl-name (s+ 'e (cn perm))))
667                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
668                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
669                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
670                                            (list i e gion)))))
671                                      ((and acc pore gate)
672                                       (let* ((i     (nmodl-name (s+ 'i (cn acc))))
673                                              (gmax  (car ((dis 'component-exports) sys (cid pore))))
674                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
675                                              (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
676                                         (list i #f gion)))
677                                      (else (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " n))
678                                      )))
679                            ionchs))
680                    (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
681                    (i-eqs  (fold (lambda (b ax) 
682                                    (match b 
683                                           ((and ps ((i e gion) . rst)) 
684                                            (let* ((sum   (if e `(* ,(sum (map third ps)) (- v ,e))
685                                                              (sum (map third ps))))
686                                                   (sum0  (rhsexpr sum))
687                                                   (sum1  (canonicalize-expr/NMODL sum0)))
688                                              (cons (list i sum1) ax)))
689                                           
690                                           ((i e gion)
691                                            (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
692                                                   (expr1  (canonicalize-expr/NMODL expr0)))
693                                              (cons (list i expr1) ax)))
694                                           
695                                           
696                                           (else ax)))
697                                  (list) i-bkts))
698                    (locals (find-locals i-eqs)))
699               (if (not (null? locals))   (pp indent+ (LOCAL ,(sl\ ", " locals))))
700               (if (not (null? asgns))    (pp indent+ (rates ())))
701               (if (not method) (pp indent+ (SOLVE states))
702                   (pp indent+ (SOLVE states METHOD ,method)))
703               (if (not (null? stcomps))  (pp indent+ (stcomps ())))
704               (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
705               (pp indent "}"))
706             
707             (if (not (null? states))
708                 (begin
709                   (pp indent ,nl (DERIVATIVE states "{"))
710                   (let* ((eq-defs (reverse (poset->state-eq-defs poset sys)))
711                          (locals (find-locals eq-defs))) 
712                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
713                     (for-each (lambda (def)
714                                 (let ((n (first def)) (b (second def)))
715                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
716                   (pp indent "}")))
717             
718             (pp indent ,nl (INITIAL "{"))
719             (let* ((init-defs  (poset->state-init-defs poset sys))
720                    (locals     (concatenate (find-locals init-defs)))) 
721               (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
722               (if (not (null? asgns))  (pp indent+ (rates ())))
723               (for-each (lambda (def)
724                           (let ((n (first def)) (b (second def)))
725                             (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
726               (for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))
727                         perm-ions))
728             (pp indent "}")
729             
730             )))
731        )))))
Note: See TracBrowser for help on using the repository browser.