source: project/release/4/nemo/trunk/nemo-nest.scm @ 31587

Last change on this file since 31587 was 31587, checked in by Ivan Raikov, 5 years ago

nemo: bug fixes in NEST templates

File size: 44.6 KB
Line 
1;;       
2;; An extension for translating NEMO models to NEST code.
3;;
4;; Copyright 2011-2014 Ivan Raikov and the Okinawa Institute of Science and Technology
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU General Public License as
8;; published by the Free Software Foundation, either version 3 of the
9;; License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15;;
16;; A full copy of the GPL license can be found at
17;; <http://www.gnu.org/licenses/>.
18;;
19
20(module nemo-nest
21
22        (nemo:nest-translator)
23
24        (import scheme chicken utils data-structures ports extras srfi-1 srfi-13 srfi-69)
25       
26        (require-extension lolevel posix matchable strictly-pretty 
27                           varsubst datatype nemo-core nemo-utils nemo-units
28                           nemo-geometry nemo-defaults nemo-constraints
29                           nemo-gate-complex nemo-synapse nemo-currents
30
31                           )
32        (require-library ersatz-lib)
33
34        (import (prefix ersatz-lib ersatz: ))
35
36
37
38
39(define C++-ops
40  `(+ - * / > < <= >= =))
41
42
43(define (nest-name s)
44  (let ((cs (string->list (->string s))))
45    (let loop ((lst (list)) (cs cs))
46      (if (null? cs) (string->symbol (list->string (reverse lst)))
47          (let* ((c (car cs))
48                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c)
49                           (else #\_))))
50            (loop (cons c1 lst) (cdr cs)))))))
51
52
53(define builtin-consts
54  (append `(params)
55          (map (lambda (x) (nest-name (s+ "M_" (first x)))) nemo:math-constants)))
56
57
58(define builtin-fns
59  `(+ - * / pow neg abs atan asin acos sin cos exp ln
60      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
61      > < <= >= = and or round ceiling floor max min
62      ))
63
64
65(define (rewrite-pow expr)
66  (match expr
67         (('pow x y)  (if (and (integer? y)  (positive? y))
68                          (if (> y 1)  (let ((tmp (gensym "x")))
69                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
70                              x)
71                          (if (and (number? y) (zero? y)) 1.0 expr)))
72         (else expr)))
73
74           
75(define (rhsexpr/C++ expr)
76  (match expr 
77         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr/C++ x)) es)))
78         (('pow x y)  (cond ((and (integer? y) (= y 1)) x)
79                            ((and (number? y) (zero? y)) 1.0)
80                            (else expr)))
81         ((s . es)    (if (symbol? s)  (cons (if (member s builtin-fns) s (nest-name s))
82                                             (map (lambda (x) (rhsexpr/C++ x)) es)) expr))
83         (id          (if (symbol? id) 
84                          (if (assoc id nemo:math-constants)
85                              (nest-name (s+ "M_" id))
86                              (nest-name id))
87                          id))
88         ))
89
90
91(define (nest-state-name n s)
92  (nest-name (s+ n s)))
93
94
95(define-syntax pp
96  (syntax-rules ()
97    ((pp indent val ...) (ppf indent (quasiquote val) ...))))
98
99
100(define group/C++   (doc:block 2 (doc:text "(") (doc:text ")")))
101(define block/C++   (doc:block 2 (doc:text "{") (doc:text "}")))
102(define (stmt/C++ x) 
103  (match x
104         (($ doc 'DocCons _ ($ doc 'DocText ";")) x)
105         (else  (doc:cons x (doc:text ";")))))
106
107
108(define (ifthen/C++ c e1 e2)
109  (doc:nest 2
110    (doc:connect (doc:group (doc:connect (doc:text "if") c))
111                 (doc:connect (doc:nest 2 e1)
112                              (doc:nest 2 (doc:connect 
113                                           (doc:text "else") 
114                                           e2))))
115    ))
116
117
118(define (letblk/C++ e1 e2)
119  (cond ((equal? e1 (doc:empty)) (doc:group (doc:nest 2 e2)))
120        ((equal? e2 (doc:empty)) (doc:group (doc:nest 2 e1)))
121        (else (doc:connect (doc:group (doc:nest 2 (stmt/C++ e1)))
122                           (doc:group (doc:nest 2 e2))))))
123       
124
125(define (format-op/C++ indent op args)
126  (let ((op1 (doc:text (->string op))))
127    (if (null? args) op1
128        (match args
129               ((x)      (doc:concat (list op1 x)))
130               ((x y)    (doc:concat (intersperse (list x op1 y) (doc:space))))
131               ((x y z)  (doc:concat (intersperse (list x op1 y op1 z) (doc:space))))
132               (lst      (let* ((n   (length lst))
133                                (n/2 (inexact->exact (round (/ n 2)))))
134                           (doc:concat 
135                            (intersperse 
136                             (list (format-op/C++ indent op (take lst n/2 )) op1 
137                                   (format-op/C++ indent op (drop lst n/2 )))
138                             (doc:space)))))))))
139
140
141(define (format-fncall/C++ indent op args)
142  (let ((op1 (doc:text (->string op))))
143    (doc:cons op1 (group/C++ ((doc:list indent identity (lambda () (doc:text ", "))) args)))))
144
145
146(define (name-normalize expr)
147  (match expr 
148         (('if c t e)  `(if ,(name-normalize c) ,(name-normalize t) ,(name-normalize e)))
149         (('let bs e)
150          `(let ,(map (lambda (b) `(,(car b) ,(name-normalize (cadr b)))) bs) ,(name-normalize e)))
151         ((f . es) 
152          (cons (if (member f builtin-fns) f (nest-name f)) (map name-normalize es)))
153         ((? symbol? ) (nest-name expr))
154         ((? atom? ) expr)))
155
156
157(define (canonicalize-expr/C++ expr)
158  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) nemo:binding? identity nemo:bind nemo:subst-term)))
159    (let* ((expr1 (if-convert expr))
160           (expr2 (subst-convert expr1 subst-empty))
161           (expr3 (let-lift expr2))
162           (expr4 (name-normalize expr3)))
163      expr4)))
164
165
166(define (format-expr/C++ indent expr . rest) 
167  (let-optionals rest ((rv #f))
168   (let ((indent+ (+ 2 indent)))
169    (match expr
170       (('let bindings body)
171        (letblk/C++
172         (fold-right 
173           (lambda (x ax)
174             (letblk/C++
175              (match (second x)
176                     (('if c t e)
177                      (ifthen/C++
178                       (group/C++ (format-expr/C++ indent c))
179                       (block/C++ (format-expr/C++ indent t (first x)))
180                       (block/C++ (format-expr/C++ indent e (first x)))))
181                     (else
182                      (stmt/C++
183                       (format-op/C++ indent+ " = "
184                                         (list (format-expr/C++ indent (first x) )
185                                               (format-expr/C++ indent (second x)))))))
186              ax))
187           (doc:empty) bindings)
188         (match body
189                (('let _ _) (format-expr/C++ indent body rv))
190                (else
191                 (let ((body1 (doc:nest indent (format-expr/C++ indent body))))
192                   (if rv (stmt/C++ (format-op/C++ indent " = " (list (format-expr/C++ indent+ rv ) body1)))
193                       body1))))))
194       
195       (('if . rest) (error 'format-expr/C++ "invalid if statement " expr))
196
197       ((op . rest) 
198       (let ((op (case op ((ln) 'log) ((abs) 'fabs) (else op))))
199         (let ((fe
200                (if (member op C++-ops)
201                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
202                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
203                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
204                      (case op
205                        ((/) 
206                         (format-op/C++ indent op 
207                                          (map (lambda (x) 
208                                                 (let ((fx (format-expr/C++ indent+ x)))
209                                                   (if (or (symbol? x) (number? x)) fx
210                                                       (if (or mul? plmin?) (group/C++ fx) fx)))) rest)))
211                        ((*) 
212                         (format-op/C++ indent op 
213                                          (map (lambda (x) 
214                                                 (let ((fx (format-expr/C++ indent+ x)))
215                                                   (if (or (symbol? x) (number? x)) fx
216                                                       (if plmin? (group/C++ fx) fx)))) rest)))
217                       
218                        (else
219                         (format-op/C++ indent op 
220                                          (map (lambda (x) 
221                                                 (let ((fx (format-expr/C++ indent+ x))) fx)) rest)))))
222                   
223                    (let ((op (case op ((neg) '-) (else op))))
224                      (format-fncall/C++ indent op (map (lambda (x) (format-expr/C++ indent+ x)) rest))))))
225           (if rv 
226               (stmt/C++ (format-op/C++ indent " = " (list (format-expr/C++ indent+ rv ) fe)))
227               fe))))
228     
229      (else  (let ((fe (doc:text (->string expr))))
230               (if rv 
231                   (stmt/C++ (format-op/C++ indent " = " (list (format-expr/C++ indent+ rv ) fe)))
232                   fe)))))))
233               
234         
235(define (expr->string/C++ x . rest)
236  (let-optionals rest ((rv #f) (width 72))
237    (sdoc->string (doc:format width (format-expr/C++ 2 x rv)))))
238
239
240
241(define nest-template 
242  (ersatz:statements-from-file 
243   (ersatz:template-std-env 
244    search-path: `(,template-dir))
245   "NEST.tmpl"))
246
247(define nest-header-template 
248  (ersatz:statements-from-file 
249   (ersatz:template-std-env 
250    search-path: `(,template-dir))
251   "NEST-header.tmpl"))
252
253
254
255(define (make-define-fn sysname )
256  (lambda (indent n proc)
257
258    (let* (
259           (lst      (procedure-data proc))
260           (indent+  (+ 2 indent))
261           (rt       (or (lookup-def 'rt lst) 'double))
262           (formals  (lookup-def 'formals lst))
263           (vars     (lookup-def 'vars lst))
264           (consts   (filter (lambda (x) (not (procedure? (cdr x)))) (lookup-def 'consts lst)))
265           (body     (lookup-def 'body lst))
266           (rv       (gensym 'rv))
267           (body0    (rhsexpr/C++ body))
268           (body1    (canonicalize-expr/C++ (add-params-to-fncall body0 builtin-fns)))
269           (lbs      (enum-bnds body1 (list)))
270           (args     (append
271                      (if (null? vars) '() (map (lambda (x) (sprintf "double ~A" (nest-name x))) vars))
272                      '("const void* params")))
273           )
274
275        (let (
276              (tmpl-env
277               (fold tenv-enter '()
278                     `(
279                       (name . ,(nest-name n))
280                       (vars . ,args)
281
282                       (localVars    . ,(if (null? lbs) (ersatz:Tlist '()) (ersatz:sexpr->tvalue lbs)))
283                       (exprString   . ,(ersatz:Tstr (expr->string/C++ body1 (nest-name rv))))
284                       
285                       (returnType . ,rt)
286                       (returnVar  . ,rv)
287                       
288                       (consts . ,(map (compose nest-name car) consts))
289                       ))
290               )
291              )
292
293          tmpl-env
294
295          ))
296    ))
297
298
299(define (ith v i) (sprintf "Ith(~A,~A)" v i))
300
301
302
303(define (nemo:nest-translator sys . rest)
304
305  (define (cid x)  (second x))
306  (define (cn x)   (first x))
307
308
309  (let-optionals rest ((dirname ".") 
310                       (method #f) (ss-method #f) 
311                       (abstol #f) (reltol #f) (maxstep #f)
312                       (dump-template-env #f))
313
314    (let ((method (or method 'gsl)))
315
316      (if (not (member method '(gsl cvode ida)))
317          (nemo:error 'nemo:nest-translator ": unknown method " method))
318
319  (match-let ((($ nemo:quantity 'DISPATCH  dis) (hash-table-ref sys (nemo-intern 'dispatch))))
320    (let (
321          (getstate (case method
322                      ((cvode ida) (lambda (i) (sprintf "Ith(B_.y,~A)" i)))
323                      (else (lambda (i) (sprintf "Ith(S_.y_,~A)" i)))))
324          (imports  ((dis 'imports)  sys))
325          (exports  ((dis 'exports)  sys))
326          )
327      (let* ((indent      0)
328             (indent+     (+ 2 indent ))
329
330             (sysname     (nest-name ((dis 'sysname) sys)))
331             (prefix      (->string sysname))
332             (deps*       ((dis 'depgraph*)  sys))
333             (consts      ((dis 'consts)     sys))
334             (asgns       ((dis 'asgns)      sys))
335             (states      ((dis 'states)     sys))
336             (reactions   ((dis 'reactions)  sys))
337             (defuns      ((dis 'defuns)     sys))
338             (components  ((dis 'components) sys))
339             
340             (g             (match-let (((state-list asgn-list g) ((dis 'depgraph*) sys))) g))
341             (poset         (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
342
343             (const-defs       (filter-map
344                                (lambda (nv)
345                                  (and (not (member (first nv) builtin-consts))
346                                       (let ((v1 (canonicalize-expr/C++ (second nv))))
347                                         (list (nest-name (first nv)) v1))))
348                                consts))
349             
350             (defaults             (nemo:defaults-query sys))
351
352             (geometry             (nemo:geometry-query sys))
353
354             (gate-complex-info    (nemo:gate-complex-query sys))
355             (perm-ions       (map (match-lambda ((comp i e erev val) `(,comp ,(nest-name i) ,(nest-name e) ,erev)))
356                                   (lookup-def 'perm-ions gate-complex-info)))
357             (acc-ions        (map (match-lambda ((comp i in out) `(,comp ,@(map nest-name (list i in out)))))
358                                   (lookup-def 'acc-ions gate-complex-info)))
359             (epools          (lookup-def 'pool-ions gate-complex-info))
360             (pool-ions       (pool-ion-name-map nest-name  epools))
361
362             (comprc         (any (match-lambda ((name 'membrane-tau id) (list name id)) (else #f)) components))
363             (compcap        (any (match-lambda ((name 'membrane-capacitance id) (list name id)) (else #f)) components))
364             (mrc            (or (and comprc (car ((dis 'component-exports) sys (cid comprc))))
365                                 (lookup-def 'membrane-tau defaults)
366                                 (lookup-def 'tau_m defaults)
367                                 (and compcap (car ((dis 'component-exports) sys (cid compcap))))
368                                 (lookup-def 'membrane-capacitance defaults)
369                                 (lookup-def 'C_m defaults)
370                                 ))
371
372             (soma-geometry  (lookup-def 'soma geometry))
373             (marea          (and soma-geometry (third soma-geometry)))
374
375             (gate-complexes       (lookup-def 'gate-complexes gate-complex-info))
376             (synapse-info         (nemo:post-synaptic-conductance-query sys))
377
378             (pscs           (lookup-def 'post-synaptic-conductances synapse-info))
379             (psc-transients (map (lambda (lst) (map nest-name lst)) 
380                                  (lookup-def 'psc-transients synapse-info)))
381
382             (i-syns         (lookup-def 'i-synapses synapse-info))
383               
384             (i-gates        (lookup-def 'i-gates gate-complex-info))
385
386             (i-defs         (nemo:ionic-current-definitions
387                              gate-complexes i-gates i-syns pscs marea
388                              (lambda (x) (state-power sys x))
389                              (lambda (x) ((dis 'component-exports) sys x))
390                              (lambda (x) ((dis 'component-subcomps) sys x))
391                              nest-name rhsexpr/C++ canonicalize-expr/C++
392                              builtin-fns))
393
394             (i-eqs          (lookup-def 'i-eqs i-defs))
395             (i-names        (lookup-def 'i-names i-defs))
396
397             (constraints    (nemo:constraint-definitions 
398                              gate-complexes i-gates i-syns pscs marea imports
399                              (lambda (x) (state-power sys x))
400                              (lambda (x) (quantity-unit sys x))
401                              (lambda (x) ((dis 'component-exports) sys x))
402                              (lambda (x) ((dis 'component-subcomps) sys x))
403                              nest-name))
404
405             (v-eq    (and (not (null? i-names))
406                           (let ((istim "(node.B_.I_stim_)" )) 
407                             (cond
408
409                              ((and mrc marea)
410                               (list 'v (rhsexpr/C++ 
411                                         `(/ (+ (* ,istim (/ 100. ,marea)) 
412                                                (* -1e3 ,(sum i-names))) ,mrc))))
413                              (marea
414                               (list 'v (rhsexpr/C++ 
415                                         `(+ (* ,istim (/ 100. ,marea))
416                                             (* -1e-3 ,(sum i-names))))))
417                              (mrc
418                               (list 'v (rhsexpr/C++ `(/ (+ ,istim (* -1e-3 ,(sum i-names))) ,mrc))))
419                             
420                              (else
421                               (list 'v (rhsexpr/C++ `(+ ,istim (* -1e-3 ,(sum i-names))))))
422                              ))
423                           ))
424
425             (v-eq
426              (and v-eq
427                   (list (first v-eq) 
428                         (add-params-to-fncall (canonicalize-expr/C++ (second v-eq)) builtin-fns))))
429
430             (external-eq-defs   (sys->external-eq-defs
431                                  sys nest-name rhsexpr/C++ canonicalize-expr/C++
432                                  namespace-filter: (lambda (x) (not (equal? x 'event)))))
433
434             (event-external-eq-defs (sys->external-eq-defs 
435                                      sys nest-name rhsexpr/C++ canonicalize-expr/C++
436                                      namespace-filter: (lambda (x) (equal? x 'event))))
437
438             (asgn-eq-defs       (poset->asgn-eq-defs* 
439                                  poset sys nest-name rhsexpr/C++ canonicalize-expr/C++ builtin-fns))
440             
441             (rate-eq-defs       (let ((eqs0 (poset->rate-eq-defs* 
442                                              poset sys method nest-name nest-state-name 
443                                              rhsexpr/C++ canonicalize-expr/C++ builtin-fns)))
444
445                                   (if v-eq
446                                       (cons v-eq (reverse eqs0))
447                                       (reverse eqs0))))
448
449             (state-index-map  (let ((acc (fold (lambda (def ax)
450                                                  (let ((st-name (first def)))
451                                                    (list (+ 1 (first ax)) 
452                                                          (cons `(,st-name ,(first ax)) (second ax)))))
453                                                (list 0 (list)) 
454                                                rate-eq-defs
455                                                )))
456                                 (second acc)))
457             
458             
459             (reaction-eq-defs   (poset->reaction-eq-defs* 
460                                  poset sys nest-name nest-state-name rhsexpr/C++ canonicalize-expr/C++))
461
462             (transient-event-defs  (poset->transient-event-defs 
463                                     poset sys method nest-name nest-state-name rhsexpr/C++ canonicalize-expr/C++ builtin-fns)) 
464             
465             (init-eq-defs       (let ((eqs0 (poset->init-defs* poset sys nest-name nest-state-name
466                                                                rhsexpr/C++ canonicalize-expr/C++ builtin-fns))
467                                       (vi (lookup-def 'v state-index-map))
468                                       (vrest (or (and (lookup-def 'Vrest const-defs) 'Vrest) -65.0)))
469                                     (if (and vi vrest) 
470                                         (cons (list 'v vrest) eqs0)
471                                         eqs0)))
472
473             (steady-state-index-map  (let ((acc (fold
474                                                  (lambda (def ax)
475                                                    (let ((st-name (first def)))
476                                                      (if (not (alist-ref st-name init-eq-defs))
477                                                          (list (+ 1 (first ax)) 
478                                                                (cons `(,st-name ,(first ax)) (second ax)))
479                                                          ax)))
480                                                  (list 0 (list)) 
481                                                  rate-eq-defs)))
482                                        (second acc)))
483             
484             (conserve-eq-defs   (map (lambda (eq) (list 0 `(- ,(second eq) ,(first eq)))) 
485                                      (poset->state-conserve-eq-defs poset sys nest-name nest-state-name)))
486             
487             (imports-sans-v (filter (lambda (x) (not (equal? 'v (first x)))) imports))
488
489             (c-eqs (lookup-def 'c-eqs constraints))
490
491             (c-units (map (lambda (x) 
492                             (let ((n (first x)) (v (second x)))
493                               (list (nest-name n) v)))
494                           (lookup-def 'c-units constraints)))
495             
496             (i-eqs 
497              (map
498               (lambda (def) (list (first def) 
499                                   (add-params-to-fncall (canonicalize-expr/C++ (second def)) builtin-fns)))
500               i-eqs))
501
502             (init-eqs 
503              (append
504               
505               (map (lambda (def)
506                      (let ((n (first def))
507                            (b (second def)))
508                        (list (nest-name n) (nest-name b))))
509                    external-eq-defs)
510               
511               asgn-eq-defs
512               init-eq-defs
513               
514               (map (lambda (pool-ion)
515                      (let ((n (pool-ion-in pool-ion))
516                            (b (pool-ion-inq pool-ion)))
517                        (list n b)))
518                    pool-ions)
519               
520               (map (lambda (pool-ion)
521                      (let ((n (pool-ion-out pool-ion))
522                            (b (pool-ion-outq pool-ion)))
523                        (list n b)))
524                    pool-ions)
525               ))
526
527
528             (init-dag 
529              (map (lambda (def)
530                     (cons (first def) (enum-freevars (second def) '() '())))
531                   init-eqs))
532             
533             (init-order
534              (reverse
535               (topological-sort init-dag 
536                                 (lambda (x y) (string=? (->string x) (->string y))))))
537
538             (init-locals  (find-locals (map second (append init-eqs i-eqs reaction-eq-defs))))
539             
540             (init-vars (delete-duplicates
541                         (map ->string 
542                              (filter (lambda (x) (not (member x builtin-consts)))
543                                      (append
544                                       init-locals
545                                       init-order
546                                       (map first external-eq-defs)
547                                       (map pool-ion-in pool-ions)
548                                       (map pool-ion-out pool-ions)
549                                       (map first i-eqs)
550                                       (map first steady-state-index-map) 
551                                       (map first const-defs)
552                                       (map first reaction-eq-defs)
553                                       )))
554                         string=?))
555             
556             (ss-get-state-defs
557              (case ss-method
558                ((kinsol)
559                 (filter-map 
560                  (lambda (def)
561                    (let* ((n   (first def)) 
562                           (ni  (lookup-def n steady-state-index-map)))
563                      (and ni (expr->string/C++ (ith 'u ni) n))
564                      ))
565                  rate-eq-defs))
566                (else
567                 (filter-map 
568                  (lambda (def)
569                    (let* ((n   (first def)) 
570                           (ni  (lookup-def n steady-state-index-map)))
571                      (and ni (expr->string/C++ (sprintf "gsl_vector_get (u, ~A)" ni) n))
572                      ))
573                  rate-eq-defs))
574                ))
575             
576             (ss-set-state-defs+lbs
577              (case ss-method
578                ((kinsol)
579                 (filter-map 
580                  (lambda (def)
581                    (let* ((n   (first def)) 
582                           (ni  (lookup-def n steady-state-index-map))
583                           (b   (second def))
584                           (lbs (delete-duplicates (find-locals (list b)))))
585                      (and ni (list (list (expr->string/C++ b (ith 'f ni))) lbs))
586                      ))
587                  rate-eq-defs))
588                (else
589                 (filter-map 
590                  (lambda (def)
591                    (let* ((n   (first def)) 
592                           (ni  (lookup-def n steady-state-index-map))
593                           (b   (second def))
594                           (lbs (delete-duplicates (find-locals (list b)))))
595                      (and ni 
596                           (let ((tmp (gensym 't)))
597                             (list
598                              (list
599                               (expr->string/C++ b tmp)
600                               (sprintf "gsl_vector_set (f,~A,~A);" ni tmp))
601                              (cons tmp lbs))
602                             ))
603                      ))
604                  rate-eq-defs))
605                ))
606
607             (ss-vars (delete-duplicates
608                       (map ->string 
609                            (filter (lambda (x) (not (member x builtin-consts)))
610                                    (append
611                                     init-locals
612                                     init-order
613                                     (map first external-eq-defs)
614                                     (map pool-ion-in pool-ions)
615                                     (map pool-ion-out pool-ions)
616                                     (map first i-eqs)
617                                     (map first steady-state-index-map) 
618                                     (map first const-defs)
619                                     (map first reaction-eq-defs)
620                                     )))
621                       string=?))
622             
623
624             (default-eqs 
625               (map (lambda (def)
626                      (let ((n (first def))
627                            (b (second def)))
628                        (expr->string/C++ (nest-name b) (nest-name n))))
629                    defaults))
630
631             (dynamics-eqs 
632              (append
633               
634               external-eq-defs
635               asgn-eq-defs
636               reaction-eq-defs
637               
638               (map (lambda (pool-ion)
639                      (let ((n (pool-ion-in pool-ion))
640                            (b (pool-ion-inq pool-ion)))
641                        (list n b)))
642                    pool-ions)
643               
644               (map (lambda (pool-ion)
645                      (let ((n (pool-ion-out pool-ion))
646                            (b (pool-ion-outq pool-ion)))
647                        (list n b)))
648                    pool-ions)
649               
650               i-eqs
651               ))
652             
653             (dynamics-eq-dag 
654              (map (lambda (def)
655                     (cons (first def) (enum-freevars (second def) '() '())))
656                   dynamics-eqs))
657
658             (dynamics-eq-order
659              (reverse
660               (topological-sort dynamics-eq-dag 
661                                 (lambda (x y) (string=? (->string x) (->string y))))))
662
663             (dynamics-eq-locals  (find-locals 
664                                   (map second
665                                        (append i-eqs rate-eq-defs dynamics-eqs))))
666
667             (dynamics-vars       (delete-duplicates 
668                                   (map (compose ->string nest-name)
669                                        (filter (lambda (x) 
670                                                  (not (member x builtin-consts)))
671                                                (append
672                                                 dynamics-eq-locals
673                                                 dynamics-eq-order
674                                                 (map first i-eqs)
675                                                 (map first external-eq-defs)
676                                                 (map first state-index-map)
677                                                 (map first const-defs)
678                                                 )))
679                                   string=?))
680
681             (residual-rate-eq-defs (map (lambda (def)
682                                           (let* ((n (first def))
683                                                  (i (lookup-def n state-index-map))
684                                                  (fv (ith 'f i))
685                                                  (y1v (ith 'y1 i))
686                                                  (ypv (ith 'yp i))
687                                                  )
688                                             (expr->string/C++ `(- ,y1v ,ypv) fv)))
689                                         rate-eq-defs))
690
691             (define-fn  (make-define-fn sysname))
692             
693             (tmpl-env
694              (fold tenv-enter '()
695                    `(
696                      (currentTimestamp  . ,(seconds->string (current-seconds)))
697                      (nemoVersionString . ,(nemo:version-string))
698                      (modelName         . ,sysname)
699
700                      (abstol            . ,abstol)
701                      (reltol            . ,reltol)
702                      (ODEmethod         . ,method)
703                      (SSmethod          . ,ss-method)
704                      (SSvector          . ,(gensym 'ssvect))
705
706                      (stateSize         . ,(length state-index-map))
707                      (steadyStateSize   . ,(length steady-state-index-map))
708                      (stateIndexMap     . ,(map (lambda (x) (cons (first x) (second x))) state-index-map))
709                      (steadyStateIndexMap . ,(map (lambda (x) (cons (first x) (second x))) steady-state-index-map))
710                      (stateDefs           . ,(map (lambda (def)
711                                                     (let* ((n      (first def)) 
712                                                            (nu     (lookup-def n c-units))
713                                                            (nscale (and nu (nemo:unit-scale nu))))
714                                                       `(
715                                                         (name  . ,(nest-name n))
716                                                         (scale . ,nscale)
717                                                         )
718                                                       ))
719                                                   state-index-map))
720                      (defaultDefs         . ,(map first defaults))
721
722                      (hasEvents         . ,(not (null? transient-event-defs)))
723                      (exports           . ,(map nest-name exports))
724                      (functionDefs      . ,(map (lambda (fndef) 
725                                                   (and
726                                                    (not (member (car fndef) builtin-fns))
727                                                    (begin
728                                                      (apply define-fn (cons indent fndef))
729                                                      )))
730                                               defuns))
731                      (currentEqDefs     . ,(map
732                                             (lambda (def) 
733                                               (expr->string/C++ (second def) (first def)))
734                                             i-eqs))
735                      (residualRateEqDefs . ,residual-rate-eq-defs)
736                      (defaultEqDefs      . ,default-eqs)
737                      (constraintEqDefs   . 
738                                          ,(map (lambda (eq)
739                                                  (match-let 
740                                                   (((op left right)  eq))
741                                                   `((op . ,op)
742                                                     (left . ,(expr->string/C++ (canonicalize-expr/C++ (rhsexpr/C++ left))))
743                                                     (right . ,(expr->string/C++ (canonicalize-expr/C++ (rhsexpr/C++ right))))
744                                                     (str . ,(->string eq))
745                                                     )))
746                                                c-eqs))
747
748                      (synapticEventDefs
749                       . 
750                       ,(map
751                         (lambda (isyn psc transients)
752                           
753                           (let* (
754                                  (ltransient-event-defs
755                                   (filter (lambda (x) (member (first x) transients))
756                                           transient-event-defs))
757                                 
758                                  (levent-external-eq-def
759                                   (car
760                                    (fold (lambda (def ax)
761                                            (let* ((b (second def))
762                                                   (events (let ((fvs (enum-freevars b '() '())))
763                                                             (filter (lambda (x) (member (first x) fvs)) 
764                                                                     event-external-eq-defs))))
765                                              (append events ax)))
766                                          '() ltransient-event-defs)))
767                                 
768                                  (lconsts
769                                   (delete-duplicates
770                                    (fold (lambda (def ax)
771                                            (let* ((n (nest-name (first def)) )
772                                                   (b (second def))
773                                                   (consts (let ((fvs (enum-freevars b '() '())))
774                                                             (filter (lambda (x) (member (first x) fvs)) const-defs)))
775                                                   )
776                                              (append consts ax)))
777                                          '() ltransient-event-defs)
778                                    (lambda (x y) (equal? (first x) (first y))))
779                                   )
780                                 
781                                  (vars (append (map (compose nest-name car) lconsts)
782                                                (list (nest-name (second levent-external-eq-def)))))
783                                  )
784                             `(
785                               (pscName . ,(nest-name (first psc)))
786                               (pscId . ,(nest-name (second psc)))
787                               
788                               (wscale (let ((wscale (fourth isyn)))
789                                         (and wscale (nest-name wscale))))
790                               (wthreshold (let ((wthreshold (fifth isyn)))
791                                             (and wthreshold (nest-name wthreshold))))
792                               
793                               (eventVar . ,(second levent-external-eq-def))
794                               
795                               (eventVarEqDef . ,(let ((b (second levent-external-eq-def)))
796                                                   (sprintf "~A = B_.spike_~A.get_value(lag);" 
797                                                            b (nest-name (second psc)))))
798                               
799                               (externalEventEqDef . 
800                                                   ,(let* ((n      (nest-name (first levent-external-eq-def)))
801                                                           (nu     (lookup-def n c-units))
802                                                           (nscale (and nu (nemo:unit-scale nu)))
803                                                           (b      (second levent-external-eq-def))
804                                                           )
805                                                      (expr->string/C++ (if nscale `(* ,nscale ,b) b) n)))
806                               
807                               (transientEventEqDefs 
808                                . 
809                                ,(fold (lambda (def lst)
810                                         (let* (
811                                                (n  (nest-name (first def)) )
812                                                (ni (lookup-def n state-index-map))
813                                                (b  (second def))
814                                                (consts (let ((fvs (enum-freevars b '() '())))
815                                                          (filter (lambda (x) (member (first x) fvs)) 
816                                                                  const-defs)))
817                                                )
818                                           (append
819                                            (map (lambda (x) 
820                                                   (let ((n (nest-name (first x))))
821                                                     (sprintf "~A = P_.~A;" n n)))
822                                                 consts)
823                                            (if ni (list (expr->string/C++ (getstate ni) n)) '())
824                                            (list (expr->string/C++ b n))
825                                            (if ni (list (expr->string/C++ n (getstate ni))) '())
826                                            )
827                                           ))
828                                       ltransient-event-defs))
829                               
830                               (localVars . ,(append (map (compose nest-name car) lconsts)
831                                                     (list
832                                                      (nest-name (first levent-external-eq-def))
833                                                      (nest-name (second levent-external-eq-def))
834                                                      )
835                                                     (map (lambda (x) (nest-name (first x))) ltransient-event-defs)
836                                                     ))
837                               ))
838                           )
839                         
840                         i-syns pscs psc-transients))
841
842                      (dynamics
843                       .
844                       (
845                        (localVars     . ,dynamics-vars)
846                       
847                        (parameterDefs .
848                                       ,(map (lambda (def)
849                                               (let ((n (first def)) )
850                                                 (expr->string/C++ (sprintf "params->~A" n) n)))
851                                             const-defs))
852                       
853                        (ratePrevEqDefs . 
854                                        ,(map (lambda (def)
855                                                (let* ((n (first def))
856                                                       (ni (lookup-def n state-index-map)))
857                                                  (expr->string/C++ (ith 'y ni) (nest-name n))))
858                                              rate-eq-defs))
859                       
860                        (eqOrderDefs . 
861                                     ,(filter-map (lambda (n)
862                                                    (let ((b (lookup-def n dynamics-eqs)))
863                                                      (and b (expr->string/C++ b (nest-name n)))))
864                                                  dynamics-eq-order))
865                       
866                        (rateEqDefs . 
867                                    ,(map (lambda (def)
868                                            (let* ((n (first def))
869                                                   (b (second def))
870                                                   (fv (ith 'f (lookup-def n state-index-map)))
871                                                   )
872                                              (expr->string/C++ b fv)))
873                                          rate-eq-defs))
874                        ))
875
876                      (init
877                       . 
878                       (
879                       
880                        (localVars         . ,init-vars)
881                        (parameterDefs     . 
882                                           ,(map (lambda (def)
883                                                   (let ((n (first def)) )
884                                                     (expr->string/C++ (sprintf "p.~A" n) n)))
885                                                 const-defs))
886                       
887                        (initOrder         . 
888                                           ,(filter-map (lambda (n)
889                                                          (let ((b  (lookup-def n init-eqs)))
890                                                            (and b (expr->string/C++ b (nest-name n)))))
891                                                        init-order))
892                       
893                        (initEqDefs        . 
894                                           ,(filter-map (lambda (def)
895                                                          (let* ((n  (first def)) 
896                                                                 (ni (lookup-def n state-index-map)))
897                                                            (and ni (expr->string/C++ n (sprintf "y_[~A]" ni)))))
898                                                        init-eq-defs))
899                       
900                        (rateEqStates      . 
901                                           ,(map first rate-eq-defs))
902                       
903                        (reactionEqDefs    . 
904                                           ,(filter-map
905                                             (lambda (def)
906                                               (let ((n (first def)) (b (second def)))
907                                                 (and (not (lookup-def n init-eq-defs))
908                                                      (expr->string/C++ b n))))
909                                             reaction-eq-defs))
910                       
911                       
912                        ))
913                     
914                      (steadystate 
915                       .
916                       (
917                        (localVars         . ,ss-vars)
918                       
919                        (parameterDefs     . ,(map
920                                               (lambda (x) 
921                                                 (let* ((n  (first x)))
922                                                   (expr->string/C++ (sprintf "params->~A" n) n)))
923                                               const-defs))
924                       
925                        (SScurrentEqDefs   . ,(map (lambda (def) 
926                                                     (expr->string/C++ 0. (first def)))
927                                                   i-eqs))
928                       
929                        (SSgetStateDefs    . ,ss-get-state-defs)
930                       
931                        (SSsetStateDefsLbs . ,(map (lambda (def+lbs) 
932                                                     `((defs . ,(first def+lbs))
933                                                       (lbs . ,(second def+lbs))))
934                                                   ss-set-state-defs+lbs))
935                        ))
936                     
937                      (parameters 
938                       . 
939                       (
940                        (localVars       . ,(find-locals (map second const-defs)))
941                       
942                        (parameterEqDefs . ,(map (lambda (def)
943                                                   (let* ((n  (first def)) (b (second def)))
944                                                     (s+ (nest-name n) "  (" (expr->string/C++ b) ")")))
945                                                 const-defs) )
946                       
947                        (parameterDefs  . ,(map (lambda (def)
948                                                  (let* ((n      (first def)) 
949                                                         (nu     (lookup-def n c-units))
950                                                         (nscale (and nu (nemo:unit-scale nu))))
951                                                    `(
952                                                      (name  . ,(nest-name n))
953                                                      (scale . ,nscale)
954                                                      )
955                                                    ))
956                                                const-defs))
957                       
958                        (defaultDefs  . ,(map (lambda (def)
959                                                (let* ((n      (first def)) 
960                                                       (b      (second def))
961                                                       (nu     (lookup-def n c-units))
962                                                       (nscale (and nu (nemo:unit-scale nu))))
963                                                  `(
964                                                    (name  . ,(nest-name n))
965                                                    (scale . ,nscale)
966                                                    )
967                                                  ))
968                                              defaults))
969                       
970                        ))
971                      ))
972              ))
973
974        (for-each
975         (lambda (a)
976           (let ((acc-ion   (car a)))
977             (if (assoc acc-ion perm-ions)
978                 (nemo:error 'nemo:nest-translator 
979                             ": ion species " acc-ion " cannot be declared as both accumulating and permeating"))))
980         acc-ions)
981
982        (if (not (= (length event-external-eq-defs) (length pscs)))
983            (error 'nemo:nest-translator "mismatch between event variables and synaptic conductances" 
984                   event-external-eq-defs pscs))
985
986        (if dump-template-env
987            (for-each (lambda (entry)
988                        (fprintf (current-error-port)
989                                 "~A = ~A~%" (car entry) 
990                                 (ersatz:tvalue->pystr (cdr entry))))
991                      tmpl-env
992                      ))
993       
994        (let ((cpp-output  (open-output-file (make-output-fname dirname prefix ".cpp")))
995              (hpp-output  (open-output-file (make-output-fname dirname prefix ".h"))))
996         
997          (with-output-to-port cpp-output
998            (lambda () (instantiate-template nest-template tmpl-env) ))
999         
1000          (with-output-to-port hpp-output
1001            (lambda () (instantiate-template nest-header-template tmpl-env) ))
1002         
1003          (close-output-port cpp-output)
1004          (close-output-port hpp-output)
1005             
1006          ))
1007      ))
1008  ))
1009  )
1010
1011)
1012
Note: See TracBrowser for help on using the repository browser.