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 | |
---|