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

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

Added nemo- prefixes to all source files.

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 utils)
34(require-extension lolevel)
35(require-extension varsubst)
36(require-extension digraph)
37(require-extension datatype)
38
39(define (lookup-def k lst . rest)
40  (let-optionals rest ((default #f))
41      (let ((kv (assoc k lst)))
42        (if (not kv) default
43            (match kv ((k v) v) (else (cdr kv)))))))
44
45(define (nmodl-name s)
46  (let ((cs (string->list (->string s))))
47    (let loop ((lst (list)) (cs cs))
48      (if (null? cs) (string->symbol (list->string (reverse lst)))
49          (let* ((c (car cs))
50                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c)
51                           (else #\_))))
52            (loop (cons c1 lst) (cdr cs)))))))
53                           
54                 
55
56(define (enumprocs expr ax)
57  (match expr 
58         (('if . es)  (fold enumprocs ax es))
59         (('let bnds body)  (fold enumprocs (fold enumprocs ax (map cadr bnds)) body))
60         ((s . es)    (if (symbol? s)  (cons s (fold enumprocs ax es)) ax))
61         (else ax)))
62
63(define (enumbnds expr ax)
64  (match expr 
65         (('if . es)        (fold enumbnds ax es))
66         (('let bnds body)  (enumbnds body (append (map car bnds) (fold enumbnds ax (map cadr bnds)))))
67         ((s . es)          (if (symbol? s)  (fold enumbnds ax es) ax))
68         (else ax)))
69
70
71(define (enum-freevars expr bnds ax)
72  (match expr 
73         (('if . es) 
74          (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
75         (('let bnds body) 
76          (let ((bnds1 (append (map first bnds) bnds)))
77            (enum-freevars body bnds1 (fold (lambda (x ax) (enum-freevars x bnds ax)) ax (map second bnds)))))
78         ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
79         (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
80
81(define (rhsvars rhs)
82  (enum-freevars rhs (list) (list)))
83
84(define (rhsexpr expr)
85  (match expr 
86         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr x)) es)))
87         (('pow x y)  (if (and (integer? y)  (positive? y))
88                          (if (> y 1)  (let ((tmp (gensym "x")))
89                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
90                              x)
91                            expr))
92         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
93         (id          id)))
94
95
96;;; Procedures for string concatenation and pretty-printing
97
98(define (s+ . lst)    (string-concatenate (map ->string lst)))
99(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
100(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
101(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
102(define nl "\n")
103
104(define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
105
106(define (ppf indent . lst)
107  (let ((sp (spaces indent)))
108    (for-each (lambda (x)
109                (and x (match x 
110                              ((i . x1) (if (and (number? i) (positive? i))
111                                            (for-each (lambda (x) (ppf (+ indent i) x)) x1)
112                                            (print sp (sw+ x))))
113                              (else   (print sp (if (list? x) (sw+ x) x))))))
114              lst)))
115
116
117(define-syntax pp
118  (syntax-rules ()
119    ((pp indent val ...) (ppf indent (quasiquote val) ...))))
120
121(define ifthen/NMODL  (doc:ifthen 0 (doc:text "if") (doc:text "") (doc:text "else")))
122(define letblk/NMODL  (doc:letblk 2 (doc:empty) (doc:break) (doc:empty)))
123(define group/NMODL   (doc:block 2 (doc:text "(") (doc:text ")")))
124(define block/NMODL   (doc:block 2 (doc:text "{") (doc:text "}")))
125(define binop/NMODL   (doc:binop 2))
126
127(define (format-op/NMODL indent op args)
128  (let ((op1 (doc:text (->string op))))
129    (if (null? args) op1
130        (match args
131               ((x)           (doc:connect op1 x))
132               ((x y)         (binop/NMODL x op1 y))
133               ((x y z)       (binop/NMODL x op1 (binop/NMODL y op1 z)))
134               (lst           (let* ((n   (length lst))
135                                     (n/2 (inexact->exact (round (/ n 2)))))
136                                (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 
137                                         (format-op/NMODL indent op (drop lst n/2 )))))))))
138
139(define (format-fncall/NMODL indent op args)
140  (let ((op1 (doc:text (->string op))))
141    (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args)))))
142
143(define nmodl-builtin-consts
144  `(celsius diam))
145
146(define nmodl-ops
147  `(+ - * / > < <= >= = ^))
148
149(define builtin-fns
150  `(+ - * / pow neg abs atan asin acos sin cos exp ln
151      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
152      > < <= >= = and or round ceiling floor max min
153      fpvector-ref))
154
155(define (sum lst)
156  (if (null? lst) lst
157      (match lst
158             ((x)   x)
159             ((x y) `(+ ,x ,y))
160             ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
161             ((x . rest) `(+ ,x ,(sum rest))))))
162
163
164(define (subst-term t subst k)
165  (match t
166         (('if c t e)
167          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
168         (('let bs e)
169          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
170         ((f . es)
171          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
172         ((? symbol? )  (lookup-def t subst t))
173         ((? atom? ) t)))
174
175(define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
176
177(define (bind ks vs e) `(let ,(zip ks vs) ,e))
178
179(define (name-normalize expr)
180  (match expr 
181         (('if c t e)  `(if ,(name-normalize c) ,(name-normalize t) ,(name-normalize e)))
182         (('let bs e)
183          `(let ,(map (lambda (b) `(,(car b) ,(name-normalize (cadr b)))) bs) ,(name-normalize e)))
184         ((f . es) 
185          (cons f (map name-normalize es)))
186         ((? symbol? ) (nmodl-name expr))
187         ((? atom? ) expr)))
188
189(define (if-convert expr)
190  (match expr 
191         (('if c t e) 
192          (let ((r (gensym "if")))
193            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
194               ,r)))
195         (('let bs e)
196          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
197         ((f . es)
198          (cons f (map if-convert es)))
199         ((? atom? ) expr)))
200
201         
202(define (let-enum expr ax)
203  (match expr
204         (('let ((x ('if c t e))) y)
205          (let ((ax (fold let-enum ax (list c ))))
206            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
207
208         (('let bnds body)  (let-enum body (append ax bnds)))
209
210         (('if c t e)  (let-enum ax c))
211
212         ((f . es)  (fold let-enum ax es))
213
214         (else ax)))
215
216
217(define (let-elim expr)
218  (match expr
219         (('let ((x ('if c t e))) y)
220          (if (eq? x y)  y expr))
221
222         (('let bnds body) (let-elim body))
223
224         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
225
226         ((f . es)  `(,f . ,(map let-elim es)))
227
228         (else expr)))
229 
230
231(define (let-lift expr)
232  (let ((bnds (let-enum expr (list))))
233    (if (null? bnds) expr
234        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
235
236(define (canonicalize-expr/NMODL expr)
237  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
238    (let* ((expr1 (if-convert expr))
239           (expr2 (subst-convert expr1 subst-empty))
240           (expr3 (let-lift expr2))
241           (expr4 (name-normalize expr3)))
242      expr4)))
243
244(define (format-expr/NMODL indent expr . rest) 
245  (let-optionals rest ((rv #f))
246   (let ((indent+ (+ 2 indent)))
247    (match expr
248       (('let bindings body)
249        (letblk/NMODL
250         (fold-right 
251           (lambda (x ax)
252             (letblk/NMODL
253              (match (second x)
254                     (('if c t e)
255                      (ifthen/NMODL
256                       (group/NMODL (format-expr/NMODL indent c))
257                       (block/NMODL (format-expr/NMODL indent t (first x)))
258                       (block/NMODL (format-expr/NMODL indent e (first x)))))
259                     (else
260                      (format-op/NMODL indent+ " = "
261                                       (list (format-expr/NMODL indent (first x) )
262                                             (format-expr/NMODL indent (second x))))))
263              ax))
264           (doc:empty) bindings)
265         (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
266           (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
267               body1))))
268       
269       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))
270
271       ((op . rest) 
272       (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
273         (let ((fe
274                (if (member op nmodl-ops)
275                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
276                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
277                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
278                      (case op
279                        ((/) 
280                         (format-op/NMODL indent op 
281                                          (map (lambda (x) 
282                                                 (let ((fx (format-expr/NMODL indent+ x)))
283                                                   (if (or (symbol? x) (number? x)) fx
284                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
285                        ((*) 
286                         (format-op/NMODL indent op 
287                                          (map (lambda (x) 
288                                                 (let ((fx (format-expr/NMODL indent+ x)))
289                                                   (if (or (symbol? x) (number? x)) fx
290                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
291                       
292                        ((^) 
293                         (format-op/NMODL indent op 
294                                          (map (lambda (x) 
295                                                 (let ((fx (format-expr/NMODL indent+ x)))
296                                                   (if (or (symbol? x)  (number? x)) fx
297                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
298                       
299                        (else
300                         (format-op/NMODL indent op 
301                                          (map (lambda (x) 
302                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
303                   
304                    (let ((op (case op ((neg) '-) (else op))))
305                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
306           (if rv 
307               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
308               fe))))
309     
310      (else  (let ((fe (doc:text (->string expr))))
311               (if rv 
312                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
313                   fe)))))))
314               
315
316         
317(define (expr->string/NMODL x . rest)
318  (let-optionals rest ((rv #f) (width 72))
319    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
320 
321
322(define (make-define-fn table? min-v max-v with depend)
323  (lambda (indent n proc)
324    (let ((lst (procedure-data proc))
325          (indent+ (+ 2 indent)))
326      (let ((rt       (lookup-def 'rt lst))
327            (formals  (lookup-def 'formals lst))
328            (vars     (lookup-def 'vars lst))
329            (body     (lookup-def 'body lst)))
330        (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" ))
331        (let* ((body1 (canonicalize-expr/NMODL (rhsexpr body)))
332               (lbs   (enumbnds body1 (list))))
333          (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " lbs))))
334          (if (and table? min-v max-v with)
335              (match vars
336                     (('v)  (pp indent+ (TABLE ,@(if depend `(DEPEND ,depend) `(""))
337                                               FROM ,min-v TO ,max-v WITH ,with)))
338                     (else  (void))))
339          (pp indent+ ,(expr->string/NMODL body1 n)))
340        (pp indent "}"))) 
341    ))
342
343(define (define-state indent n)
344  (pp indent (,n)))
345
346
347(define (state-eqs n initial open transitions power)
348  (let* ((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 s0 (cons 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 s0 name->id-map)))
374                                  (j  (car (alist-ref 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) (apply define-state (list indent+ st)))
608                     states)
609           (for-each (lambda (st) (apply define-state (list indent+ st)))
610                     stcomps)
611           (pp indent "}")
612           
613           (pp indent ,nl (ASSIGNED "{"))
614           (let* ((asgns0 (append asgns (map first imports) 
615                                  (map second perm-ions) (map third perm-ions)
616                                  (map second acc-ions) (map fourth acc-ions)))
617                  (asgns1 (delete-duplicates asgns0)))
618             (for-each (lambda (x) (pp indent+ ,(nmodl-name x))) asgns1)
619             (pp indent "}")
620             
621             (if (not (null? asgns))
622                 (begin
623                   (pp indent ,nl (PROCEDURE rates () "{"))
624                   (let ((locals    (find-locals asgn-eq-defs))) 
625                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))))
626                   (for-each (lambda (def)
627                               (let ((n (nmodl-name (first def)) )
628                                     (b (second def)))
629                                 (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs)
630                   (pp indent "}")))
631             
632             (if (not (null? stcomps))
633                 (begin
634                   (pp indent ,nl (PROCEDURE stcomps () "{"))
635                   (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
636                          (locals    (find-locals eq-defs))) 
637                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
638                     (for-each (lambda (def)
639                                 (let ((n (first def)) (b (second def)))
640                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
641                   
642                   (pp indent "}")))
643             
644             (pp indent ,nl (BREAKPOINT "{"))
645             (let* ((i-eqs (filter-map
646                            (lambda (ionch) 
647                              (let* ((n     (second ionch))
648                                     (subcomps ((dis 'component-subcomps) sys n))
649                                     (acc   (lookup-def 'accumulating-substance subcomps))
650                                     (perm  (lookup-def 'permeating-substance subcomps))
651                                     (pore  (lookup-def 'pore subcomps))
652                                     (gate  (lookup-def 'gate subcomps))
653                                     (sts   (and gate ((dis 'component-exports) sys (cid gate)))))
654                                (cond ((and perm pore gate)
655                                       (case (cn perm)
656                                         ((non-specific)
657                                          (let* ((i     (nmodl-name 'i))
658                                                 (e     (nmodl-name 'e))
659                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
660                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
661                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
662                                            (list i e gion)))
663                                         (else
664                                          (let* ((i     (nmodl-name (s+ 'i (cn perm))))
665                                                 (e     (nmodl-name (s+ 'e (cn perm))))
666                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
667                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
668                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
669                                            (list i e gion)))))
670                                      ((and acc pore gate)
671                                       (let* ((i     (nmodl-name (s+ 'i (cn acc))))
672                                              (gmax  (car ((dis 'component-exports) sys (cid pore))))
673                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
674                                              (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
675                                         (list i #f gion)))
676                                      (else (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " n))
677                                      )))
678                            ionchs))
679                    (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
680                    (i-eqs  (fold (lambda (b ax) 
681                                    (match b 
682                                           ((and ps ((i e gion) . rst)) 
683                                            (let* ((sum   (if e `(* ,(sum (map third ps)) (- v ,e))
684                                                              (sum (map third ps))))
685                                                   (sum0  (rhsexpr sum))
686                                                   (sum1  (canonicalize-expr/NMODL sum0)))
687                                              (cons (list i sum1) ax)))
688                                           
689                                           ((i e gion)
690                                            (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
691                                                   (expr1  (canonicalize-expr/NMODL expr0)))
692                                              (cons (list i expr1) ax)))
693                                           
694                                           
695                                           (else ax)))
696                                  (list) i-bkts))
697                    (locals (find-locals i-eqs)))
698               (if (not (null? locals))   (pp indent+ (LOCAL ,(sl\ ", " locals))))
699               (if (not (null? asgns))    (pp indent+ (rates ())))
700               (if (not method) (pp indent+ (SOLVE states))
701                   (pp indent+ (SOLVE states METHOD ,method)))
702               (if (not (null? stcomps))  (pp indent+ (stcomps ())))
703               (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
704               (pp indent "}"))
705             
706             (if (not (null? states))
707                 (begin
708                   (pp indent ,nl (DERIVATIVE states "{"))
709                   (let* ((eq-defs (reverse (poset->state-eq-defs poset sys)))
710                          (locals (find-locals eq-defs))) 
711                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
712                     (for-each (lambda (def)
713                                 (let ((n (first def)) (b (second def)))
714                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
715                   (pp indent "}")))
716             
717             (pp indent ,nl (INITIAL "{"))
718             (let* ((init-defs  (poset->state-init-defs poset sys))
719                    (locals     (concatenate (find-locals init-defs)))) 
720               (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
721               (if (not (null? asgns))  (pp indent+ (rates ())))
722               (for-each (lambda (def)
723                           (let ((n (first def)) (b (second def)))
724                             (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
725               (for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))
726                         perm-ions))
727             (pp indent "}")
728             
729             )))
730        )))))
Note: See TracBrowser for help on using the repository browser.