Context Navigation

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

Last change on this file since 31587 was 31587, checked in by Ivan Raikov, 6 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.

Download in other formats: