1 | ;; |
---|
2 | ;; |
---|
3 | ;; An extension for translating NEMO models to NMODL descriptions. |
---|
4 | ;; |
---|
5 | ;; Copyright 2008-2012 Ivan Raikov and the Okinawa Institute of Science and Technology |
---|
6 | ;; |
---|
7 | ;; This program is free software: you can redistribute it and/or |
---|
8 | ;; modify it under the terms of the GNU General Public License as |
---|
9 | ;; published by the Free Software Foundation, either version 3 of the |
---|
10 | ;; License, or (at your option) any later version. |
---|
11 | ;; |
---|
12 | ;; This program is distributed in the hope that it will be useful, but |
---|
13 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
15 | ;; General Public License for more details. |
---|
16 | ;; |
---|
17 | ;; A full copy of the GPL license can be found at |
---|
18 | ;; <http://www.gnu.org/licenses/>. |
---|
19 | ;; |
---|
20 | |
---|
21 | (module nemo-nmodl |
---|
22 | |
---|
23 | (nemo:nmodl-translator) |
---|
24 | |
---|
25 | (import scheme chicken utils data-structures lolevel srfi-1 srfi-13 srfi-69) |
---|
26 | |
---|
27 | (require-extension lolevel datatype matchable strictly-pretty |
---|
28 | varsubst datatype |
---|
29 | nemo-core nemo-utils nemo-gate-complex) |
---|
30 | |
---|
31 | (define (safe-car x) |
---|
32 | (and x (car x))) |
---|
33 | |
---|
34 | (define nmodl-builtin-consts |
---|
35 | `(celsius diam)) |
---|
36 | |
---|
37 | (define nmodl-ops |
---|
38 | `(+ - * / > < <= >= = ^)) |
---|
39 | |
---|
40 | (define builtin-fns |
---|
41 | `(+ - * / pow neg abs atan asin acos sin cos exp ln |
---|
42 | sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube |
---|
43 | > < <= >= = and or round ceiling floor max min |
---|
44 | )) |
---|
45 | |
---|
46 | |
---|
47 | (define (nmodl-name s) |
---|
48 | (let ((cs (string->list (->string s)))) |
---|
49 | (let loop ((lst (list)) (cs cs)) |
---|
50 | (if (null? cs) (string->symbol (list->string (reverse lst))) |
---|
51 | (let* ((c (car cs)) |
---|
52 | (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c) |
---|
53 | (else #\_)))) |
---|
54 | (loop (cons c1 lst) (cdr cs))))))) |
---|
55 | |
---|
56 | |
---|
57 | (define (nmodl-state-name n s) |
---|
58 | (nmodl-name (if n (s+ n s) s))) |
---|
59 | |
---|
60 | (define (rhsvars rhs) |
---|
61 | (enum-freevars rhs (list) (list))) |
---|
62 | |
---|
63 | (define (rhsexpr/NMODL expr) |
---|
64 | (match expr |
---|
65 | (('if . es) `(if . ,(map (lambda (x) (rhsexpr/NMODL x)) es))) |
---|
66 | (('let bnds body) `(let ,(map (lambda (x) (list (car x) (rhsexpr/NMODL (cadr x)))) bnds) ,(rhsexpr/NMODL body))) |
---|
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 | ((s . es) (if (symbol? s) (cons (if (member s builtin-fns) s (nmodl-name s)) (map (lambda (x) (rhsexpr/NMODL x)) es)) expr)) |
---|
73 | (id (if (symbol? id) (nmodl-name id) id)))) |
---|
74 | |
---|
75 | |
---|
76 | (define-syntax pp |
---|
77 | (syntax-rules () |
---|
78 | ((pp indent val ...) (ppf indent (quasiquote val) ...)))) |
---|
79 | |
---|
80 | |
---|
81 | (define (letblk/NMODL e1 e2) |
---|
82 | (cond ((equal? e1 (doc:empty)) (doc:group (doc:nest 2 e2))) |
---|
83 | ((equal? e2 (doc:empty)) (doc:group (doc:nest 2 e1))) |
---|
84 | (else (doc:connect (doc:group (doc:nest 2 e1)) |
---|
85 | (doc:group (doc:nest 2 e2)))))) |
---|
86 | |
---|
87 | (define ifthen/NMODL (doc:ifthen 0 (doc:text "if") (doc:text "") (doc:text "else"))) |
---|
88 | (define group/NMODL (doc:block 2 (doc:text "(") (doc:text ")"))) |
---|
89 | (define block/NMODL (doc:block 2 (doc:text "{") (doc:text "}"))) |
---|
90 | (define binop/NMODL (doc:binop 2)) |
---|
91 | |
---|
92 | (define (format-op/NMODL indent op args) |
---|
93 | (let ((op1 (doc:text (->string op)))) |
---|
94 | (let ((res |
---|
95 | (if (null? args) op1 |
---|
96 | (match args |
---|
97 | ((x) (doc:connect op1 x)) |
---|
98 | ((x y) (binop/NMODL x op1 y)) |
---|
99 | ((x y z) (binop/NMODL x op1 (binop/NMODL y op1 z))) |
---|
100 | (lst (let* ((n (length lst)) |
---|
101 | (n/2 (inexact->exact (round (/ n 2))))) |
---|
102 | (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 |
---|
103 | (format-op/NMODL indent op (drop lst n/2 ))))))))) |
---|
104 | res))) |
---|
105 | |
---|
106 | |
---|
107 | (define (format-conseq-op/NMODL indent op args) |
---|
108 | (let ((op1 (doc:text (->string op)))) |
---|
109 | (if (null? args) op1 |
---|
110 | (match args |
---|
111 | ((x) (doc:concat (list op1 x))) |
---|
112 | ((x y) (doc:concat (intersperse (list x op1 y) (doc:space)))) |
---|
113 | ((x y z) (doc:concat (intersperse (list x op1 y op1 z) (doc:space)))) |
---|
114 | (lst (let* ((n (length lst)) |
---|
115 | (n/2 (inexact->exact (round (/ n 2))))) |
---|
116 | (doc:concat |
---|
117 | (intersperse |
---|
118 | (list (format-conseq-op/NMODL indent op (take lst n/2 )) op1 |
---|
119 | (format-conseq-op/NMODL indent op (drop lst n/2 ))) |
---|
120 | (doc:space))))))))) |
---|
121 | |
---|
122 | (define (format-fncall/NMODL indent op args) |
---|
123 | (let ((op1 (doc:text (->string op)))) |
---|
124 | (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args))))) |
---|
125 | |
---|
126 | (define (name-normalize expr) |
---|
127 | (match expr |
---|
128 | (('if c t e) `(if ,(name-normalize c) ,(name-normalize t) ,(name-normalize e))) |
---|
129 | (('let bs e) |
---|
130 | `(let ,(map (lambda (b) `(,(car b) ,(name-normalize (cadr b)))) bs) ,(name-normalize e))) |
---|
131 | ((f . es) |
---|
132 | (cons f (map name-normalize es))) |
---|
133 | ((? symbol? ) (nmodl-name expr)) |
---|
134 | ((? atom? ) expr))) |
---|
135 | |
---|
136 | |
---|
137 | (define (canonicalize-expr/NMODL expr) |
---|
138 | (let ((subst-convert (subst-driver (lambda (x) (and (symbol? x) x)) |
---|
139 | nemo:binding? identity nemo:bind |
---|
140 | nemo:subst-term))) |
---|
141 | (let* ((expr1 (if-convert expr)) |
---|
142 | (expr2 (subst-convert expr1 subst-empty)) |
---|
143 | (expr3 (let-lift expr2)) |
---|
144 | (expr4 (name-normalize expr3))) |
---|
145 | expr4))) |
---|
146 | |
---|
147 | |
---|
148 | (define (format-expr/NMODL indent expr . rest) |
---|
149 | (let-optionals rest ((rv #f)) |
---|
150 | (let ((indent+ (+ 2 indent))) |
---|
151 | (match expr |
---|
152 | (('let bindings body) |
---|
153 | (letblk/NMODL |
---|
154 | (fold-right |
---|
155 | (lambda (x ax) |
---|
156 | (let ((res |
---|
157 | (letblk/NMODL |
---|
158 | (match (second x) |
---|
159 | (('if c t e) |
---|
160 | (ifthen/NMODL |
---|
161 | (group/NMODL (format-expr/NMODL indent c)) |
---|
162 | (block/NMODL (format-expr/NMODL indent t (first x))) |
---|
163 | (block/NMODL (format-expr/NMODL indent e (first x))))) |
---|
164 | (else |
---|
165 | (format-op/NMODL indent+ " = " |
---|
166 | (list (format-expr/NMODL indent (first x) ) |
---|
167 | (format-expr/NMODL indent (second x)))))) |
---|
168 | ax))) |
---|
169 | res |
---|
170 | )) |
---|
171 | (doc:empty) bindings) |
---|
172 | (match body |
---|
173 | (('let _ _) (format-expr/NMODL indent body rv)) |
---|
174 | (else |
---|
175 | (let ((body1 (doc:nest indent (format-expr/NMODL indent body)))) |
---|
176 | (if rv (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1)) |
---|
177 | body1)))))) |
---|
178 | |
---|
179 | (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr)) |
---|
180 | |
---|
181 | ((op . rest) |
---|
182 | (let ((op (case op ((pow) '^) ((abs) 'fabs) ((ln) 'log) (else op)))) |
---|
183 | (let ((fe |
---|
184 | (if (member op nmodl-ops) |
---|
185 | (let ((mdiv? (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest)) |
---|
186 | (mul? (any (lambda (x) (match x (('* . _) #t) (else #f))) rest)) |
---|
187 | (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest))) |
---|
188 | (case op |
---|
189 | ((/) |
---|
190 | (format-op/NMODL indent op |
---|
191 | (map (lambda (x) |
---|
192 | (let ((fx (format-expr/NMODL indent+ x))) |
---|
193 | (if (or (symbol? x) (number? x)) fx |
---|
194 | (if (or mul? plmin?) (group/NMODL fx) fx)))) rest))) |
---|
195 | ((*) |
---|
196 | (format-op/NMODL indent op |
---|
197 | (map (lambda (x) |
---|
198 | (let ((fx (format-expr/NMODL indent+ x))) |
---|
199 | (if (or (symbol? x) (number? x)) fx |
---|
200 | (if plmin? (group/NMODL fx) fx)))) rest))) |
---|
201 | |
---|
202 | ((^) |
---|
203 | (format-op/NMODL indent op |
---|
204 | (map (lambda (x) |
---|
205 | (let ((fx (format-expr/NMODL indent+ x))) |
---|
206 | (if (or (symbol? x) (number? x)) fx |
---|
207 | (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest))) |
---|
208 | |
---|
209 | (else |
---|
210 | (format-op/NMODL indent op |
---|
211 | (map (lambda (x) |
---|
212 | (let ((fx (format-expr/NMODL indent+ x))) fx)) rest))))) |
---|
213 | |
---|
214 | (let ((op (case op ((neg) '-) (else op)))) |
---|
215 | (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest)))))) |
---|
216 | (if rv |
---|
217 | (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe)) |
---|
218 | fe)))) |
---|
219 | |
---|
220 | (else (let ((fe (doc:text (->string expr)))) |
---|
221 | (if rv |
---|
222 | (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe)) |
---|
223 | fe))))))) |
---|
224 | |
---|
225 | |
---|
226 | |
---|
227 | (define (expr->string/NMODL x . rest) |
---|
228 | (let-optionals rest ((rv #f) (width 72)) |
---|
229 | (sdoc->string (doc:format width (format-expr/NMODL 2 x rv))))) |
---|
230 | |
---|
231 | |
---|
232 | (define (format-conseq/NMODL indent expr . rest) |
---|
233 | (let-optionals rest ((rv #f)) |
---|
234 | (let ((indent+ (+ 2 indent))) |
---|
235 | (match expr |
---|
236 | (('let bindings body) |
---|
237 | (letblk/NMODL |
---|
238 | (fold-right |
---|
239 | (lambda (x ax) |
---|
240 | (letblk/NMODL |
---|
241 | (match (second x) |
---|
242 | (('if c t e) |
---|
243 | (ifthen/NMODL |
---|
244 | (group/NMODL (format-conseq/NMODL indent c)) |
---|
245 | (block/NMODL (format-conseq/NMODL indent t (first x))) |
---|
246 | (block/NMODL (format-conseq/NMODL indent e (first x))))) |
---|
247 | (else |
---|
248 | (format-conseq-op/NMODL indent+ " = " |
---|
249 | (list (format-conseq/NMODL indent (first x) ) |
---|
250 | (format-conseq/NMODL indent (second x)))))) |
---|
251 | ax)) |
---|
252 | (doc:empty) bindings) |
---|
253 | (let ((body1 (doc:nest indent (format-conseq/NMODL indent body)))) |
---|
254 | (if rv (format-conseq-op/NMODL indent " = " (list (format-conseq/NMODL indent+ rv ) body1)) |
---|
255 | body1)))) |
---|
256 | |
---|
257 | (('if . rest) (error 'format-conseq/NMODL "invalid if statement " expr)) |
---|
258 | |
---|
259 | ((op . rest) |
---|
260 | (let ((op (case op ((pow) '^) ((abs) 'fabs) (else op)))) |
---|
261 | (let ((fe |
---|
262 | (if (member op nmodl-ops) |
---|
263 | (let ((mdiv? (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest)) |
---|
264 | (mul? (any (lambda (x) (match x (('* . _) #t) (else #f))) rest)) |
---|
265 | (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest))) |
---|
266 | (case op |
---|
267 | ((/) |
---|
268 | (format-conseq-op/NMODL indent op |
---|
269 | (map (lambda (x) |
---|
270 | (let ((fx (format-conseq/NMODL indent+ x))) |
---|
271 | (if (or (symbol? x) (number? x)) fx |
---|
272 | (if (or mul? plmin?) (group/NMODL fx) fx)))) rest))) |
---|
273 | ((*) |
---|
274 | (format-conseq-op/NMODL indent op |
---|
275 | (map (lambda (x) |
---|
276 | (let ((fx (format-conseq/NMODL indent+ x))) |
---|
277 | (if (or (symbol? x) (number? x)) fx |
---|
278 | (if plmin? (group/NMODL fx) fx)))) rest))) |
---|
279 | |
---|
280 | ((^) |
---|
281 | (format-conseq-op/NMODL indent op |
---|
282 | (map (lambda (x) |
---|
283 | (let ((fx (format-conseq/NMODL indent+ x))) |
---|
284 | (if (or (symbol? x) (number? x)) fx |
---|
285 | (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest))) |
---|
286 | |
---|
287 | (else |
---|
288 | (format-conseq-op/NMODL indent op |
---|
289 | (map (lambda (x) |
---|
290 | (let ((fx (format-conseq/NMODL indent+ x))) fx)) rest))))) |
---|
291 | |
---|
292 | (case op |
---|
293 | ((neg) (format-conseq-op/NMODL indent '* (map (lambda (x) (format-conseq/NMODL indent+ x)) |
---|
294 | (cons "(-1)" rest)))) |
---|
295 | (else (format-fncall/NMODL indent op (map (lambda (x) (format-conseq/NMODL indent+ x)) |
---|
296 | rest))))))) |
---|
297 | |
---|
298 | (if rv (format-conseq-op/NMODL indent " = " (list (format-conseq/NMODL indent+ rv ) fe)) fe)))) |
---|
299 | |
---|
300 | (else (let ((fe (doc:text (->string expr)))) |
---|
301 | (if rv |
---|
302 | (format-conseq-op/NMODL indent " = " (list (format-conseq/NMODL indent+ rv ) fe)) |
---|
303 | fe))))))) |
---|
304 | |
---|
305 | |
---|
306 | (define (conserve-conseq->string/NMODL x val . rest) |
---|
307 | (let-optionals rest ((width 72)) |
---|
308 | (s+ "CONSERVE " (sdoc->string (doc:format width (format-conseq/NMODL 2 x #f))) |
---|
309 | " = " (number->string val)))) |
---|
310 | |
---|
311 | |
---|
312 | (define (make-define-fn table? min-v max-v with depend) |
---|
313 | (lambda (indent n proc) |
---|
314 | (let ((lst (procedure-data proc)) |
---|
315 | (indent+ (+ 2 indent))) |
---|
316 | (let ((rt (lookup-def 'rt lst)) |
---|
317 | (formals (lookup-def 'formals lst)) |
---|
318 | (vars (lookup-def 'vars lst)) |
---|
319 | (body (lookup-def 'body lst))) |
---|
320 | (pp indent ,nl (FUNCTION ,(nmodl-name n) (,(slp ", " vars)) "{" )) |
---|
321 | (let* ((body0 (rhsexpr/NMODL body)) |
---|
322 | (body1 (canonicalize-expr/NMODL body0)) |
---|
323 | (lbs (enum-bnds body1 (list)))) |
---|
324 | (if (not (null? lbs)) (pp indent+ (LOCAL ,(slp ", " lbs)))) |
---|
325 | (if (and table? min-v max-v with) |
---|
326 | (match vars |
---|
327 | (('v) (pp indent+ (TABLE ,@(if depend `(DEPEND ,depend) `("")) |
---|
328 | FROM ,min-v TO ,max-v WITH ,with))) |
---|
329 | (else (void)))) |
---|
330 | (pp indent+ ,(expr->string/NMODL body1 (nmodl-name n)))) |
---|
331 | (pp indent "}"))) |
---|
332 | )) |
---|
333 | |
---|
334 | (define (expeuler dt name rhs) |
---|
335 | (define (isname? x) (equal? x name)) |
---|
336 | (let ((res |
---|
337 | (match rhs |
---|
338 | ((or ('- A ('* B (and x (? isname?)))) |
---|
339 | ('+ ('neg ('* B (and x (? isname?)))) A)) |
---|
340 | (let ((xexp (string->symbol (s+ x 'exp)))) |
---|
341 | `(let ((,xexp (exp (* (neg ,B) ,dt)))) |
---|
342 | (+ (* ,x ,xexp) (* (- 1 ,xexp) (/ ,A ,B)))))) |
---|
343 | |
---|
344 | ((or ('- A ('* (and x (? isname?)) . B)) |
---|
345 | ('+ ('neg ('* (and x (? isname?)) . B)) A)) |
---|
346 | (let ((xexp (string->symbol (s+ x 'exp))) |
---|
347 | (B1 (if (null? (cdr B)) (car B) `(* ,@B)))) |
---|
348 | `(let ((,xexp (exp (* (neg ,B1) ,dt)))) |
---|
349 | (+ (* ,x ,xexp) (* (- 1 ,xexp) (/ ,A ,B1)))))) |
---|
350 | |
---|
351 | (('+ ('neg ('* (and x1 (? isname?)) Alpha)) |
---|
352 | ('* ('- 1 (and x2 (? isname?))) Beta)) |
---|
353 | (let ((A Alpha) |
---|
354 | (B `(+ ,Alpha ,Beta))) |
---|
355 | (let ((xexp (string->symbol (s+ x1 'exp)))) |
---|
356 | `(let ((,xexp (exp (* (neg ,B) ,dt)))) |
---|
357 | (+ (* ,x1 ,xexp) (* (- 1 ,xexp) (/ ,A ,B))))))) |
---|
358 | |
---|
359 | (('let bnds body) |
---|
360 | `(let ,bnds ,(expeuler dt name body))) |
---|
361 | |
---|
362 | (else (nemo:error 'nemo:expeuler: "unable to rewrite equation " rhs |
---|
363 | "in exponential Euler form"))))) |
---|
364 | |
---|
365 | res)) |
---|
366 | |
---|
367 | |
---|
368 | (define (reaction-transition-eqs n initial open transitions conserve power method) |
---|
369 | (match-let (((g cnode node-subs) (transitions-graph n open transitions conserve nmodl-state-name))) |
---|
370 | (let* ((out-edges (g 'out-edges)) |
---|
371 | (in-edges (g 'in-edges)) |
---|
372 | (nodes ((g 'nodes)))) |
---|
373 | ;; generate differential equations for each state in the transitions system |
---|
374 | (let ((eqs (fold (lambda (s ax) |
---|
375 | (if (and cnode (= (first cnode) (first s) )) ax |
---|
376 | (let* ((out (out-edges (first s))) |
---|
377 | (in (in-edges (first s))) |
---|
378 | (open? (eq? (second s) open)) |
---|
379 | (name (nmodl-name (lookup-def (second s) node-subs)))) |
---|
380 | |
---|
381 | (let* ((rhs1 (cond ((and (not (null? out)) (not (null? in))) |
---|
382 | `(+ (neg ,(sum (map third out))) |
---|
383 | ,(sum (map third in)))) |
---|
384 | ((and (not (null? out)) (null? in)) |
---|
385 | `(neg ,(sum (map third out)))) |
---|
386 | ((and (null? out) (not (null? in))) |
---|
387 | (sum (map third in))))) |
---|
388 | |
---|
389 | (fbody0 (rhsexpr/NMODL rhs1)) |
---|
390 | (fbody1 (case method |
---|
391 | ((expeuler) (canonicalize-expr/NMODL (expeuler 'dt name fbody0))) |
---|
392 | (else (canonicalize-expr/NMODL fbody0))))) |
---|
393 | (cons (list name fbody1) ax)) |
---|
394 | ))) |
---|
395 | (list) nodes))) |
---|
396 | eqs)))) |
---|
397 | |
---|
398 | |
---|
399 | |
---|
400 | |
---|
401 | |
---|
402 | (define (reaction-keqs n initial open transitions power) |
---|
403 | (let* ((subst-convert (subst-driver (lambda (x) (and (symbol? x) x)) |
---|
404 | nemo:binding? identity nemo:bind nemo:subst-term)) |
---|
405 | (state-list (let loop ((lst (list)) (tlst transitions)) |
---|
406 | (if (null? tlst) (delete-duplicates lst eq?) |
---|
407 | (match (car tlst) |
---|
408 | (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr) |
---|
409 | (loop (cons* s0 s1 lst) (cdr tlst))) |
---|
410 | (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr) |
---|
411 | (loop (cons* s0 s1 lst) (cdr tlst))) |
---|
412 | (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2) |
---|
413 | (loop (cons* s0 s1 lst) (cdr tlst))) |
---|
414 | (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2) |
---|
415 | (loop (cons* s0 s1 lst) (cdr tlst))) |
---|
416 | (else |
---|
417 | (nemo:error 'nemo:nmodl-reaction-keqs: "invalid transition equation " |
---|
418 | (car tlst) " in state complex " n)) |
---|
419 | (else (loop lst (cdr tlst))))))) |
---|
420 | (state-subs (fold (lambda (s ax) (subst-extend s (nmodl-state-name n s) ax)) subst-empty state-list))) |
---|
421 | ;; generate kinetic equations for each edge in the transitions system |
---|
422 | (list n |
---|
423 | (map |
---|
424 | (lambda (e) |
---|
425 | (match e |
---|
426 | (('-> s0 s1 rexpr) |
---|
427 | (let ((i (lookup-def s0 state-subs)) |
---|
428 | (j (lookup-def s1 state-subs))) |
---|
429 | `(-> ,i ,j ,(canonicalize-expr/NMODL |
---|
430 | (subst-convert rexpr state-subs))))) |
---|
431 | |
---|
432 | ((s0 '-> s1 rexpr) |
---|
433 | (let ((i (lookup-def s0 state-subs)) |
---|
434 | (j (lookup-def s1 state-subs))) |
---|
435 | `(-> ,i ,j ,(canonicalize-expr/NMODL |
---|
436 | (subst-convert rexpr state-subs))))) |
---|
437 | |
---|
438 | (('<-> s0 s1 rexpr1 rexpr2) |
---|
439 | (let ((i (lookup-def s0 state-subs)) |
---|
440 | (j (lookup-def s1 state-subs))) |
---|
441 | `(<-> ,i ,j |
---|
442 | ,(canonicalize-expr/NMODL (subst-convert rexpr1 state-subs)) |
---|
443 | ,(canonicalize-expr/NMODL (subst-convert rexpr2 state-subs))))) |
---|
444 | |
---|
445 | ((s0 '<-> s1 rexpr1 rexpr2) |
---|
446 | (let ((i (lookup-def s0 state-subs)) |
---|
447 | (j (lookup-def s1 state-subs))) |
---|
448 | `(<-> ,i ,j |
---|
449 | ,(canonicalize-expr/NMODL (subst-convert rexpr1 state-subs)) |
---|
450 | ,(canonicalize-expr/NMODL (subst-convert rexpr2 state-subs))))) |
---|
451 | |
---|
452 | |
---|
453 | (else (nemo:error 'nemo:nmodl-reaction-keqs: "invalid transition equation " |
---|
454 | e " in state complex " n)))) |
---|
455 | transitions)))) |
---|
456 | |
---|
457 | |
---|
458 | |
---|
459 | (define (state-init n init) |
---|
460 | (let* ((init (rhsexpr/NMODL init)) |
---|
461 | (init1 (canonicalize-expr/NMODL init))) |
---|
462 | (list (nmodl-name n) init1))) |
---|
463 | |
---|
464 | |
---|
465 | (define (asgn-eq n rhs) |
---|
466 | (let* ((fbody (rhsexpr/NMODL rhs)) |
---|
467 | (fbody1 (canonicalize-expr/NMODL fbody))) |
---|
468 | (list (nmodl-name n) fbody1))) |
---|
469 | |
---|
470 | |
---|
471 | (define (reaction-eq n open transitions conserve) |
---|
472 | (if (symbol? open) |
---|
473 | (list (nmodl-name n) (nmodl-state-name n open)) |
---|
474 | (list (nmodl-name n) (sum (map (lambda (x) (nmodl-state-name n x)) open))) |
---|
475 | )) |
---|
476 | |
---|
477 | |
---|
478 | (define (poset->reaction-eq-defs poset sys kinetic) |
---|
479 | (fold-right |
---|
480 | (lambda (lst ax) |
---|
481 | (fold (lambda (x ax) |
---|
482 | (match-let (((i . n) x)) |
---|
483 | (let ((en (hash-table-ref sys n))) |
---|
484 | (if (nemo:quantity? en) |
---|
485 | (cases nemo:quantity en |
---|
486 | (REACTION (name initial open transitions conserve power) |
---|
487 | (cons (reaction-eq name open transitions conserve) ax)) |
---|
488 | |
---|
489 | (else ax)) |
---|
490 | ax)))) |
---|
491 | ax lst)) |
---|
492 | (list) poset)) |
---|
493 | |
---|
494 | |
---|
495 | (define (poset->asgn-eq-defs poset sys) |
---|
496 | (fold-right |
---|
497 | (lambda (lst ax) |
---|
498 | (fold (lambda (x ax) |
---|
499 | (match-let (((i . n) x)) |
---|
500 | (let ((en (hash-table-ref sys n))) |
---|
501 | (if (nemo:quantity? en) |
---|
502 | (cases nemo:quantity en |
---|
503 | (ASGN (name value rhs) (cons (asgn-eq name rhs) ax)) |
---|
504 | (else ax)) |
---|
505 | ax)))) |
---|
506 | ax lst)) |
---|
507 | (list) poset)) |
---|
508 | |
---|
509 | |
---|
510 | (define (poset->rate-eq-defs poset sys kinetic method) |
---|
511 | (fold-right |
---|
512 | (lambda (lst ax) |
---|
513 | (fold (lambda (x ax) |
---|
514 | (match-let (((i . n) x)) |
---|
515 | (let ((en (hash-table-ref sys n))) |
---|
516 | (if (and (not (member n kinetic)) (nemo:quantity? en)) |
---|
517 | (cases nemo:quantity en |
---|
518 | (REACTION (name initial open transitions conserve power) |
---|
519 | (append (reaction-transition-eqs name initial open transitions |
---|
520 | conserve power method) ax)) |
---|
521 | |
---|
522 | (RATE (name initial rhs power) |
---|
523 | (let ((fbody0 (rhsexpr/NMODL rhs)) |
---|
524 | (dy (nmodl-name name ))) |
---|
525 | (case method |
---|
526 | ((expeuler) |
---|
527 | (cons (list dy (canonicalize-expr/NMODL (expeuler 'dt name fbody0))) |
---|
528 | ax)) |
---|
529 | (else |
---|
530 | (cons (list dy (canonicalize-expr/NMODL fbody0)) ax))))) |
---|
531 | |
---|
532 | (else ax)) |
---|
533 | ax)))) |
---|
534 | ax lst)) |
---|
535 | (list) poset)) |
---|
536 | |
---|
537 | |
---|
538 | (define (poset->kinetic-eq-defs poset sys kinetic) |
---|
539 | (fold-right |
---|
540 | (lambda (lst ax) |
---|
541 | (fold (lambda (x ax) |
---|
542 | (match-let (((i . n) x)) |
---|
543 | (let ((en (hash-table-ref sys n))) |
---|
544 | (if (and (member n kinetic) (nemo:quantity? en)) |
---|
545 | (cases nemo:quantity en |
---|
546 | (REACTION (name initial open transitions conserve power) |
---|
547 | (cons (reaction-keqs name initial open transitions power) ax)) |
---|
548 | (else ax)) |
---|
549 | ax)))) |
---|
550 | ax lst)) |
---|
551 | (list) poset)) |
---|
552 | |
---|
553 | |
---|
554 | (define (poset->state-init-defs poset sys) |
---|
555 | (fold-right |
---|
556 | (lambda (lst ax) |
---|
557 | (fold (lambda (x ax) |
---|
558 | (match-let (((i . n) x)) |
---|
559 | (let ((en (hash-table-ref sys n))) |
---|
560 | (if (nemo:quantity? en) |
---|
561 | (cases nemo:quantity en |
---|
562 | (REACTION (name initial open transitions conserve power) |
---|
563 | (if (nemo:rhs? initial) |
---|
564 | (cons* (state-init name initial) |
---|
565 | (state-init (nmodl-state-name name open) name) ax) |
---|
566 | ax)) |
---|
567 | (RATE (name initial rhs power) |
---|
568 | (if (nemo:rhs? initial) |
---|
569 | (cons (state-init name initial) ax) |
---|
570 | ax)) |
---|
571 | (else ax)) |
---|
572 | ax)))) |
---|
573 | ax lst)) |
---|
574 | (list) poset)) |
---|
575 | |
---|
576 | (define (poset->state-conserve-eq-defs poset sys) |
---|
577 | (fold-right |
---|
578 | (lambda (lst ax) |
---|
579 | (fold (lambda (x ax) |
---|
580 | (match-let (((i . n) x)) |
---|
581 | (let ((en (hash-table-ref sys n))) |
---|
582 | (if (nemo:quantity? en) |
---|
583 | (cases nemo:quantity en |
---|
584 | (REACTION (name initial open transitions conserve power) |
---|
585 | (if (and (list? conserve) (every nemo:conseq? conserve)) |
---|
586 | (cons (state-conseqs (nmodl-name name) transitions conserve |
---|
587 | nmodl-state-name) ax) |
---|
588 | ax)) |
---|
589 | (else ax)) |
---|
590 | ax)))) |
---|
591 | ax lst)) |
---|
592 | (list) poset)) |
---|
593 | |
---|
594 | |
---|
595 | (define (find-locals defs) |
---|
596 | (concatenate (map (lambda (def) |
---|
597 | (match def |
---|
598 | (('let bnds body) |
---|
599 | (let ((bexprs (map second bnds))) |
---|
600 | (concatenate (list (map first bnds) |
---|
601 | (find-locals bexprs ) |
---|
602 | (find-locals (list body)))))) |
---|
603 | (('if c t e) (append (find-locals (list t)) (find-locals (list e)))) |
---|
604 | ((s . rest) (find-locals rest)) |
---|
605 | (else (list)))) |
---|
606 | defs))) |
---|
607 | |
---|
608 | (define (member-imports x imports) |
---|
609 | (safe-car (member x imports (lambda (x y) (equal? x (car y)))))) |
---|
610 | |
---|
611 | |
---|
612 | (define (rate/reaction-power sys n) |
---|
613 | (let ((en (hash-table-ref sys n))) |
---|
614 | (if (nemo:quantity? en) |
---|
615 | (cases nemo:quantity en |
---|
616 | (REACTION (name initial open transitions conserve power) |
---|
617 | power) |
---|
618 | (RATE (name initial rhs power) |
---|
619 | power) |
---|
620 | (else #f)) |
---|
621 | #f))) |
---|
622 | |
---|
623 | |
---|
624 | (define (bucket-partition p lst) |
---|
625 | (let loop ((lst lst) (ax (list))) |
---|
626 | (if (null? lst) ax |
---|
627 | (let ((x (car lst))) |
---|
628 | (let bkt-loop ((old-bkts ax) (new-bkts (list))) |
---|
629 | (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts)) |
---|
630 | (if (p x (caar old-bkts )) |
---|
631 | (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts))) |
---|
632 | (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts))))))))) |
---|
633 | |
---|
634 | |
---|
635 | |
---|
636 | (define (nemo:nmodl-translator sys . rest) |
---|
637 | (define (cid x) (second x)) |
---|
638 | (define (cn x) (first x)) |
---|
639 | (let-optionals rest ((method 'cnexp) (table? #f) (min-v -100) (max-v 100) (step 0.5) |
---|
640 | (depend #f) (kinetic (list)) (linear? #f)) |
---|
641 | (match-let ((($ nemo:quantity 'DISPATCH dis) (hash-table-ref sys (nemo-intern 'dispatch)))) |
---|
642 | (let ((eval-const (let ((eval-const (dis 'eval-const))) |
---|
643 | (lambda (x q) (eval-const sys x q)))) |
---|
644 | (imports ((dis 'imports) sys)) |
---|
645 | (exports ((dis 'exports) sys)) |
---|
646 | ) |
---|
647 | (let* ((indent 0) |
---|
648 | (indent+ (+ 2 indent )) |
---|
649 | (table-with (and table? (inexact->exact (round (/ (abs (- max-v min-v)) step))))) |
---|
650 | (sysname (nmodl-name ((dis 'sysname) sys))) |
---|
651 | (consts ((dis 'consts) sys)) |
---|
652 | (asgns ((dis 'asgns) sys)) |
---|
653 | (states ((dis 'states) sys)) |
---|
654 | (kinetic (or kinetic '())) |
---|
655 | (kinetic (delete-duplicates |
---|
656 | (cond ((eq? kinetic 'all) (filter-map first states)) |
---|
657 | ((symbol? kinetic) |
---|
658 | (let ((sk (->string kinetic))) |
---|
659 | (filter-map (lambda (s) (and s (and (string-suffix? sk (->string s)) s)) ) |
---|
660 | (map first states)))) |
---|
661 | (else |
---|
662 | (let ((kinetic (map ->string kinetic)) |
---|
663 | (ss (map (compose ->string first) states))) |
---|
664 | (concatenate |
---|
665 | (map (lambda (sk) |
---|
666 | (filter-map (lambda (s) (and (string-suffix? sk s) s)) |
---|
667 | ss)) |
---|
668 | kinetic))))))) |
---|
669 | (reactions ((dis 'reactions) sys)) |
---|
670 | (rates ((dis 'rates) sys)) |
---|
671 | (defuns ((dis 'defuns) sys)) |
---|
672 | (components ((dis 'components) sys)) |
---|
673 | (g (match-let (((state-list asgn-list g) ((dis 'depgraph*) sys))) g)) |
---|
674 | (poset (vector->list ((dis 'depgraph->bfs-dist-poset) g))) |
---|
675 | |
---|
676 | (gate-complex-info (nemo:gate-complex-query sys)) |
---|
677 | (gate-complexes (lookup-def 'gate-complexes gate-complex-info)) |
---|
678 | (perm-ions (map (match-lambda ((comp i e erev) `(,comp ,(nmodl-name i) ,(nmodl-name e) ,erev))) |
---|
679 | (lookup-def 'perm-ions gate-complex-info))) |
---|
680 | (acc-ions (map (match-lambda ((comp i in out) `(,comp ,@(map nmodl-name (list i in out))))) |
---|
681 | (lookup-def 'acc-ions gate-complex-info))) |
---|
682 | (mod-ions (lookup-def 'mod-ions gate-complex-info)) |
---|
683 | (epools (lookup-def 'pool-ions gate-complex-info)) |
---|
684 | (pool-ions (map (lambda (lst) (map nmodl-name lst)) epools)) |
---|
685 | |
---|
686 | (i-gates (lookup-def 'i-gates gate-complex-info)) |
---|
687 | |
---|
688 | (has-kinetic? (or (not (null? (filter (lambda (x) (member (car x) kinetic)) states))))) |
---|
689 | (has-ode? (or (not (null? (filter (lambda (x) (not (member (car x) kinetic))) states))) |
---|
690 | (not (null? pool-ions)))) |
---|
691 | |
---|
692 | (asgn-eq-defs (poset->asgn-eq-defs poset sys)) |
---|
693 | (reaction-eq-defs (poset->reaction-eq-defs poset sys kinetic)) |
---|
694 | (rate-eq-defs (reverse (poset->rate-eq-defs poset sys kinetic method))) |
---|
695 | (kstate-eq-defs (poset->kinetic-eq-defs poset sys kinetic)) |
---|
696 | (conserve-eq-defs (poset->state-conserve-eq-defs poset sys)) |
---|
697 | (state-init-defs (poset->state-init-defs poset sys)) |
---|
698 | |
---|
699 | ) |
---|
700 | |
---|
701 | (pp indent ,nl (TITLE ,sysname)) |
---|
702 | |
---|
703 | (pp indent ,nl (NEURON "{")) |
---|
704 | (let recur ((exports exports)) |
---|
705 | (if (not (null? exports)) |
---|
706 | (begin |
---|
707 | (pp indent+ (RANGE ,(slp ", " (map nmodl-name (take exports (min 10 (length exports))))))) |
---|
708 | (recur (drop exports (min 10 (length exports))))))) |
---|
709 | |
---|
710 | (let ((currents (append (map (lambda (gate-complex) (nmodl-name (s+ 'i_ (first gate-complex)))) gate-complexes ) |
---|
711 | (map (lambda (i-gate) (nmodl-name (s+ 'i_ (second i-gate)))) i-gates )))) |
---|
712 | (if (not (null? currents)) (pp indent+ (RANGE ,(slp ", " currents))))) |
---|
713 | |
---|
714 | (for-each (lambda (x) |
---|
715 | (case (first x) |
---|
716 | ((non-specific) |
---|
717 | (pp indent+ |
---|
718 | (RANGE ,(third x)) |
---|
719 | (NONSPECIFIC_CURRENT ,(second x)))) |
---|
720 | (else |
---|
721 | (cond ((fourth x) |
---|
722 | (let* ((ion (first x)) |
---|
723 | (readqs (filter identity |
---|
724 | (list (third x) |
---|
725 | (safe-car (member-imports (string->symbol (s+ ion 'i)) imports)) |
---|
726 | (safe-car (member-imports (string->symbol (s+ ion 'o)) imports))))) |
---|
727 | ) |
---|
728 | (pp indent+ |
---|
729 | (RANGE ,(second x)) |
---|
730 | (RANGE ,(third x)) |
---|
731 | (USEION ,ion READ ,(slp ", " readqs) WRITE ,(second x))))) |
---|
732 | (else (pp indent+ (RANGE ,(second x)))))))) |
---|
733 | (delete-duplicates perm-ions (lambda (x y) (eq? (car x) (car y))))) |
---|
734 | |
---|
735 | |
---|
736 | (if (null? acc-ions) |
---|
737 | (begin |
---|
738 | (for-each (lambda (pool-ion epool) |
---|
739 | (let ((valence (fifth epool))) |
---|
740 | (if valence |
---|
741 | (pp indent+ (RANGE ,(slp ", " (list (second pool-ion) (third pool-ion)))) |
---|
742 | (USEION ,(fourth pool-ion) |
---|
743 | READ ,(slp ", " (list (second pool-ion))) |
---|
744 | WRITE ,(slp ", " (list (third pool-ion ))) |
---|
745 | VALENCE ,(inexact->exact (eval-const valence valence)))) |
---|
746 | (pp indent+ (RANGE ,(slp ", " (list (second pool-ion) (third pool-ion)))) |
---|
747 | (USEION ,(fourth pool-ion) |
---|
748 | READ ,(slp ", " (list (second pool-ion))) |
---|
749 | WRITE ,(slp ", " (list (third pool-ion ))))) |
---|
750 | ))) |
---|
751 | pool-ions epools) |
---|
752 | |
---|
753 | (for-each (lambda (mod-ion) |
---|
754 | (pp indent+ |
---|
755 | (RANGE ,(second mod-ion)) |
---|
756 | (USEION ,(first mod-ion) READ ,(second mod-ion)))) |
---|
757 | mod-ions) |
---|
758 | ) |
---|
759 | (for-each (lambda (acc-ion) |
---|
760 | (let ((pool-ion (assoc (first acc-ion) pool-ions))) |
---|
761 | (if pool-ion |
---|
762 | (pp indent+ (RANGE ,(second acc-ion)) |
---|
763 | (USEION ,(first acc-ion) |
---|
764 | READ ,(slp ", " (list (third acc-ion) (fourth acc-ion) (second pool-ion))) |
---|
765 | WRITE ,(slp ", " (list (second acc-ion) (third pool-ion ))))) |
---|
766 | (pp indent+ (RANGE ,(second acc-ion)) |
---|
767 | (USEION ,(first acc-ion) |
---|
768 | READ ,(slp ", " (list (third acc-ion) (fourth acc-ion) )) |
---|
769 | WRITE ,(second acc-ion)))))) |
---|
770 | (delete-duplicates acc-ions (lambda (x y) (eq? (car x) (car y)))))) |
---|
771 | |
---|
772 | (let* ((const-names (map first consts)) |
---|
773 | (is-const? (lambda (x) (member x const-names))) |
---|
774 | (range-consts (delete-duplicates |
---|
775 | (fold (lambda (def ax) |
---|
776 | (let* ((rhs (second def)) |
---|
777 | (vars (rhsvars rhs))) |
---|
778 | (append (filter is-const? vars) ax))) |
---|
779 | (list) asgn-eq-defs )))) |
---|
780 | (if (not (null? range-consts)) (pp indent+ (RANGE ,(slp ", " range-consts))))) |
---|
781 | |
---|
782 | |
---|
783 | (pp indent "}") |
---|
784 | |
---|
785 | (let* ((define-fn (make-define-fn table? min-v max-v table-with depend))) |
---|
786 | (for-each (lambda (fndef) |
---|
787 | (if (not (member (car fndef) builtin-fns)) |
---|
788 | (apply define-fn (cons indent fndef)))) |
---|
789 | defuns)) |
---|
790 | |
---|
791 | (let* ((parameter-defs |
---|
792 | (filter-map |
---|
793 | (lambda (nv) |
---|
794 | (and (not (member (first nv) nmodl-builtin-consts)) |
---|
795 | (let ((v1 (canonicalize-expr/NMODL (second nv)))) |
---|
796 | (list (first nv) v1)))) |
---|
797 | consts)) |
---|
798 | |
---|
799 | (parameter-locals (find-locals (map second parameter-defs))) |
---|
800 | |
---|
801 | (state-defs |
---|
802 | (append |
---|
803 | (map (lambda (st) |
---|
804 | (if (pair? st) (nmodl-state-name (first st) (second st)) |
---|
805 | (nmodl-name st))) |
---|
806 | states) |
---|
807 | (map nmodl-name reactions))) |
---|
808 | |
---|
809 | (assigned-defs |
---|
810 | (filter-map |
---|
811 | (lambda (x) |
---|
812 | (let ((x1 (nmodl-name x))) |
---|
813 | (and (not (or (member x1 state-defs) (assoc x1 parameter-defs))) |
---|
814 | x1))) |
---|
815 | (delete-duplicates |
---|
816 | (append asgns |
---|
817 | (map first imports) |
---|
818 | (map second perm-ions) (map third perm-ions) |
---|
819 | (map second acc-ions) (map fourth acc-ions) |
---|
820 | (map second pool-ions) (map third pool-ions) |
---|
821 | (map (lambda (gate-complex) (nmodl-name (s+ 'i_ (first gate-complex)))) gate-complexes ) |
---|
822 | (map (lambda (i-gate) (nmodl-name (s+ 'i_ (second i-gate)))) i-gates ) |
---|
823 | )))) |
---|
824 | ) |
---|
825 | |
---|
826 | (pp indent ,nl (PARAMETER "{")) |
---|
827 | (if (not (null? parameter-locals)) (pp indent+ (LOCAL ,(slp ", " parameter-locals)))) |
---|
828 | (for-each (lambda (def) |
---|
829 | (let ((n (nmodl-name (first def))) (b (second def))) |
---|
830 | (pp indent+ ,(expr->string/NMODL b n)))) parameter-defs) |
---|
831 | (case method ((expeuler) (pp indent+ dt))) |
---|
832 | (pp indent "}") |
---|
833 | (pp indent ,nl (STATE "{")) |
---|
834 | (for-each (lambda (x) (pp indent+ ,x)) state-defs) |
---|
835 | (pp indent "}") |
---|
836 | (pp indent ,nl (ASSIGNED "{")) |
---|
837 | (for-each (lambda (x) (pp indent+ ,x)) assigned-defs) |
---|
838 | (pp indent "}")) |
---|
839 | |
---|
840 | (if (not (null? asgns)) |
---|
841 | (begin |
---|
842 | (pp indent ,nl (PROCEDURE asgns () "{")) |
---|
843 | (let ((locals (find-locals (map second asgn-eq-defs))) ) |
---|
844 | (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals))))) |
---|
845 | #| |
---|
846 | This seems to cause a segmentation fault in nrnoc: |
---|
847 | |
---|
848 | (if (and table? min-v max-v table-with) |
---|
849 | (pp indent+ (TABLE ,(slp ", " (map first asgn-eq-defs)) |
---|
850 | ,@(if depend `(DEPEND ,depend) `("")) |
---|
851 | FROM ,min-v TO ,max-v WITH ,table-with))) |
---|
852 | |# |
---|
853 | |
---|
854 | (for-each (lambda (def) |
---|
855 | (let ((n (nmodl-name (first def)) ) |
---|
856 | (b (second def))) |
---|
857 | (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs) |
---|
858 | (pp indent "}"))) |
---|
859 | |
---|
860 | (if (not (null? reactions)) |
---|
861 | (begin |
---|
862 | (pp indent ,nl (PROCEDURE reactions () "{")) |
---|
863 | (let ((locals (find-locals (map second reaction-eq-defs))) ) |
---|
864 | (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals)))) |
---|
865 | (for-each (lambda (def) |
---|
866 | (let ((n (nmodl-name (first def))) (b (second def))) |
---|
867 | (pp indent+ ,(expr->string/NMODL b n)))) |
---|
868 | reaction-eq-defs)) |
---|
869 | (pp indent "}"))) |
---|
870 | |
---|
871 | (if (not (null? pool-ions)) |
---|
872 | (begin |
---|
873 | (pp indent ,nl (PROCEDURE pools () "{")) |
---|
874 | (for-each (lambda (pool-ion) |
---|
875 | (pp indent+ (,(third pool-ion) = ,(first pool-ion)))) |
---|
876 | pool-ions) |
---|
877 | (pp indent "}"))) |
---|
878 | |
---|
879 | (pp indent ,nl (BREAKPOINT "{")) |
---|
880 | (let* ((i-eqs (filter-map |
---|
881 | (lambda (gate-complex) |
---|
882 | |
---|
883 | (let* ((label (first gate-complex)) |
---|
884 | (n (second gate-complex)) |
---|
885 | (subcomps ((dis 'component-subcomps) sys n)) |
---|
886 | (acc (lookup-def 'accumulating-substance subcomps)) |
---|
887 | (perm (lookup-def 'permeating-ion subcomps)) |
---|
888 | (permqs (and perm ((dis 'component-exports) sys (cid perm)))) |
---|
889 | (pore (lookup-def 'pore subcomps)) |
---|
890 | (permeability (lookup-def 'permeability subcomps)) |
---|
891 | (gate (lookup-def 'gate subcomps)) |
---|
892 | (sts (and gate ((dis 'component-exports) sys (cid gate))))) |
---|
893 | |
---|
894 | (if (and pore (null? permqs)) |
---|
895 | (nemo:error 'nemo:nmodl-translator: "ion channel definition " label |
---|
896 | "permeating-ion component lacks exported quantities")) |
---|
897 | |
---|
898 | (if (null? sts) |
---|
899 | (nemo:error 'nemo:nmodl-translator: "ion channel definition " label |
---|
900 | "gate component lacks exported quantities")) |
---|
901 | |
---|
902 | (if (not (or pore permeability)) |
---|
903 | (nemo:error 'nemo:nmodl-translator: "ion channel definition " label |
---|
904 | "lacks any pore or permeability components")) |
---|
905 | |
---|
906 | (cond ((and perm permeability gate) |
---|
907 | (let* ((i (nmodl-name (s+ 'i (cn perm)))) |
---|
908 | (pmax (car ((dis 'component-exports) sys (cid permeability)))) |
---|
909 | (pwrs (map (lambda (n) (rate/reaction-power sys n)) sts)) |
---|
910 | (sptms (map (lambda (st pwr) (if pwr `(pow ,st ,pwr) st)) sts pwrs)) |
---|
911 | (gion `(* ,pmax ,@sptms))) |
---|
912 | (list i #f gion (nmodl-name (s+ 'i_ label) )))) |
---|
913 | |
---|
914 | ((and perm pore gate) |
---|
915 | |
---|
916 | (case (cn perm) |
---|
917 | ((non-specific) |
---|
918 | (let* ((i (nmodl-name 'i)) |
---|
919 | (e (nmodl-name 'e)) |
---|
920 | (gmax (car ((dis 'component-exports) sys (cid pore)))) |
---|
921 | (pwrs (map (lambda (n) (rate/reaction-power sys n)) sts)) |
---|
922 | (sptms (map (lambda (st pwr) (if pwr `(pow ,st ,pwr) st)) sts pwrs)) |
---|
923 | (gion `(* ,gmax ,@sptms))) |
---|
924 | (list i e gion (nmodl-name (s+ 'i_ label) )))) |
---|
925 | |
---|
926 | (else |
---|
927 | (let* ((i (nmodl-name (s+ 'i (cn perm)))) |
---|
928 | (e (nmodl-name (s+ 'e (cn perm)))) |
---|
929 | (gmax (car ((dis 'component-exports) sys (cid pore)))) |
---|
930 | (pwrs (map (lambda (n) (rate/reaction-power sys n)) sts)) |
---|
931 | (sptms (map (lambda (st pwr) (if pwr `(pow ,st ,pwr) st)) sts pwrs)) |
---|
932 | (gion `(* ,gmax ,@sptms))) |
---|
933 | |
---|
934 | (list i e gion (nmodl-name (s+ 'i_ label))))))) |
---|
935 | |
---|
936 | ((and perm pore) |
---|
937 | (case (cn perm) |
---|
938 | ((non-specific) |
---|
939 | (let* ((i (nmodl-name 'i)) |
---|
940 | (e (nmodl-name (s+ 'e (cn perm)))) |
---|
941 | (gmax (car ((dis 'component-exports) sys (cid pore))))) |
---|
942 | (list i e gmax (nmodl-name (s+ 'i_ label))))) |
---|
943 | (else |
---|
944 | (nemo:error 'nemo:nmodl-translator: "ion channel definition " label |
---|
945 | (s+ "(" n ")") |
---|
946 | "lacks gate component")))) |
---|
947 | |
---|
948 | ((and acc pore gate) |
---|
949 | (let* ((i (nmodl-name (s+ 'i (cn acc)))) |
---|
950 | (gmax (car ((dis 'component-exports) sys (cid pore)))) |
---|
951 | (pwrs (map (lambda (n) (rate/reaction-power sys n)) sts)) |
---|
952 | (sptms (map (lambda (st pwr) (if pwr `(pow ,st ,pwr) st)) sts pwrs)) |
---|
953 | (gion `(* ,gmax ,@sptms))) |
---|
954 | (list i #f gion (nmodl-name (s+ 'i_ label) )))) |
---|
955 | |
---|
956 | (else (nemo:error 'nemo:nmodl-translator: "invalid ion channel definition " |
---|
957 | label)) |
---|
958 | ))) |
---|
959 | gate-complexes)) |
---|
960 | |
---|
961 | (i-eqs (fold (lambda (i-gate ax) |
---|
962 | (let ((i-gate-var (first i-gate))) |
---|
963 | (cons (list (nmodl-name 'i) #f i-gate-var (s+ 'i_ (second i-gate)) ) ax))) |
---|
964 | i-eqs i-gates)) |
---|
965 | |
---|
966 | (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs)) |
---|
967 | |
---|
968 | (i-eqs (fold (lambda (b ax) |
---|
969 | (match b |
---|
970 | ((and ps ((i e gion ii) . rst)) |
---|
971 | (let loop ((ps ps) (summands (list)) (eqs (list))) |
---|
972 | (if (null? ps) |
---|
973 | |
---|
974 | (let* ((sum0 (sum summands)) |
---|
975 | (sum1 (rhsexpr/NMODL sum0)) |
---|
976 | (sum2 (canonicalize-expr/NMODL sum1))) |
---|
977 | (append eqs (list (list i sum2)) ax)) |
---|
978 | |
---|
979 | (match-let (((i e gion ii) (car ps))) |
---|
980 | |
---|
981 | (loop (cdr ps) |
---|
982 | (cons ii summands) |
---|
983 | (let* ((expr0 (rhsexpr/NMODL (if e `(* ,gion (- v ,e)) gion))) |
---|
984 | (expr1 (canonicalize-expr/NMODL expr0))) |
---|
985 | (cons (list ii expr1) eqs))))))) |
---|
986 | |
---|
987 | ((i e gion ii) |
---|
988 | (let* ((expr0 (rhsexpr/NMODL (if e `(* ,gion (- v ,e)) gion))) |
---|
989 | (expr1 (canonicalize-expr/NMODL expr0))) |
---|
990 | (cons (list i expr1) ax))) |
---|
991 | |
---|
992 | (else ax))) |
---|
993 | (list) i-bkts)) |
---|
994 | |
---|
995 | (locals (find-locals (map second i-eqs)))) |
---|
996 | |
---|
997 | (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals)))) |
---|
998 | (if has-ode? |
---|
999 | (case method |
---|
1000 | ((#f expeuler) (pp indent+ (SOLVE states))) |
---|
1001 | (else (pp indent+ (SOLVE states METHOD ,method))))) |
---|
1002 | (if has-kinetic? (pp indent+ (SOLVE kstates METHOD sparse))) |
---|
1003 | (if (not (null? reactions)) (pp indent+ (reactions ()))) |
---|
1004 | (if (not (null? pool-ions)) (pp indent+ (pools ()))) |
---|
1005 | (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs) |
---|
1006 | (pp indent "}")) |
---|
1007 | |
---|
1008 | (if has-ode? |
---|
1009 | (let ((locals (find-locals (map second rate-eq-defs)))) |
---|
1010 | (case method |
---|
1011 | ((expeuler) (pp indent ,nl (PROCEDURE states () "{"))) |
---|
1012 | (else (pp indent ,nl (DERIVATIVE states "{")))) |
---|
1013 | (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals)))) |
---|
1014 | (if (not (null? asgns)) (pp indent+ (asgns ()))) |
---|
1015 | (let ((prime (case method |
---|
1016 | ((expeuler) identity) |
---|
1017 | (else (lambda (x) (s+ x "'")))))) |
---|
1018 | (for-each (lambda (def) |
---|
1019 | (let ((n (prime (first def))) |
---|
1020 | (b (second def))) |
---|
1021 | (pp indent+ ,(expr->string/NMODL b n)))) |
---|
1022 | rate-eq-defs)) |
---|
1023 | (pp indent "}"))) |
---|
1024 | |
---|
1025 | (if has-kinetic? |
---|
1026 | (begin |
---|
1027 | (pp indent ,nl (KINETIC kstates "{")) |
---|
1028 | (let* ((exprs (map second kstate-eq-defs)) |
---|
1029 | (locals (concatenate |
---|
1030 | (find-locals |
---|
1031 | (append (map (lambda (x) (map fourth x)) exprs) |
---|
1032 | (map (lambda (x) (map fifth x)) exprs)))))) |
---|
1033 | (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals)))) |
---|
1034 | (if (not (null? asgns)) (pp indent+ (asgns ()))) |
---|
1035 | (for-each |
---|
1036 | (lambda (def) |
---|
1037 | (let* ((n (first def)) |
---|
1038 | (eqs (second def)) |
---|
1039 | (conserve-eqs (lookup-def (nmodl-name n) conserve-eq-defs))) |
---|
1040 | (for-each |
---|
1041 | (lambda (eq) |
---|
1042 | (match eq |
---|
1043 | (('-> s0 s1 rexpr) |
---|
1044 | (pp indent+ (~ ,s0 -> ,s1 (,(expr->string/NMODL rexpr))))) |
---|
1045 | (('<-> s0 s1 rexpr1 rexpr2) |
---|
1046 | (pp indent+ (~ ,s0 <-> ,s1 (,(expr->string/NMODL rexpr1) #\, |
---|
1047 | ,(expr->string/NMODL rexpr2) |
---|
1048 | )))) |
---|
1049 | )) |
---|
1050 | eqs) |
---|
1051 | (if conserve-eqs |
---|
1052 | (for-each (lambda (eq) |
---|
1053 | (let ((val (first eq)) |
---|
1054 | (expr (third eq))) |
---|
1055 | (pp indent+ ,(conserve-conseq->string/NMODL expr val)))) |
---|
1056 | conserve-eqs)) |
---|
1057 | )) |
---|
1058 | kstate-eq-defs)) |
---|
1059 | (pp indent "}"))) |
---|
1060 | |
---|
1061 | |
---|
1062 | (let ((locals (find-locals (map second state-init-defs)))) |
---|
1063 | (pp indent ,nl (INITIAL "{")) |
---|
1064 | |
---|
1065 | (if (not (null? locals)) (pp indent+ (LOCAL ,(slp ", " locals)))) |
---|
1066 | (if (not (null? asgns)) (pp indent+ (asgns ()))) |
---|
1067 | (for-each (lambda (def) |
---|
1068 | (let ((n (first def)) (b (second def))) |
---|
1069 | (pp indent+ ,(expr->string/NMODL b n)))) state-init-defs) |
---|
1070 | (if has-kinetic? |
---|
1071 | (pp indent+ (SOLVE kstates STEADYSTATE sparse))) |
---|
1072 | |
---|
1073 | (for-each |
---|
1074 | (lambda (gate-complex) |
---|
1075 | |
---|
1076 | (let* ((label (first gate-complex)) |
---|
1077 | (n (second gate-complex)) |
---|
1078 | (subcomps ((dis 'component-subcomps) sys n)) |
---|
1079 | (perm (lookup-def 'permeating-ion subcomps)) |
---|
1080 | (permqs (and perm ((dis 'component-exports) sys (cid perm)))) |
---|
1081 | ) |
---|
1082 | |
---|
1083 | (if perm |
---|
1084 | |
---|
1085 | (case (cn perm) |
---|
1086 | ((non-specific) |
---|
1087 | (let* ((e (nmodl-name 'e)) |
---|
1088 | (elocal (car permqs))) |
---|
1089 | (if (not (equal? e elocal)) |
---|
1090 | (pp indent+ ,(expr->string/NMODL (nmodl-name elocal) e))))) |
---|
1091 | |
---|
1092 | (else |
---|
1093 | (let* ((e (nmodl-name (s+ 'e (cn perm)))) |
---|
1094 | (elocal (car permqs))) |
---|
1095 | (if (not (equal? e elocal)) |
---|
1096 | (pp indent+ ,(expr->string/NMODL (nmodl-name elocal) e))))))) |
---|
1097 | )) |
---|
1098 | gate-complexes) |
---|
1099 | |
---|
1100 | |
---|
1101 | (pp indent "}") |
---|
1102 | |
---|
1103 | (pp indent ,nl (PROCEDURE print_state () "{")) |
---|
1104 | |
---|
1105 | (let ((lst (sort (map (compose ->string first) rate-eq-defs) string<?))) |
---|
1106 | (for-each (lambda (x) |
---|
1107 | (pp indent+ (printf (,(s+ #\" "NMODL state: t = %g v = %g " x " = %g\\n" #\") ", t, v, " ,x )))) |
---|
1108 | lst)) |
---|
1109 | |
---|
1110 | (let ((lst (sort (map (compose ->string first) reaction-eq-defs) string<?))) |
---|
1111 | (for-each (lambda (x) |
---|
1112 | (pp indent+ (printf (,(s+ #\" "NMODL state: t = %g v = %g " x " = %g\\n" #\") ", t, v, " ,x )))) |
---|
1113 | lst)) |
---|
1114 | |
---|
1115 | (pp indent "}") |
---|
1116 | |
---|
1117 | )))))) |
---|
1118 | ) |
---|