source: project/release/3/oru/nmodl.scm @ 11603

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

Some updates to the nmodl backend and hh extension.

File size: 21.5 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 nl "\n")
47
48(define (nmodl-name s)
49  (let ((cs (string->list (->string s))))
50    (let loop ((lst (list)) (cs cs))
51      (if (null? cs) (string->symbol (list->string (reverse lst)))
52          (let* ((c (car cs))
53                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c)
54                           (else #\_))))
55            (loop (cons c1 lst) (cdr cs)))))))
56                           
57                 
58
59(define (enumprocs expr ax)
60  (match expr 
61         (('if . es)  (fold enumprocs ax es))
62         (('let bnds body)  (fold enumprocs (fold enumprocs ax (map cadr bnds)) body))
63         ((s . es)    (if (symbol? s)  (cons s (fold enumprocs ax es)) ax))
64         (else ax)))
65
66(define (enumvars expr ax)
67  (match expr 
68         (('if . es)  (fold enumvars ax es))
69         (('let bnds body)  (fold enumprocs (fold enumvars ax (map cadr bnds)) body))
70         ((s . es)    (if (symbol? s)  (fold enumvars ax es) ax))
71         (id          (if (symbol? id) (cons id ax) ax))))
72
73(define (enumbnds expr ax)
74  (match expr 
75         (('if . es)  (fold enumbnds ax es))
76         (('let bnds body)  (fold enumbnds (append (map car bnds) ax) body))
77         ((s . es)    (if (symbol? s)  (fold enumbnds ax es) ax))
78         (else ax)))
79
80(define (rhsvars rhs)
81  (enumvars rhs (list)))
82
83(define (rhsexpr expr)
84  (match expr 
85         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr x)) es)))
86         (('pow x y)  (if (and (integer? y)  (positive? y))
87                          (if (> y 1)  (let ((tmp (gensym "x")))
88                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
89                              x)
90                            expr))
91         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
92         (id          id)))
93
94
95;;; Procedures for string concatenation and pretty-printing
96
97(define (s+ . lst)    (string-concatenate (map ->string lst)))
98(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
99(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
100(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
101(define nl "\n")
102
103(define (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))
104
105(define (ppf indent . lst)
106  (let ((sp (spaces indent)))
107    (for-each (lambda (x)
108                (and x (match x 
109                              ((i . x1) (if (and (number? i) (positive? i))
110                                            (for-each (lambda (x) (ppf (+ indent i) x)) x1)
111                                            (print sp (sw+ x))))
112                              (else   (print sp (if (list? x) (sw+ x) x))))))
113              lst)))
114
115
116(define-syntax pp
117  (syntax-rules ()
118    ((pp indent val ...) (ppf indent (quasiquote val) ...))))
119
120(define ifthen/NMODL  (doc:ifthen 2 (doc:text "if") (doc:text "") (doc:text "else")))
121(define letblk/NMODL  (doc:letblk 2 (doc:empty) (doc:break) (doc:empty)))
122(define group/NMODL   (doc:block 2 (doc:text "(") (doc:text ")")))
123(define block/NMODL   (doc:block 2 (doc:text "{") (doc:text "}")))
124(define binop/NMODL   (doc:binop 2))
125
126(define (format-op/NMODL indent op args)
127  (let ((op1 (doc:text (->string op))))
128    (if (null? args) op1
129        (match args
130               ((x)           (doc:connect op1 x))
131               ((x y)         (binop/NMODL x op1 y))
132               ((x y z)       (binop/NMODL x op1 (binop/NMODL y op1 z)))
133               (lst           (let* ((n   (length lst))
134                                     (n/2 (inexact->exact (round (/ n 2)))))
135                                (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 
136                                         (format-op/NMODL indent op (drop lst n/2 )))))))))
137
138(define (format-fncall/NMODL indent op args)
139  (let ((op1 (doc:text (->string op))))
140    (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args)))))
141
142
143(define nmodl-ops
144  `(+ - * / > < <= >= = ^))
145
146(define builtin-fns
147  `(+ - * / pow neg abs atan asin acos sin cos exp ln
148      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
149      > < <= >= = and or round ceiling floor max min
150      fpvector-ref))
151
152(define (sum lst)
153  (if (null? lst) lst
154      (match lst
155             ((x)   x)
156             ((x y) `(+ ,x ,y))
157             ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
158             ((x . rest) `(+ ,x ,(sum rest))))))
159
160
161(define (subst-term t subst k)
162  (match t
163         (('if c t e)
164          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
165         (('let bs e)
166          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,e) subst))
167         ((f . es)
168          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
169         ((? atom? ) t)))
170
171(define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))
172
173(define (bind ks vs e) `(let ,(zip ks vs) ,e))
174
175
176(define (if-convert expr)
177  (match expr 
178         (('if c t e) 
179          (let ((x (gensym "if")))
180            `(let ((,x (if ,(if-convert c) ,(if-convert t) ,(if-convert e))))  ,x)))
181         (('let bs e)
182          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
183         ((f . es)
184          (cons f (map if-convert es)))
185         ((? atom? ) expr)))
186
187         
188(define (let-enum expr ax)
189  (match expr
190         (('let ((x ('if c t e))) y)
191          (let ((ax (fold let-enum ax (list c t e))))
192            (if (eq? x y)  (cons (list x `(if ,c ,t ,e)) ax) ax)))
193
194         (('let bnds body)  (let-enum body (append bnds ax)))
195
196         (('if c t e)  (fold let-enum ax (list c t e)))
197
198         ((f . es)  (fold let-enum ax es))
199
200         (else ax)))
201
202
203(define (let-elim expr)
204  (match expr
205         (('let ((x ('if c t e))) y)
206          (if (eq? x y)  y expr))
207
208         (('let bnds body) (let-elim body))
209
210         (('if c t e)  `(if . ,(map let-elim (list c t e))))
211
212         ((f . es)  `(,f . ,(map let-elim es)))
213
214         (else expr)))
215 
216
217(define (let-lift expr)
218  (let ((bnds (let-enum expr (list))))
219    (if (null? bnds) expr
220        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))
221
222(define (canonicalize-expr/NMODL expr)
223  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
224    (let* ((expr1 (if-convert expr))
225           (expr2 (subst-convert expr1 subst-empty))
226           (expr3 (let-lift expr2)))
227      expr3)))
228
229(define (format-expr/NMODL indent expr . rest) 
230  (let-optionals rest ((rv #f))
231   (let ((indent+ (+ 2 indent)))
232    (match expr
233       (('let bindings body)
234        (letblk/NMODL
235         (fold-right 
236           (lambda (x ax)
237             (letblk/NMODL
238              (match (second x)
239                     (('if c t e)
240                      (ifthen/NMODL
241                       (group/NMODL (format-expr/NMODL indent c))
242                       (block/NMODL 
243                        (binop/NMODL (doc:text (->string (first x))) (doc:text " = ")
244                                     (format-expr/NMODL indent+ t)))
245                       (block/NMODL
246                        (binop/NMODL (doc:text (->string (first x))) (doc:text " = ")
247                                     (format-expr/NMODL indent+ e) ))))
248                     
249                     (else
250                      (format-op/NMODL indent+ " = "
251                                       (list (format-expr/NMODL indent+ (first x) )
252                                             (format-expr/NMODL indent+ (second x))))))
253              ax))
254           (doc:empty) bindings)
255         (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
256           (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
257               body1))))
258       
259       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))
260
261       ((op . rest) 
262       (let ((op (case op ((pow)  '^) (else op))))
263         (let ((fe
264                (if (member op nmodl-ops)
265                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
266                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
267                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
268                      (case op
269                        ((/) 
270                         (format-op/NMODL indent op 
271                                          (map (lambda (x) 
272                                                 (let ((fx (format-expr/NMODL indent+ x)))
273                                                   (if (or (symbol? x) (number? x)) fx
274                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
275                        ((*) 
276                         (format-op/NMODL indent op 
277                                          (map (lambda (x) 
278                                                 (let ((fx (format-expr/NMODL indent+ x)))
279                                                   (if (or (symbol? x) (number? x)) fx
280                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
281                       
282                        ((^) 
283                         (format-op/NMODL indent op 
284                                          (map (lambda (x) 
285                                                 (let ((fx (format-expr/NMODL indent+ x)))
286                                                   (if (or (symbol? x)  (number? x)) fx
287                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
288                       
289                        (else
290                         (format-op/NMODL indent op 
291                                          (map (lambda (x) 
292                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
293                   
294                    (let ((op (case op ((neg) '-) (else op))))
295                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
296           (if rv 
297               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
298               fe))))
299     
300      (else  (let ((fe (doc:text (->string expr))))
301               (if rv 
302                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
303                   fe)))))))
304               
305
306         
307(define (expr->string/NMODL x . rest)
308  (let-optionals rest ((rv #f) (width 64))
309    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
310 
311
312(define (define-fn 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 body))
321             (lbs (enumbnds body1 (list))))
322        (if (not (null? lbs)) (pp indent (LOCAL ,(sl\ ", " lbs))))
323        (pp indent+ ,(expr->string/NMODL body1 n)))
324      (pp indent "}")))  )
325
326
327(define (define-state indent n)
328  (pp indent (,n)))
329
330(define (define-asgn indent n)
331  (pp indent (,n)))
332
333(define (define-import indent n)
334  (pp indent (,(car n))))
335
336
337(define (state-eqs n initial open transitions power)
338  (let* ((g (make-digraph n (string-append (->string n) " transitions graph")))
339         (add-node!  (g 'add-node!))
340         (add-edge!  (g 'add-edge!))
341         (out-edges  (g 'out-edges))
342         (in-edges   (g 'in-edges))
343         (node-info  (g 'node-info))
344         (node-list  (let loop ((lst (list)) (tlst transitions))
345                       (if (null? tlst)  (delete-duplicates lst eq?)
346                           (match (car tlst) 
347                                  (('-> s0 s1 rate-expr)
348                                   (loop (cons s0 (cons s1 lst)) (cdr tlst)))
349                                  (('-> _)
350                                   (oru:error 'oru:nmodl-state-eqs ": invalid transition equation " 
351                                                  (car tlst) " in state complex " n))
352                                  (else (loop lst (cdr tlst)))))))
353         (node-ids      (list-tabulate (length node-list) identity))
354         (name->id-map  (zip node-list node-ids)))
355    ;; insert state nodes in the dependency graph
356    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
357    (let* ((nodes  ((g 'nodes)))
358           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
359           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes)))))
360      ;; create rate edges in the graph
361      (for-each (lambda (e) 
362                  (match e (('-> s0 s1 rate-expr)
363                            (let ((i  (car (alist-ref s0 name->id-map)))
364                                  (j  (car (alist-ref s1 name->id-map)))
365                                  (x  (if (eq? s0 (second snode)) snex s0)))
366                            (add-edge! (list i j `(* ,x ,rate-expr)))))
367                         (else (void))))
368                transitions)
369      ;; generate differential equations for each state in the transitions system
370      (let ((eqs    (fold (lambda (s ax) 
371                            (if (= (first snode) (first s) ) ax
372                                (let* ((out   (out-edges (first s)))
373                                       (in    (in-edges (first s)))
374                                       (open? (eq? (second s) open))
375                                       (name  (second s)))
376                                  (let* ((rhs1  (cond ((and (not (null? out)) (not (null? in)))
377                                                       `(+ (neg ,(sum (map third out)))
378                                                           ,(sum (map third in))))
379                                                      ((and (not (null? out)) (null? in))
380                                                       `(neg ,(sum (map third out))))
381                                                      ((and (null? out) (not (null? in)))
382                                                       (sum (map third in)))))
383                                         (fbody  (rhsexpr rhs1))
384                                         (fbody1 (canonicalize-expr/NMODL fbody)))
385                                    (cons (list (s+ name "'") fbody1) ax)))))
386                          (list) nodes)))
387        eqs))))
388           
389       
390
391
392(define (state-init n init)
393  (let* ((init  (rhsexpr init))
394         (init1 (canonicalize-expr/NMODL init)))
395    (list  n init1)))
396
397(define (asgn-eq n rhs)
398  (let* ((fbody   (rhsexpr rhs))
399         (fbody1  (canonicalize-expr/NMODL fbody)))
400    (list n fbody1)))
401
402
403(define (stcomp-eq n open transitions)
404  (list n open))
405
406
407(define (poset->asgn-eq-defs poset sys)
408  (fold-right
409   (lambda (lst ax)
410     (fold  (lambda (x ax) 
411              (match-let (((i . n)  x))
412                         (let ((en (environment-ref sys n)))
413                           (if (oru:quantity? en)
414                               (cases oru:quantity en
415                                      (ASGN  (name value rhs) (cons (asgn-eq name rhs) ax))
416                                      (else  ax))
417                               ax))))
418            ax lst))
419   (list) poset))
420
421
422(define (poset->state-eq-defs poset sys)
423  (fold-right
424   (lambda (lst ax)
425     (fold  (lambda (x ax) 
426              (match-let (((i . n)  x))
427                         (let ((en (environment-ref sys n)))
428                           (if (oru:quantity? en)
429                               (cases oru:quantity en
430                                      (TSCOMP  (name initial open transitions power) 
431                                               (append (state-eqs name initial open transitions power) ax))
432                                      (else  ax))
433                               ax))))
434            ax lst))
435   (list) poset))
436
437
438(define (poset->stcomp-eq-defs poset sys)
439  (fold-right
440   (lambda (lst ax)
441     (fold  (lambda (x ax) 
442              (match-let (((i . n)  x))
443                         (let ((en (environment-ref sys n)))
444                           (if (oru:quantity? en)
445                               (cases oru:quantity en
446                                      (TSCOMP  (name initial open transitions power) 
447                                               (cons (stcomp-eq name open transitions) ax))
448                                      (else  ax))
449                               ax))))
450            ax lst))
451   (list) poset))
452
453(define (poset->state-init-defs poset sys)
454  (fold-right
455   (lambda (lst ax)
456     (fold  (lambda (x ax) 
457              (match-let (((i . n)  x))
458                         (let ((en (environment-ref sys n)))
459                           (if (oru:quantity? en)
460                               (cases oru:quantity en
461                                      (TSCOMP  (name initial open transitions power) 
462                                               (cons* (state-init name initial) (state-init open name) ax))
463                                      (else  ax))
464                               ax))))
465            ax lst))
466   (list) poset))
467
468(define (find-locals defs)
469  (concatenate 
470   (map (lambda (def) (match (second def) (('let bnds _) (map first bnds)) (else (list))))
471        defs)))
472
473
474(define (state-power sys n)
475  (let ((en (environment-ref sys n)))
476    (if (oru:quantity? en)
477        (cases oru:quantity en
478               (TSCOMP  (name initial open transitions power)  power)
479               (else  #f))  #f)))
480
481(define (bucket-partition p lst)
482  (let loop ((lst lst) (ax (list)))
483    (if (null? lst) ax
484        (let ((x (car lst)))
485          (let bkt-loop ((old-bkts ax) (new-bkts (list)))
486            (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts))
487                (if (p x (caar old-bkts ))
488                    (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts)))
489                    (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts)))))))))
490
491
492(define (oru:nmodl-translator sys)
493  (match-let ((($ oru:quantity 'DISPATCH  dis) (environment-ref sys (oru-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             (sfname  (string-append (->string sysname) ".mod"))
500             (deps*   ((dis 'depgraph*) sys))
501             (asgns   ((dis 'asgns) sys))
502             (states  ((dis 'states) sys))
503             (stcomps ((dis 'stcomps) sys))
504             (components ((dis 'components) sys))
505             (ionchs  (filter-map (match-lambda (('ion-channel name) name) (else #f)) components))) 
506
507        (match-let (((state-list asgn-list g) deps*))
508         (let ((poset     (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
509               (perm-ions (delete-duplicates
510                           (fold (lambda (n ax) 
511                                  (let* ((subcomps ((dis 'component-subcomps) sys n))
512                                         (perm (lookup-def 'permeating-substance subcomps))
513                                         (erev (and perm (car ((dis 'component-exports) sys perm))))
514                                         (i    (and perm (nmodl-name (s+ 'i perm))))
515                                         (e    (and perm (nmodl-name (s+ 'e perm)))))
516                                    (if perm  (cons `(,perm ,i ,e ,erev) ax) ax)))
517                                (list) ionchs)
518                           (lambda (x y) (eq? (car x) (car y))))
519                          ))
520               
521           (with-output-to-file sfname
522             (lambda ()
523               (pp indent ,nl (TITLE ,sysname))
524
525               (pp indent ,nl (NEURON "{"))
526               (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
527               (for-each (lambda (x)
528                           (pp indent+ (RANGE ,(second x))
529                               (USEION ,(first x) READ ,(third x) WRITE ,(second x))))
530                         perm-ions)
531               (pp indent "}")
532
533
534               (pp indent ,nl (PARAMETER "{"))
535               (let* ((const-defs (map (lambda (nv)
536                                         (let ((v1 (canonicalize-expr/NMODL (second nv))))
537                                           (list (first nv) v1)))
538                                       ((dis 'consts) sys)))
539                      (locals  (find-locals const-defs)))
540                 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
541                 (for-each (lambda (def)
542                             (let ((n (first def)) (b (second def)))
543                               (pp indent+ ,(expr->string/NMODL b n)))) const-defs))
544               (pp indent "}")
545
546               (for-each (lambda (fndef) 
547                           (if (not (member (car fndef) builtin-fns))
548                               (apply define-fn (cons indent fndef)))) 
549                         ((dis 'defuns) sys))
550
551               (pp indent ,nl (STATE "{"))
552               (for-each (lambda (st) (apply define-state (list indent+ st)))
553                         states)
554               (for-each (lambda (st) (apply define-state (list indent+ st)))
555                         stcomps)
556               (pp indent "}")
557
558               (pp indent ,nl (ASSIGNED "{"))
559               (for-each (lambda (x) (apply define-asgn (list indent+ x))) 
560                         asgns)
561               (for-each (lambda (x) (apply define-import (list indent+ x))) 
562                         imports)
563               (for-each (lambda (x) (pp indent+ ,(second x) ,(third x))) perm-ions)
564               (pp indent "}")
565
566               (if (not (null? asgns))
567                   (begin
568                     (pp indent ,nl (PROCEDURE rates () "{"))
569                     (let* ((eq-defs   (poset->asgn-eq-defs poset sys)) 
570                            (locals    (find-locals eq-defs))) 
571                       (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
572                       (for-each (lambda (def)
573                             (let ((n (first def)) (b (second def)))
574                               (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
575
576                     (pp indent "}")))
577
578               (if (not (null? stcomps))
579                   (begin
580                     (pp indent ,nl (PROCEDURE stcomps () "{"))
581                     (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
582                            (locals    (find-locals eq-defs))) 
583                       (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
584                       (for-each (lambda (def)
585                             (let ((n (first def)) (b (second def)))
586                               (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
587
588                     (pp indent "}")))
589               
590               (pp indent ,nl (BREAKPOINT "{"))
591               (let* ((i-eqs (filter-map
592                              (lambda (n) 
593                                (let* ((subcomps ((dis 'component-subcomps) sys n))
594                                       (perm  (lookup-def 'permeating-substance subcomps))
595                                       (pore  (lookup-def 'pore subcomps))
596                                       (gate  (lookup-def 'gate subcomps))
597                                       (sts   (and gate ((dis 'component-exports) sys gate))))
598                                  (and perm pore gate
599                                       (let* ((i     (nmodl-name (s+ 'i perm)))
600                                              (e     (nmodl-name (s+ 'e perm)))
601                                              (gmax  (car ((dis 'component-exports) sys pore)))
602                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
603                                              (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
604                                         (list i e gion)))))
605                                 ionchs))
606                      (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
607                      (i-eqs  (fold (lambda (b ax) 
608                                      (match b 
609                                             ((and ps ((i e gion) . rst)) 
610                                              (let* ((sum   `(* ,(sum (map third ps)) (- v ,e)))
611                                                     (sum0  (rhsexpr sum))
612                                                     (sum1  (canonicalize-expr/NMODL sum0)))
613                                                (cons (list i sum1) ax)))
614
615                                             ((i e gion)
616                                              (let* ((expr0  (rhsexpr `(* ,gion (- v ,e))))
617                                                     (expr1  (canonicalize-expr/NMODL expr0)))
618                                                (cons (list i expr1) ax)))
619                                                     
620
621                                             (else ax)))
622                                    (list) i-bkts))
623                      (locals (find-locals i-eqs)))
624                 (if (not (null? locals))   (pp indent+ (LOCAL ,(sl\ ", " locals))))
625                 (if (not (null? asgns))    (pp indent+ (rates ())))
626                 (pp indent+ (SOLVE states))
627                 (if (not (null? stcomps))  (pp indent+ (stcomps ())))
628                 (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
629                 (pp indent "}"))
630
631               (if (not (null? states))
632                   (begin
633                     (pp indent ,nl (DERIVATIVE states "{"))
634                     (let* ((eq-defs (reverse (poset->state-eq-defs poset sys)))
635                            (locals (find-locals eq-defs))) 
636                       (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
637                       (for-each (lambda (def)
638                             (let ((n (first def)) (b (second def)))
639                               (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
640                     (pp indent "}")))
641
642               (pp indent ,nl (INITIAL "{"))
643               (let* ((init-defs  (poset->state-init-defs poset sys))
644                      (locals     (concatenate (find-locals init-defs)))) 
645                 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
646                 (for-each (lambda (def)
647                             (let ((n (first def)) (b (second def)))
648                               (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
649                 (for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))
650                           perm-ions))
651               (pp indent "}")
652
653               )))
654         )))))
Note: See TracBrowser for help on using the repository browser.