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

Last change on this file since 31562 was 31562, checked in by Ivan Raikov, 6 years ago

nemo: updated nest header template

File size: 43.5 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 ".")  (method #f) (ss-method #f) (abstol #f) (reltol #f) (maxstep #f))
310
311    (let ((method (or method 'gsl)))
312
313      (if (not (member method '(gsl cvode ida)))
314          (nemo:error 'nemo:nest-translator ": unknown method " method))
315
316  (match-let ((($ nemo:quantity 'DISPATCH  dis) (hash-table-ref sys (nemo-intern 'dispatch))))
317    (let (
318          (getstate (case method
319                      ((cvode ida) (lambda (i) (sprintf "Ith(B_.y,~A)" i)))
320                      (else (lambda (i) (sprintf "Ith(S_.y_,~A)" i)))))
321          (imports  ((dis 'imports)  sys))
322          (exports  ((dis 'exports)  sys))
323          )
324      (let* ((indent      0)
325             (indent+     (+ 2 indent ))
326
327             (sysname     (nest-name ((dis 'sysname) sys)))
328             (prefix      (->string sysname))
329             (deps*       ((dis 'depgraph*)  sys))
330             (consts      ((dis 'consts)     sys))
331             (asgns       ((dis 'asgns)      sys))
332             (states      ((dis 'states)     sys))
333             (reactions   ((dis 'reactions)  sys))
334             (defuns      ((dis 'defuns)     sys))
335             (components  ((dis 'components) sys))
336             
337             (g             (match-let (((state-list asgn-list g) ((dis 'depgraph*) sys))) g))
338             (poset         (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
339
340             (const-defs       (filter-map
341                                (lambda (nv)
342                                  (and (not (member (first nv) builtin-consts))
343                                       (let ((v1 (canonicalize-expr/C++ (second nv))))
344                                         (list (nest-name (first nv)) v1))))
345                                consts))
346             
347             (defaults             (nemo:defaults-query sys))
348
349             (geometry             (nemo:geometry-query sys))
350
351             (gate-complex-info    (nemo:gate-complex-query sys))
352             (perm-ions       (map (match-lambda ((comp i e erev val) `(,comp ,(nest-name i) ,(nest-name e) ,erev)))
353                                   (lookup-def 'perm-ions gate-complex-info)))
354             (acc-ions        (map (match-lambda ((comp i in out) `(,comp ,@(map nest-name (list i in out)))))
355                                   (lookup-def 'acc-ions gate-complex-info)))
356             (epools          (lookup-def 'pool-ions gate-complex-info))
357             (pool-ions       (pool-ion-name-map nest-name  epools))
358
359             (comprc         (any (match-lambda ((name 'membrane-tau id) (list name id)) (else #f)) components))
360             (compcap        (any (match-lambda ((name 'membrane-capacitance id) (list name id)) (else #f)) components))
361             (mrc            (or (and comprc (car ((dis 'component-exports) sys (cid comprc))))
362                                 (lookup-def 'membrane-tau defaults)
363                                 (lookup-def 'tau_m defaults)
364                                 (and compcap (car ((dis 'component-exports) sys (cid compcap))))
365                                 (lookup-def 'membrane-capacitance defaults)
366                                 (lookup-def 'C_m defaults)
367                                 ))
368
369             (soma-geometry  (lookup-def 'soma geometry))
370             (marea          (and soma-geometry (third soma-geometry)))
371
372             (gate-complexes       (lookup-def 'gate-complexes gate-complex-info))
373             (synapse-info         (nemo:post-synaptic-conductance-query sys))
374
375             (pscs           (lookup-def 'post-synaptic-conductances synapse-info))
376             (psc-transients (map (lambda (lst) (map nest-name lst)) 
377                                  (lookup-def 'psc-transients synapse-info)))
378
379             (i-syns         (lookup-def 'i-synapses synapse-info))
380               
381             (i-gates        (lookup-def 'i-gates gate-complex-info))
382
383             (i-defs         (nemo:ionic-current-definitions
384                              gate-complexes i-gates i-syns pscs marea
385                              (lambda (x) (state-power sys x))
386                              (lambda (x) ((dis 'component-exports) sys x))
387                              (lambda (x) ((dis 'component-subcomps) sys x))
388                              nest-name rhsexpr/C++ canonicalize-expr/C++
389                              builtin-fns))
390
391             (i-eqs          (lookup-def 'i-eqs i-defs))
392             (i-names        (lookup-def 'i-names i-defs))
393
394             (constraints    (nemo:constraint-definitions 
395                              gate-complexes i-gates i-syns pscs marea imports
396                              (lambda (x) (state-power sys x))
397                              (lambda (x) (quantity-unit sys x))
398                              (lambda (x) ((dis 'component-exports) sys x))
399                              (lambda (x) ((dis 'component-subcomps) sys x))
400                              nest-name))
401
402             (v-eq    (and (not (null? i-names))
403                           (let ((istim "(node.B_.I_stim_)" )) 
404                             (cond
405
406                              ((and mrc marea)
407                               (list 'v (rhsexpr/C++ 
408                                         `(/ (+ (* ,istim (/ 100. ,marea)) 
409                                                (* -1e3 ,(sum i-names))) ,mrc))))
410                              (marea
411                               (list 'v (rhsexpr/C++ 
412                                         `(+ (* ,istim (/ 100. ,marea))
413                                             (* -1e-3 ,(sum i-names))))))
414                              (mrc
415                               (list 'v (rhsexpr/C++ `(/ (+ ,istim (* -1e-3 ,(sum i-names))) ,mrc))))
416                             
417                              (else
418                               (list 'v (rhsexpr/C++ `(+ ,istim (* -1e-3 ,(sum i-names))))))
419                              ))
420                           ))
421
422             (v-eq
423              (and v-eq
424                   (list (first v-eq) 
425                         (add-params-to-fncall (canonicalize-expr/C++ (second v-eq)) builtin-fns))))
426
427             (external-eq-defs   (sys->external-eq-defs
428                                  sys nest-name rhsexpr/C++ canonicalize-expr/C++
429                                  namespace-filter: (lambda (x) (not (equal? x 'event)))))
430
431             (event-external-eq-defs (sys->external-eq-defs 
432                                      sys nest-name rhsexpr/C++ canonicalize-expr/C++
433                                      namespace-filter: (lambda (x) (equal? x 'event))))
434
435             (asgn-eq-defs       (poset->asgn-eq-defs* 
436                                  poset sys nest-name rhsexpr/C++ canonicalize-expr/C++ builtin-fns))
437             
438             (rate-eq-defs       (let ((eqs0 (poset->rate-eq-defs* 
439                                              poset sys method nest-name nest-state-name 
440                                              rhsexpr/C++ canonicalize-expr/C++ builtin-fns)))
441
442                                   (if v-eq
443                                       (cons v-eq (reverse eqs0))
444                                       (reverse eqs0))))
445
446             (state-index-map  (let ((acc (fold (lambda (def ax)
447                                                  (let ((st-name (first def)))
448                                                    (list (+ 1 (first ax)) 
449                                                          (cons `(,st-name ,(first ax)) (second ax)))))
450                                                (list 0 (list)) 
451                                                rate-eq-defs
452                                                )))
453                                 (second acc)))
454             
455             
456             (reaction-eq-defs   (poset->reaction-eq-defs* 
457                                  poset sys nest-name nest-state-name rhsexpr/C++ canonicalize-expr/C++))
458
459             (transient-event-defs  (poset->transient-event-defs 
460                                     poset sys method nest-name nest-state-name rhsexpr/C++ canonicalize-expr/C++ builtin-fns)) 
461             
462             (init-eq-defs       (let ((eqs0 (poset->init-defs* poset sys nest-name nest-state-name
463                                                                rhsexpr/C++ canonicalize-expr/C++ builtin-fns))
464                                       (vi (lookup-def 'v state-index-map))
465                                       (vrest (or (and (lookup-def 'Vrest const-defs) 'Vrest) -65.0)))
466                                     (if (and vi vrest) 
467                                         (cons (list 'v vrest) eqs0)
468                                         eqs0)))
469
470             (steady-state-index-map  (let ((acc (fold
471                                                  (lambda (def ax)
472                                                    (let ((st-name (first def)))
473                                                      (if (not (alist-ref st-name init-eq-defs))
474                                                          (list (+ 1 (first ax)) 
475                                                                (cons `(,st-name ,(first ax)) (second ax)))
476                                                          ax)))
477                                                  (list 0 (list)) 
478                                                  rate-eq-defs)))
479                                        (second acc)))
480             
481             (conserve-eq-defs   (map (lambda (eq) (list 0 `(- ,(second eq) ,(first eq)))) 
482                                      (poset->state-conserve-eq-defs poset sys nest-name nest-state-name)))
483             
484             (imports-sans-v (filter (lambda (x) (not (equal? 'v (first x)))) imports))
485
486             (c-eqs (lookup-def 'c-eqs constraints))
487
488             (c-units (map (lambda (x) 
489                             (let ((n (first x)) (v (second x)))
490                               (list (nest-name n) v)))
491                           (lookup-def 'c-units constraints)))
492             
493             (i-eqs 
494              (map
495               (lambda (def) (list (first def) 
496                                   (add-params-to-fncall (canonicalize-expr/C++ (second def)) builtin-fns)))
497               i-eqs))
498
499             (init-eqs 
500              (append
501               
502               (map (lambda (def)
503                      (let ((n (first def))
504                            (b (second def)))
505                        (list (nest-name n) (nest-name b))))
506                    external-eq-defs)
507               
508               asgn-eq-defs
509               init-eq-defs
510               
511               (map (lambda (pool-ion)
512                      (let ((n (pool-ion-in pool-ion))
513                            (b (pool-ion-inq pool-ion)))
514                        (list n b)))
515                    pool-ions)
516               
517               (map (lambda (pool-ion)
518                      (let ((n (pool-ion-out pool-ion))
519                            (b (pool-ion-outq pool-ion)))
520                        (list n b)))
521                    pool-ions)
522               ))
523
524
525             (init-dag 
526              (map (lambda (def)
527                     (cons (first def) (enum-freevars (second def) '() '())))
528                   init-eqs))
529             
530             (init-order
531              (reverse
532               (topological-sort init-dag 
533                                 (lambda (x y) (string=? (->string x) (->string y))))))
534
535             (init-locals  (find-locals (map second (append init-eqs i-eqs reaction-eq-defs))))
536             
537             (init-vars (delete-duplicates
538                         (map ->string 
539                              (filter (lambda (x) (not (member x builtin-consts)))
540                                      (append
541                                       init-locals
542                                       init-order
543                                       (map first external-eq-defs)
544                                       (map pool-ion-in pool-ions)
545                                       (map pool-ion-out pool-ions)
546                                       (map first i-eqs)
547                                       (map first steady-state-index-map) 
548                                       (map first const-defs)
549                                       (map first reaction-eq-defs)
550                                       )))
551                         string=?))
552             
553             (ss-get-state-defs
554              (case ss-method
555                ((kinsol)
556                 (filter-map 
557                  (lambda (def)
558                    (let* ((n   (first def)) 
559                           (ni  (lookup-def n steady-state-index-map)))
560                      (and ni (expr->string/C++ (ith 'u ni) n))
561                      ))
562                  rate-eq-defs))
563                (else
564                 (filter-map 
565                  (lambda (def)
566                    (let* ((n   (first def)) 
567                           (ni  (lookup-def n steady-state-index-map)))
568                      (and ni (expr->string/C++ (sprintf "gsl_vector_get (u, ~A)" ni) n))
569                      ))
570                  rate-eq-defs))
571                ))
572             
573             (ss-set-state-defs+lbs
574              (case ss-method
575                ((kinsol)
576                 (filter-map 
577                  (lambda (def)
578                    (let* ((n   (first def)) 
579                           (ni  (lookup-def n steady-state-index-map))
580                           (b   (second def))
581                           (lbs (delete-duplicates (find-locals (list b)))))
582                      (and ni (list (list (expr->string/C++ b (ith 'f ni))) lbs))
583                      ))
584                  rate-eq-defs))
585                (else
586                 (filter-map 
587                  (lambda (def)
588                    (let* ((n   (first def)) 
589                           (ni  (lookup-def n steady-state-index-map))
590                           (b   (second def))
591                           (lbs (delete-duplicates (find-locals (list b)))))
592                      (and ni 
593                           (let ((tmp (gensym 't)))
594                             (list
595                              (list
596                               (expr->string/C++ b tmp)
597                               (sprintf "gsl_vector_set (f,~A,~A);" ni tmp))
598                              (cons tmp lbs))
599                             ))
600                      ))
601                  rate-eq-defs))
602                ))
603
604             (ss-vars (delete-duplicates
605                       (map ->string 
606                            (filter (lambda (x) (not (member x builtin-consts)))
607                                    (append
608                                     init-locals
609                                     init-order
610                                     (map first external-eq-defs)
611                                     (map pool-ion-in pool-ions)
612                                     (map pool-ion-out pool-ions)
613                                     (map first i-eqs)
614                                     (map first steady-state-index-map) 
615                                     (map first const-defs)
616                                     (map first reaction-eq-defs)
617                                     )))
618                       string=?))
619             
620
621             (default-eqs 
622               (map (lambda (def)
623                      (let ((n (first def))
624                            (b (second def)))
625                        (expr->string/C++ (nest-name b) (nest-name n))))
626                    defaults))
627
628             (dynamics-eqs 
629              (append
630               
631               external-eq-defs
632               asgn-eq-defs
633               reaction-eq-defs
634               
635               (map (lambda (pool-ion)
636                      (let ((n (pool-ion-in pool-ion))
637                            (b (pool-ion-inq pool-ion)))
638                        (list n b)))
639                    pool-ions)
640               
641               (map (lambda (pool-ion)
642                      (let ((n (pool-ion-out pool-ion))
643                            (b (pool-ion-outq pool-ion)))
644                        (list n b)))
645                    pool-ions)
646               
647               i-eqs
648               ))
649             
650             (dynamics-eq-dag 
651              (map (lambda (def)
652                     (cons (first def) (enum-freevars (second def) '() '())))
653                   dynamics-eqs))
654
655             (dynamics-eq-order
656              (reverse
657               (topological-sort dynamics-eq-dag 
658                                 (lambda (x y) (string=? (->string x) (->string y))))))
659
660             (dynamics-eq-locals  (find-locals 
661                                   (map second
662                                        (append i-eqs rate-eq-defs dynamics-eqs))))
663
664             (dynamics-vars       (delete-duplicates 
665                                   (map (compose ->string nest-name)
666                                        (filter (lambda (x) 
667                                                  (not (member x builtin-consts)))
668                                                (append
669                                                 dynamics-eq-locals
670                                                 dynamics-eq-order
671                                                 (map first i-eqs)
672                                                 (map first external-eq-defs)
673                                                 (map first state-index-map)
674                                                 (map first const-defs)
675                                                 )))
676                                   string=?))
677
678             (residual-rate-eq-defs (map (lambda (def)
679                                           (let* ((n (first def))
680                                                  (i (lookup-def n state-index-map))
681                                                  (fv (ith 'f i))
682                                                  (y1v (ith 'y1 i))
683                                                  (ypv (ith 'yp i))
684                                                  )
685                                             (expr->string/C++ `(- ,y1v ,ypv) fv)))
686                                         rate-eq-defs))
687
688             (define-fn  (make-define-fn sysname))
689             
690             (tmpl-env
691              (fold tenv-enter '()
692                    `(
693                      (currentTimestamp  . ,(seconds->string (current-seconds)))
694                      (nemoVersionString . ,(nemo:version-string))
695                      (modelName         . ,sysname)
696
697                      (abstol            . ,abstol)
698                      (reltol            . ,reltol)
699                      (ODEmethod         . ,method)
700                      (SSmethod          . ,ss-method)
701                      (SSvector          . ,(gensym 'ssvect))
702
703                      (stateSize         . ,(length state-index-map))
704                      (steadyStateSize   . ,(length steady-state-index-map))
705                      (stateIndexMap     . ,(map (lambda (x) (cons (first x) (second x))) state-index-map))
706                      (steadyStateIndexMap . ,(map (lambda (x) (cons (first x) (second x))) steady-state-index-map))
707                      (stateDefs           . ,(map first state-index-map))
708                      (defaultDefs         . ,(map first defaults))
709
710                      (hasEvents         . ,(not (null? transient-event-defs)))
711                      (exports           . ,(map nest-name exports))
712                      (functionDefs      . ,(map (lambda (fndef) 
713                                                   (and
714                                                    (not (member (car fndef) builtin-fns))
715                                                    (begin
716                                                      (apply define-fn (cons indent fndef))
717                                                      )))
718                                               defuns))
719                      (currentEqDefs     . ,(map
720                                             (lambda (def) 
721                                               (expr->string/C++ (second def) (first def)))
722                                             i-eqs))
723                      (residualRateEqDefs . ,residual-rate-eq-defs)
724                      (defaultEqDefs      . ,default-eqs)
725                      (constraintEqDefs   . 
726                                          ,(map (lambda (eq)
727                                                  (match-let 
728                                                   (((op left right)  eq))
729                                                   `((op . ,op)
730                                                     (left . ,(expr->string/C++ (canonicalize-expr/C++ (rhsexpr/C++ left))))
731                                                     (right . ,(expr->string/C++ (canonicalize-expr/C++ (rhsexpr/C++ right))))
732                                                     (str . ,(->string eq))
733                                                     )))
734                                                c-eqs))
735
736                      (synapticEventDefs
737                       . 
738                       ,(map
739                         (lambda (isyn psc transients)
740                           
741                           (let* (
742                                  (ltransient-event-defs
743                                   (filter (lambda (x) (member (first x) transients))
744                                           transient-event-defs))
745                                 
746                                  (levent-external-eq-def
747                                   (car
748                                    (fold (lambda (def ax)
749                                            (let* ((b (second def))
750                                                   (events (let ((fvs (enum-freevars b '() '())))
751                                                             (filter (lambda (x) (member (first x) fvs)) 
752                                                                     event-external-eq-defs))))
753                                              (append events ax)))
754                                          '() ltransient-event-defs)))
755                                 
756                                  (lconsts
757                                   (delete-duplicates
758                                    (fold (lambda (def ax)
759                                            (let* ((n (nest-name (first def)) )
760                                                   (b (second def))
761                                                   (consts (let ((fvs (enum-freevars b '() '())))
762                                                             (filter (lambda (x) (member (first x) fvs)) const-defs)))
763                                                   )
764                                              (append consts ax)))
765                                          '() ltransient-event-defs)
766                                    (lambda (x y) (equal? (first x) (first y))))
767                                   )
768                                 
769                                  (vars (append (map (compose nest-name car) lconsts)
770                                                (list (nest-name (second levent-external-eq-def)))))
771                                  )
772                             `(
773                               (pscName . ,(nest-name (first psc)))
774                               (pscId . ,(nest-name (second psc)))
775                               
776                               (wscale (let ((wscale (fourth isyn)))
777                                         (and wscale (nest-name wscale))))
778                               (wthreshold (let ((wthreshold (fifth isyn)))
779                                             (and wthreshold (nest-name wthreshold))))
780                               
781                               (eventVar . ,(second levent-external-eq-def))
782                               
783                               (eventVarEqDef . ,(let ((b (second levent-external-eq-def)))
784                                                   (sprintf "~A = B_.spike_~A.get_value(lag);" 
785                                                            b (nest-name (second psc)))))
786                               
787                               (externalEventEqDef . 
788                                                   ,(let* ((n      (nest-name (first levent-external-eq-def)))
789                                                           (nu     (lookup-def n c-units))
790                                                           (nscale (and nu (nemo:unit-scale nu)))
791                                                           (b      (second levent-external-eq-def))
792                                                           )
793                                                      (expr->string/C++ (if nscale `(* ,nscale ,b) b) n)))
794                               
795                               (transientEventEqDefs 
796                                . 
797                                ,(fold (lambda (def lst)
798                                         (let* (
799                                                (n  (nest-name (first def)) )
800                                                (ni (lookup-def n state-index-map))
801                                                (b  (second def))
802                                                (consts (let ((fvs (enum-freevars b '() '())))
803                                                          (filter (lambda (x) (member (first x) fvs)) 
804                                                                  const-defs)))
805                                                )
806                                           (append
807                                            (map (lambda (x) 
808                                                   (let ((n (nest-name (first x))))
809                                                     (sprintf "~A = P_.~A;" n n)))
810                                                 consts)
811                                            (if ni (list (expr->string/C++ (getstate ni) n)) '())
812                                            (list (expr->string/C++ b n))
813                                            (if ni (list (expr->string/C++ n (getstate ni))) '())
814                                            )
815                                           ))
816                                       ltransient-event-defs))
817                               
818                               (localVars . ,(append (map (compose nest-name car) lconsts)
819                                                     (list
820                                                      (nest-name (first levent-external-eq-def))
821                                                      (nest-name (second levent-external-eq-def))
822                                                      )
823                                                     (map (lambda (x) (nest-name (first x))) ltransient-event-defs)
824                                                     ))
825                               ))
826                           )
827                         
828                         i-syns pscs psc-transients))
829
830                      (dynamics
831                       .
832                       (
833                        (localVars     . ,dynamics-vars)
834                       
835                        (parameterDefs .
836                                       ,(map (lambda (def)
837                                               (let ((n (first def)) )
838                                                 (expr->string/C++ (sprintf "params->~A" n) n)))
839                                             const-defs))
840                       
841                        (ratePrevEqDefs . 
842                                        ,(map (lambda (def)
843                                                (let* ((n (first def))
844                                                       (ni (lookup-def n state-index-map)))
845                                                  (expr->string/C++ (ith 'y ni) (nest-name n))))
846                                              rate-eq-defs))
847                       
848                        (eqOrderDefs . 
849                                     ,(filter-map (lambda (n)
850                                                    (let ((b (lookup-def n dynamics-eqs)))
851                                                      (and b (expr->string/C++ b (nest-name n)))))
852                                                  dynamics-eq-order))
853                       
854                        (rateEqDefs . 
855                                    ,(map (lambda (def)
856                                            (let* ((n (first def))
857                                                   (b (second def))
858                                                   (fv (ith 'f (lookup-def n state-index-map)))
859                                                   )
860                                              (expr->string/C++ b fv)))
861                                          rate-eq-defs))
862                        ))
863
864                      (init
865                       . 
866                       (
867                       
868                        (localVars         . ,init-vars)
869                        (parameterDefs     . 
870                                           ,(map (lambda (def)
871                                                   (let ((n (first def)) )
872                                                     (expr->string/C++ (sprintf "p.~A" n) n)))
873                                                 const-defs))
874                       
875                        (initOrder         . 
876                                           ,(filter-map (lambda (n)
877                                                          (let ((b  (lookup-def n init-eqs)))
878                                                            (and b (expr->string/C++ b (nest-name n)))))
879                                                        init-order))
880                       
881                        (initEqDefs        . 
882                                           ,(filter-map (lambda (def)
883                                                          (let* ((n  (first def)) 
884                                                                 (ni (lookup-def n state-index-map)))
885                                                            (and ni (expr->string/C++ n (sprintf "y_[~A]" ni)))))
886                                                        init-eq-defs))
887                       
888                        (rateEqStates      . 
889                                           ,(map first rate-eq-defs))
890                       
891                        (reactionEqDefs    . 
892                                           ,(filter-map
893                                             (lambda (def)
894                                               (let ((n (first def)) (b (second def)))
895                                                 (and (not (lookup-def n init-eq-defs))
896                                                      (expr->string/C++ b n))))
897                                             reaction-eq-defs))
898                       
899                       
900                        ))
901                     
902                      (steadystate 
903                       .
904                       (
905                        (localVars         . ,ss-vars)
906                       
907                        (parameterDefs     . ,(map
908                                               (lambda (x) 
909                                                 (let* ((n  (first x)))
910                                                   (expr->string/C++ (sprintf "params->~A" n) n)))
911                                               const-defs))
912                       
913                        (SScurrentEqDefs   . ,(map (lambda (def) 
914                                                     (expr->string/C++ 0. (first def)))
915                                                   i-eqs))
916                       
917                        (SSgetStateDefs    . ,ss-get-state-defs)
918                       
919                        (SSsetStateDefsLbs . ,(map (lambda (def+lbs) 
920                                                     `((defs . ,(first def+lbs))
921                                                       (lbs . ,(second def+lbs))))
922                                                   ss-set-state-defs+lbs))
923                        ))
924                     
925                      (parameters 
926                       . 
927                       (
928                        (localVars       . ,(find-locals (map second const-defs)))
929                       
930                        (parameterEqDefs . ,(map (lambda (def)
931                                                   (let* ((n  (first def)) (b (second def)))
932                                                     (s+ (nest-name n) "  (" (expr->string/C++ b) ")")))
933                                                 const-defs) )
934                       
935                        (parameterDefs  . ,(map (lambda (def)
936                                                  (let* ((n      (first def)) 
937                                                         (nu     (lookup-def n c-units))
938                                                         (nscale (and nu (nemo:unit-scale nu))))
939                                                    `(
940                                                      (name  . ,(nest-name n))
941                                                      (scale . ,nscale)
942                                                      )
943                                                    ))
944                                                const-defs))
945                       
946                        (defaultDefs  . ,(map (lambda (def)
947                                                (let* ((n      (first def)) 
948                                                       (b      (second 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                                              defaults))
957                       
958                        ))
959                      ))
960              ))
961
962        (for-each
963         (lambda (a)
964           (let ((acc-ion   (car a)))
965             (if (assoc acc-ion perm-ions)
966                 (nemo:error 'nemo:nest-translator 
967                             ": ion species " acc-ion " cannot be declared as both accumulating and permeating"))))
968         acc-ions)
969
970        (if (not (= (length event-external-eq-defs) (length pscs)))
971            (error 'nemo:nest-translator "mismatch between event variables and synaptic conductances" 
972                   event-external-eq-defs pscs))
973
974        (let ((cpp-output  (open-output-file (make-output-fname dirname prefix ".cpp")))
975              (hpp-output  (open-output-file (make-output-fname dirname prefix ".h"))))
976         
977          (with-output-to-port cpp-output
978            (lambda () (instantiate-template nest-template tmpl-env) ))
979         
980          (with-output-to-port hpp-output
981            (lambda () (instantiate-template nest-header-template tmpl-env) ))
982         
983          (close-output-port cpp-output)
984          (close-output-port hpp-output)
985             
986          ))
987      ))
988  ))
989  )
990
991)
992
Note: See TracBrowser for help on using the repository browser.