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

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

More updated to the NMODL backend.

File size: 24.0 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 oru-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 (define-fn indent n proc)
312  (let ((lst (procedure-data proc))
313        (indent+ (+ 2 indent)))
314    (let ((rt       (lookup-def 'rt lst))
315          (formals  (lookup-def 'formals lst))
316          (vars     (lookup-def 'vars lst))
317          (body     (lookup-def 'body lst)))
318      (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" ))
319      (let* ((body1 (canonicalize-expr/NMODL (rhsexpr body)))
320             (lbs   (enumbnds body1 (list))))
321        (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " lbs))))
322        (pp indent+ ,(expr->string/NMODL body1 n)))
323      (pp indent "}")))  )
324
325
326(define (define-state indent n)
327  (pp indent (,n)))
328
329
330(define (state-eqs n initial open transitions power)
331  (let* ((g (make-digraph n (string-append (->string n) " transitions graph")))
332         (add-node!  (g 'add-node!))
333         (add-edge!  (g 'add-edge!))
334         (out-edges  (g 'out-edges))
335         (in-edges   (g 'in-edges))
336         (node-info  (g 'node-info))
337         (node-list  (let loop ((lst (list)) (tlst transitions))
338                       (if (null? tlst)  (delete-duplicates lst eq?)
339                           (match (car tlst) 
340                                  (('-> s0 s1 rate-expr)
341                                   (loop (cons s0 (cons s1 lst)) (cdr tlst)))
342                                  (('-> _)
343                                   (oru:error 'oru:nmodl-state-eqs ": invalid transition equation " 
344                                                  (car tlst) " in state complex " n))
345                                  (else (loop lst (cdr tlst)))))))
346         (node-ids      (list-tabulate (length node-list) identity))
347         (name->id-map  (zip node-list node-ids)))
348    ;; insert state nodes in the dependency graph
349    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
350    (let* ((nodes  ((g 'nodes)))
351           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
352           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes)))))
353      ;; create rate edges in the graph
354      (for-each (lambda (e) 
355                  (match e (('-> s0 s1 rate-expr)
356                            (let ((i  (car (alist-ref s0 name->id-map)))
357                                  (j  (car (alist-ref s1 name->id-map)))
358                                  (x  (if (eq? s0 (second snode)) snex s0)))
359                            (add-edge! (list i j `(* ,x ,rate-expr)))))
360                         (else (void))))
361                transitions)
362      ;; generate differential equations for each state in the transitions system
363      (let ((eqs    (fold (lambda (s ax) 
364                            (if (= (first snode) (first s) ) ax
365                                (let* ((out   (out-edges (first s)))
366                                       (in    (in-edges (first s)))
367                                       (open? (eq? (second s) open))
368                                       (name  (second s)))
369                                  (let* ((rhs1  (cond ((and (not (null? out)) (not (null? in)))
370                                                       `(+ (neg ,(sum (map third out)))
371                                                           ,(sum (map third in))))
372                                                      ((and (not (null? out)) (null? in))
373                                                       `(neg ,(sum (map third out))))
374                                                      ((and (null? out) (not (null? in)))
375                                                       (sum (map third in)))))
376                                         (fbody  (rhsexpr rhs1))
377                                         (fbody1 (canonicalize-expr/NMODL fbody)))
378                                    (cons (list (s+ name "'") fbody1) ax)))))
379                          (list) nodes)))
380        eqs))))
381           
382       
383
384
385(define (state-init n init)
386  (let* ((init  (rhsexpr init))
387         (init1 (canonicalize-expr/NMODL init)))
388    (list  n init1)))
389
390(define (asgn-eq n rhs)
391  (let* ((fbody   (rhsexpr rhs))
392         (fbody1  (canonicalize-expr/NMODL fbody)))
393    (list n fbody1)))
394
395
396(define (stcomp-eq n open transitions)
397  (list n open))
398
399
400(define (poset->asgn-eq-defs poset sys)
401  (fold-right
402   (lambda (lst ax)
403     (fold  (lambda (x ax) 
404              (match-let (((i . n)  x))
405                         (let ((en (environment-ref sys n)))
406                           (if (oru:quantity? en)
407                               (cases oru:quantity en
408                                      (ASGN  (name value rhs) (cons (asgn-eq name rhs) ax))
409                                      (else  ax))
410                               ax))))
411            ax lst))
412   (list) poset))
413
414
415(define (poset->state-eq-defs poset sys)
416  (fold-right
417   (lambda (lst ax)
418     (fold  (lambda (x ax) 
419              (match-let (((i . n)  x))
420                         (let ((en (environment-ref sys n)))
421                           (if (oru:quantity? en)
422                               (cases oru:quantity en
423                                      (TSCOMP  (name initial open transitions power) 
424                                               (append (state-eqs name initial open transitions power) ax))
425                                      (else  ax))
426                               ax))))
427            ax lst))
428   (list) poset))
429
430
431(define (poset->stcomp-eq-defs poset sys)
432  (fold-right
433   (lambda (lst ax)
434     (fold  (lambda (x ax) 
435              (match-let (((i . n)  x))
436                         (let ((en (environment-ref sys n)))
437                           (if (oru:quantity? en)
438                               (cases oru:quantity en
439                                      (TSCOMP  (name initial open transitions power) 
440                                               (cons (stcomp-eq name open transitions) ax))
441                                      (else  ax))
442                               ax))))
443            ax lst))
444   (list) poset))
445
446(define (poset->state-init-defs poset sys)
447  (fold-right
448   (lambda (lst ax)
449     (fold  (lambda (x ax) 
450              (match-let (((i . n)  x))
451                         (let ((en (environment-ref sys n)))
452                           (if (oru:quantity? en)
453                               (cases oru:quantity en
454                                      (TSCOMP  (name initial open transitions power) 
455                                               (cons* (state-init name initial) (state-init open name) ax))
456                                      (else  ax))
457                               ax))))
458            ax lst))
459   (list) poset))
460
461(define (find-locals defs)
462  (concatenate 
463   (map (lambda (def) (match (second def) (('let bnds _) (map first bnds)) (else (list))))
464        defs)))
465
466
467(define (state-power sys n)
468  (let ((en (environment-ref sys n)))
469    (if (oru:quantity? en)
470        (cases oru:quantity en
471               (TSCOMP  (name initial open transitions power)  power)
472               (else  #f))  #f)))
473
474(define (bucket-partition p lst)
475  (let loop ((lst lst) (ax (list)))
476    (if (null? lst) ax
477        (let ((x (car lst)))
478          (let bkt-loop ((old-bkts ax) (new-bkts (list)))
479            (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts))
480                (if (p x (caar old-bkts ))
481                    (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts)))
482                    (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts)))))))))
483
484
485(define (oru:nmodl-translator sys)
486  (match-let ((($ oru:quantity 'DISPATCH  dis) (environment-ref sys (oru-intern 'dispatch))))
487    (let ((imports  ((dis 'imports)  sys))
488          (exports  ((dis 'exports)  sys)))
489      (let* ((indent  0)
490             (indent+ (+ 2 indent ))
491             (sysname (nmodl-name ((dis 'sysname) sys)))
492             (sfname  (string-append (->string sysname) ".mod"))
493             (deps*   ((dis 'depgraph*) sys))
494             (consts  ((dis 'consts) sys))
495             (asgns   ((dis 'asgns) sys))
496             (states  ((dis 'states) sys))
497             (stcomps ((dis 'stcomps) sys))
498             (components ((dis 'components) sys))
499             (ionchs  (filter-map (match-lambda (('ion-channel name) name) (else #f)) components))) 
500
501        (match-let (((state-list asgn-list g) deps*))
502         (let* ((poset          (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
503                (asgn-eq-defs   (poset->asgn-eq-defs poset sys)) 
504                (perm-ions (delete-duplicates
505                            (fold (lambda (n ax) 
506                                    (let* ((subcomps ((dis 'component-subcomps) sys n))
507                                           (perm (lookup-def 'permeating-substance subcomps)))
508                                      (if perm 
509                                          (case perm
510                                            ((non-specific)   
511                                             (let* ((erev (car ((dis 'component-exports) sys perm)))
512                                                    (i    (nmodl-name 'i))
513                                                    (e    (nmodl-name 'e)))
514                                               (cons `(,perm ,i ,e ,erev) ax)))
515                                            (else (let* ((erev (car ((dis 'component-exports) sys perm)))
516                                                         (i    (nmodl-name (s+ 'i perm)))
517                                                         (e    (nmodl-name (s+ 'e perm))))
518                                                    (cons `(,perm ,i ,e ,erev) ax))))
519                                          ax)))
520                                  (list) ionchs)
521                            (lambda (x y) (eq? (car x) (car y)))))
522               (acc-ions (delete-duplicates
523                           (fold (lambda (n ax) 
524                                  (let* ((subcomps ((dis 'component-subcomps) sys n))
525                                         (acc   (lookup-def 'accumulating-substance subcomps))
526                                         (i     (and acc (nmodl-name (s+ 'i acc))))
527                                         (in    (and acc (nmodl-name (s+ acc 'i))))
528                                         (out   (and acc (nmodl-name (s+ acc 'o)))))
529                                    (if acc  (cons `(,acc ,i ,in ,out) ax) ax)))
530                                (list) ionchs)
531                           (lambda (x y) (eq? (car x) (car y)))))
532               )
533               
534           (with-output-to-file sfname
535             (lambda ()
536               (pp indent ,nl (TITLE ,sysname))
537
538               (pp indent ,nl (NEURON "{"))
539               (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
540               (for-each (lambda (x)
541                           (case (first x)
542                             ((non-specific) 
543                              (pp indent+ (RANGE ,(third x))
544                                  (NONSPECIFIC_CURRENT ,(second x))))
545                             (else
546                              (pp indent+ (RANGE ,(second x))
547                                  (USEION ,(first x) READ ,(third x) WRITE ,(second x))))))
548                         perm-ions)
549               (for-each (lambda (x)
550                           (pp indent+ (RANGE ,(second x))
551                               (USEION ,(first x) READ ,(third x) ", " ,(fourth x) WRITE ,(second x))))
552                         acc-ions)
553               (let* ((const-names   (map first consts))
554                      (is-const?     (lambda (x) (member x const-names)))
555                      (range-consts  (delete-duplicates 
556                                      (fold (lambda (def ax) 
557                                              (let* ((rhs   (second def))
558                                                     (vars  (rhsvars rhs)))
559                                                (append (filter is-const? vars) ax)))
560                                            (list) asgn-eq-defs ))))
561                 (if (not (null? range-consts)) (pp indent+ (RANGE ,(sl\ ", " range-consts)))))
562
563               
564               (pp indent "}")
565
566
567               (pp indent ,nl (PARAMETER "{"))
568               (let* ((const-defs (map (lambda (nv)
569                                         (let ((v1 (canonicalize-expr/NMODL (second nv))))
570                                           (list (first nv) v1)))
571                                       consts))
572                      (locals  (find-locals const-defs)))
573                 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
574                 (for-each (lambda (def)
575                             (let ((n (first def)) (b (second def)))
576                               (pp indent+ ,(expr->string/NMODL b n)))) const-defs))
577               (pp indent "}")
578
579               (for-each (lambda (fndef) 
580                           (if (not (member (car fndef) builtin-fns))
581                               (apply define-fn (cons indent fndef)))) 
582                         ((dis 'defuns) sys))
583
584               (pp indent ,nl (STATE "{"))
585               (for-each (lambda (st) (apply define-state (list indent+ st)))
586                         states)
587               (for-each (lambda (st) (apply define-state (list indent+ st)))
588                         stcomps)
589               (pp indent "}")
590
591               (pp indent ,nl (ASSIGNED "{"))
592               (let* ((asgns0 (append asgns (map first imports) 
593                                      (map second perm-ions) (map third perm-ions)
594                                      (map second acc-ions) (map fourth acc-ions)))
595                      (asgns1 (delete-duplicates asgns0)))
596                 (for-each (lambda (x) (pp indent+ ,x)) asgns1))
597               (pp indent "}")
598
599               (if (not (null? asgns))
600                   (begin
601                     (pp indent ,nl (PROCEDURE rates () "{"))
602                     (let ((locals    (find-locals asgn-eq-defs))) 
603                       (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
604                       (for-each (lambda (def)
605                             (let ((n (first def)) (b (second def)))
606                               (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs))
607
608                     (pp indent "}")))
609
610               (if (not (null? stcomps))
611                   (begin
612                     (pp indent ,nl (PROCEDURE stcomps () "{"))
613                     (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
614                            (locals    (find-locals eq-defs))) 
615                       (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
616                       (for-each (lambda (def)
617                             (let ((n (first def)) (b (second def)))
618                               (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
619
620                     (pp indent "}")))
621               
622               (pp indent ,nl (BREAKPOINT "{"))
623               (let* ((i-eqs (filter-map
624                              (lambda (n) 
625                                (let* ((subcomps ((dis 'component-subcomps) sys n))
626                                       (acc   (lookup-def 'accumulating-substance subcomps))
627                                       (perm  (lookup-def 'permeating-substance subcomps))
628                                       (pore  (lookup-def 'pore subcomps))
629                                       (gate  (lookup-def 'gate subcomps))
630                                       (sts   (and gate ((dis 'component-exports) sys gate))))
631                                  (cond ((and perm pore gate)
632                                         (case perm
633                                           ((non-specific)
634                                            (let* ((i     (nmodl-name 'i))
635                                                   (e     (nmodl-name 'e))
636                                                   (gmax  (car ((dis 'component-exports) sys pore)))
637                                                   (pwrs  (map (lambda (n) (state-power sys n)) sts))
638                                                   (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
639                                              (list i e gion)))
640                                           (else
641                                            (let* ((i     (nmodl-name (s+ 'i perm)))
642                                                   (e     (nmodl-name (s+ 'e perm)))
643                                                   (gmax  (car ((dis 'component-exports) sys pore)))
644                                                   (pwrs  (map (lambda (n) (state-power sys n)) sts))
645                                                   (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
646                                              (list i e gion)))))
647                                         ((and acc pore gate)
648                                          (let* ((i     (nmodl-name (s+ 'i acc)))
649                                                 (gmax  (car ((dis 'component-exports) sys pore)))
650                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
651                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
652                                           (list i #f gion)))
653                                         (else (oru:error 'oru:nmodl-translator ": invalid ion channel definition " n))
654                                        )))
655                                 ionchs))
656                      (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
657                      (i-eqs  (fold (lambda (b ax) 
658                                      (match b 
659                                             ((and ps ((i e gion) . rst)) 
660                                              (let* ((sum   (if e `(* ,(sum (map third ps)) (- v ,e))
661                                                                (sum (map third ps))))
662                                                     (sum0  (rhsexpr sum))
663                                                     (sum1  (canonicalize-expr/NMODL sum0)))
664                                                (cons (list i sum1) ax)))
665
666                                             ((i e gion)
667                                              (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
668                                                     (expr1  (canonicalize-expr/NMODL expr0)))
669                                                (cons (list i expr1) ax)))
670                                                     
671
672                                             (else ax)))
673                                    (list) i-bkts))
674                      (locals (find-locals i-eqs)))
675                 (if (not (null? locals))   (pp indent+ (LOCAL ,(sl\ ", " locals))))
676                 (if (not (null? asgns))    (pp indent+ (rates ())))
677                 (pp indent+ (SOLVE states))
678                 (if (not (null? stcomps))  (pp indent+ (stcomps ())))
679                 (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
680                 (pp indent "}"))
681
682               (if (not (null? states))
683                   (begin
684                     (pp indent ,nl (DERIVATIVE states "{"))
685                     (let* ((eq-defs (reverse (poset->state-eq-defs poset sys)))
686                            (locals (find-locals eq-defs))) 
687                       (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
688                       (for-each (lambda (def)
689                             (let ((n (first def)) (b (second def)))
690                               (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
691                     (pp indent "}")))
692
693               (pp indent ,nl (INITIAL "{"))
694               (let* ((init-defs  (poset->state-init-defs poset sys))
695                      (locals     (concatenate (find-locals init-defs)))) 
696                 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
697                 (if (not (null? asgns))  (pp indent+ (rates ())))
698                 (for-each (lambda (def)
699                             (let ((n (first def)) (b (second def)))
700                               (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
701                 (for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))
702                           perm-ions))
703               (pp indent "}")
704
705               )))
706         )))))
Note: See TracBrowser for help on using the repository browser.