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

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

Bug fixes related to SXML frontend.

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