1 | ;; |
---|
2 | ;; NEMO: a description language for models of neuronal ionic currents. |
---|
3 | ;; |
---|
4 | ;; Copyright 2008-2014 Ivan Raikov and the Okinawa Institute of |
---|
5 | ;; 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 | (import files setup-api srfi-1 srfi-4 srfi-13 srfi-69) |
---|
22 | |
---|
23 | |
---|
24 | (require-extension nemo-core nemo-macros nemo-hh nemo-vclamp nemo-iclamp |
---|
25 | nemo-utils nemo-units nemo-fetch) |
---|
26 | (require-library iexpr ersatz-lib) |
---|
27 | (require-extension datatype matchable lalr-driver |
---|
28 | ssax sxml-transforms sxpath sxpath-lolevel |
---|
29 | getopt-long) |
---|
30 | (import (prefix iexpr iexpr: ) |
---|
31 | (prefix ersatz-lib ersatz: ) |
---|
32 | ) |
---|
33 | |
---|
34 | (define user-template-list? |
---|
35 | (lambda (ts) |
---|
36 | (every (lambda (x) (and (string? (car x)) |
---|
37 | (every string? (cadr x)) |
---|
38 | (every ersatz:tstmt? (caddr x)))) ts))) |
---|
39 | |
---|
40 | |
---|
41 | (define-datatype nemo:model nemo:model? |
---|
42 | (ModelSource (source-path string?) (in-format symbol?) (name symbol?) |
---|
43 | (decls list?) |
---|
44 | (user-templates user-template-list?) |
---|
45 | (iexpr boolean?) (parse-expr procedure?)) |
---|
46 | (SingleModel (source-path string?) (in-format symbol?) (name symbol?) |
---|
47 | (sys hash-table?) (decls list?) (user-templates user-template-list?) |
---|
48 | (iexpr boolean?) (parse-expr procedure?)) |
---|
49 | (ModelPart (source-path string?) (in-format symbol?) (name symbol?) (part-name symbol?) |
---|
50 | (sys hash-table?) (decls list?) (parent-decls list?) |
---|
51 | (user-templates user-template-list?) |
---|
52 | (iexpr boolean?) (parse-expr procedure?)) |
---|
53 | ) |
---|
54 | |
---|
55 | |
---|
56 | (define nemo-nmodl? (extension-information 'nemo-nmodl)) |
---|
57 | (define nemo-matlab? (extension-information 'nemo-matlab)) |
---|
58 | (define nemo-nest? (extension-information 'nemo-nest)) |
---|
59 | (define nemo-pyparams? (extension-information 'nemo-pyparams)) |
---|
60 | |
---|
61 | (if nemo-nmodl? (use nemo-nmodl)) |
---|
62 | (if nemo-matlab? (use nemo-matlab)) |
---|
63 | (if nemo-nest? (use nemo-nest)) |
---|
64 | (if nemo-pyparams? (use nemo-pyparams)) |
---|
65 | |
---|
66 | (define (lookup-def k lst . rest) |
---|
67 | (let-optionals rest ((default #f)) |
---|
68 | (let ((kv (assoc k lst))) |
---|
69 | (if (not kv) default |
---|
70 | (match kv ((k v) v) (else (cdr kv))))))) |
---|
71 | |
---|
72 | (define ($ x) (and x (string->symbol (->string x)))) |
---|
73 | |
---|
74 | ;;; Procedures for string concatenation and pretty-printing |
---|
75 | |
---|
76 | (define (s+ . lst) (string-concatenate (map ->string lst))) |
---|
77 | (define (sw+ lst) (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " ")) |
---|
78 | (define (s\ p . lst) (string-intersperse (map ->string lst) p)) |
---|
79 | (define (slp p lst) (string-intersperse (map ->string lst) p)) |
---|
80 | (define nl "\n") |
---|
81 | |
---|
82 | |
---|
83 | (define (warn port message . specialising-msgs) |
---|
84 | (print-error-message message (current-output-port) "Warning") |
---|
85 | (print (string-concatenate (map ->string specialising-msgs)))) |
---|
86 | |
---|
87 | ;;; Error procedure for the XML parser |
---|
88 | |
---|
89 | (define (parser-error port message . specialising-msgs) |
---|
90 | (error (string-append message (string-concatenate (map ->string specialising-msgs))))) |
---|
91 | |
---|
92 | (define ssax:warn warn) |
---|
93 | |
---|
94 | (define opt-defaults |
---|
95 | `( |
---|
96 | (nmodl-kinetic . all) |
---|
97 | (nmodl-method . cnexp) |
---|
98 | )) |
---|
99 | |
---|
100 | (define (defopt x) |
---|
101 | (lookup-def x opt-defaults)) |
---|
102 | |
---|
103 | (define opt-grammar |
---|
104 | `( |
---|
105 | (input-format |
---|
106 | "specify input format (nemo, xml, ixml, sxml, s-exp)" |
---|
107 | (single-char #\i) |
---|
108 | (value (required FORMAT) |
---|
109 | (transformer ,string->symbol))) |
---|
110 | |
---|
111 | (partition |
---|
112 | "partition model source into individual parts for each current" |
---|
113 | (single-char #\p)) |
---|
114 | |
---|
115 | (surface-xml |
---|
116 | "write surface XML translation of input to file (default: <model-name>.xml)" |
---|
117 | (value (optional DIRNAME) |
---|
118 | )) |
---|
119 | |
---|
120 | (surface-nineml |
---|
121 | "write NineML-compatible translation of input to file (default: <model-name>.xml)" |
---|
122 | (value (optional DIRNAME) |
---|
123 | )) |
---|
124 | |
---|
125 | (plain |
---|
126 | "write plain text output to file (default: <model-name>.txt)" |
---|
127 | (value (optional DIRNAME) |
---|
128 | )) |
---|
129 | |
---|
130 | (xml |
---|
131 | "write XML output to file (default: <model-name>.xml)" |
---|
132 | (value (optional DIRNAME) |
---|
133 | )) |
---|
134 | |
---|
135 | (sxml |
---|
136 | "write SXML output to file (default: <model-name>.sxml)" |
---|
137 | (value (optional DIRNAME) |
---|
138 | )) |
---|
139 | |
---|
140 | (hh-markov |
---|
141 | "convert HH rate equations to Markov chain form") |
---|
142 | |
---|
143 | (print-default-units |
---|
144 | "print default units used for target platform") |
---|
145 | |
---|
146 | (default-units |
---|
147 | "set default units used for target platform" |
---|
148 | (value (required QUANTITY:UNIT) |
---|
149 | (transformer |
---|
150 | ,(lambda (x) |
---|
151 | (map (lambda (x) |
---|
152 | (match-let (((dimstr unitstr) (string-split x ":"))) |
---|
153 | (let ((dimsym (string->symbol dimstr)) |
---|
154 | (unitsym (string->symbol unitstr))) |
---|
155 | (let* ((alldims (map (lambda (x) |
---|
156 | (cons (nemo:quantity-name (car x)) (car x))) |
---|
157 | (nemo:default-units))) |
---|
158 | (dim (lookup-def dimsym alldims)) |
---|
159 | (u (lookup-def unitsym nemo:basic-units))) |
---|
160 | (if (not (and u (= (nemo:quantity-int (nemo:unit-dims u))) |
---|
161 | (nemo:quantity-int dim))) |
---|
162 | (error 'default-units "invalid unit for given quantity" |
---|
163 | unitsym dimsym) |
---|
164 | (cons dim u)))) |
---|
165 | )) |
---|
166 | (string-split x ",")))) |
---|
167 | ) |
---|
168 | ) |
---|
169 | |
---|
170 | ,@(if nemo-nest? |
---|
171 | `( |
---|
172 | (nest |
---|
173 | "write NEST output files <model-name>.cpp and <model-name>.h in the given directory (default: .)" |
---|
174 | (value (optional DIRNAME))) |
---|
175 | |
---|
176 | (nest-method |
---|
177 | "specify NEST integration method (gsl, cvode, ida)" |
---|
178 | (value (required METHOD) |
---|
179 | (transformer ,string->symbol))) |
---|
180 | |
---|
181 | (nest-ss-method |
---|
182 | "specify NEST steady state solving method (gsl, kinsol)" |
---|
183 | (value (required METHOD) |
---|
184 | (transformer ,string->symbol))) |
---|
185 | |
---|
186 | (nest-abstol |
---|
187 | "specify NEST absolute tolerance (default is 1e-7)" |
---|
188 | (value (required NUMBER) |
---|
189 | (transformer ,string->number))) |
---|
190 | |
---|
191 | (nest-reltol |
---|
192 | "specify NEST relative tolerance (default is 1e-7)" |
---|
193 | (value (required NUMBER) |
---|
194 | (transformer ,string->number))) |
---|
195 | |
---|
196 | (nest-maxstep |
---|
197 | "specify NEST maximum step size (default is provided by the NEST interpreter)" |
---|
198 | (value (required NUMBER) |
---|
199 | (transformer ,string->number))) |
---|
200 | ) |
---|
201 | `()) |
---|
202 | |
---|
203 | ,@(if nemo-pyparams? |
---|
204 | `( |
---|
205 | (pyparams |
---|
206 | "write Python representation of parameters to given file (default: <model-name>.py)" |
---|
207 | (value (optional DIRNAME))) |
---|
208 | ) |
---|
209 | `()) |
---|
210 | |
---|
211 | ,@(if nemo-matlab? |
---|
212 | `((matlab |
---|
213 | "write MATLAB output in the given directory (default: .)" |
---|
214 | (value (optional DIRNAME))) |
---|
215 | |
---|
216 | (octave |
---|
217 | "write Octave output to given file (default: <model-name>.m)" |
---|
218 | (value (optional DIRNAME))) |
---|
219 | |
---|
220 | (octave-method |
---|
221 | "specify Octave integration method (lsode, odepkg, or cvode)" |
---|
222 | (value (required METHOD) |
---|
223 | (transformer ,string->symbol))) |
---|
224 | ) |
---|
225 | `()) |
---|
226 | |
---|
227 | ,@(if nemo-nmodl? |
---|
228 | `( |
---|
229 | (nmodl "write NMODL output to file (default: <model-name>.mod)" |
---|
230 | (value (optional DIRNAME))) |
---|
231 | |
---|
232 | (nmodl-kinetic ,(s+ "use NMODL kinetic equations for the given reactions " |
---|
233 | "(or for all reactions)") |
---|
234 | (value (optional STATES) |
---|
235 | (default ,(defopt 'nmodl-kinetic)) |
---|
236 | (transformer |
---|
237 | ,(lambda (x) |
---|
238 | (if (string=? x "all") 'all |
---|
239 | (map string->symbol (string-split x ","))))))) |
---|
240 | |
---|
241 | (nmodl-method "specify NMODL integration method" |
---|
242 | (value (required METHOD) |
---|
243 | (transformer ,string->symbol))) |
---|
244 | ) |
---|
245 | `()) |
---|
246 | |
---|
247 | (vclamp-hoc |
---|
248 | "write voltage clamp scripts to HOC file (default: <model-name>.hoc)" |
---|
249 | (value (optional DIRNAME) |
---|
250 | )) |
---|
251 | |
---|
252 | (vclamp-octave |
---|
253 | "write voltage clamp script to Octave file (default: <model-name>_vclamp.m)" |
---|
254 | (value (optional DIRNAME) |
---|
255 | )) |
---|
256 | |
---|
257 | (iclamp-hoc |
---|
258 | "write current pulse injection scripts to HOC file (default: <model-name>.hoc)" |
---|
259 | (value (optional DIRNAME) |
---|
260 | )) |
---|
261 | |
---|
262 | (iclamp-nest |
---|
263 | "write current pulse injection script to NEST SLI file (default: <model-name>.sli)" |
---|
264 | (value (optional DIRNAME) |
---|
265 | )) |
---|
266 | |
---|
267 | (template |
---|
268 | "instantiate the given template from the model file by setting the given variables to the respective values" |
---|
269 | (value (required "NAME[:VAR=VAL...]")) |
---|
270 | (multiple #t) |
---|
271 | ) |
---|
272 | |
---|
273 | (template-prefix |
---|
274 | "output instantiated templates to <PREFIX><template_name> (default is <model-name>_<template_name>)" |
---|
275 | (value (required PREFIX) |
---|
276 | )) |
---|
277 | |
---|
278 | (dump-template-env "print the template environment used for code generation (only nmodl or nest backend)") |
---|
279 | |
---|
280 | (debug "print additional debugging information") |
---|
281 | |
---|
282 | (version "print the current version and exit") |
---|
283 | |
---|
284 | (help (single-char #\h)) |
---|
285 | |
---|
286 | |
---|
287 | )) |
---|
288 | |
---|
289 | |
---|
290 | ;; Use args:usage to generate a formatted list of options (from OPTS), |
---|
291 | ;; suitable for embedding into help text. |
---|
292 | (define (nemo:usage) |
---|
293 | (print "Usage: " (car (argv)) " <list of files to be processed> [options...] ") |
---|
294 | (newline) |
---|
295 | (print "The following options are recognized: ") |
---|
296 | (newline) |
---|
297 | (print (parameterize ((indent 5) (width 30)) (usage opt-grammar))) |
---|
298 | (exit 1)) |
---|
299 | |
---|
300 | |
---|
301 | ;; Process arguments and collate options and arguments into OPTIONS |
---|
302 | ;; alist, and operands (filenames) into OPERANDS. You can handle |
---|
303 | ;; options as they are processed, or afterwards. |
---|
304 | |
---|
305 | (define opts (getopt-long (command-line-arguments) opt-grammar)) |
---|
306 | (define opt (make-option-dispatch opts opt-grammar)) |
---|
307 | |
---|
308 | |
---|
309 | (define (nmlb:sxpath query doc) |
---|
310 | ((sxpath query '((nmlb . "http://www.nineml.org/Biophysics"))) doc)) |
---|
311 | |
---|
312 | (define (ncml:sxpath query doc) |
---|
313 | ((sxpath query '((ncml . "ncml"))) doc)) |
---|
314 | |
---|
315 | (define (ncml:car-sxpath query doc) |
---|
316 | (let ((lst ((sxpath query '((ncml . "ncml") )) doc))) |
---|
317 | (car lst))) |
---|
318 | |
---|
319 | (define (ncml:if-car-sxpath query doc) |
---|
320 | (let ((lst ((sxpath query '((ncml . "ncml") )) doc))) |
---|
321 | (and (not (null? lst)) (car lst)))) |
---|
322 | |
---|
323 | (define (ncml:if-sxpath query doc) |
---|
324 | (let ((lst ((sxpath query '((ncml . "ncml") )) doc))) |
---|
325 | (and (not (null? lst)) lst))) |
---|
326 | |
---|
327 | (define (ncml-binding->binding node) |
---|
328 | (match node |
---|
329 | (('ncml:bnd ('@ ('id id)) ('ncml:expr expr)) |
---|
330 | `(,($ id) ,(ncml-expr->expr expr))) |
---|
331 | (else (error 'ncml-binding->binding "invalid binding " node)))) |
---|
332 | |
---|
333 | (define (ncml-expr->expr node) |
---|
334 | (match node |
---|
335 | ((? number?) node) |
---|
336 | ((? string?) (sxml:number node)) |
---|
337 | (('ncml:id id) ($ id)) |
---|
338 | (('ncml:apply ('@ ('id id)) . args) (cons ($ id) (map ncml-expr->expr args))) |
---|
339 | (('ncml:let ('ncml:bnds . bnds) ('ncml:expr body)) |
---|
340 | `(let ,(map ncml-binding->binding bnds) ,(ncml-expr->expr body))) |
---|
341 | (((and op (? symbol?)) . args) |
---|
342 | (cons (ncml-op->op op) (map ncml-expr->expr args))) |
---|
343 | (else (error 'ncml-expr->expr "unknown expression " node)))) |
---|
344 | |
---|
345 | |
---|
346 | (define (ncml-op->op op) |
---|
347 | (case op |
---|
348 | ((ncml:sum) '+) |
---|
349 | ((ncml:sub) '-) |
---|
350 | ((ncml:mul) '*) |
---|
351 | ((ncml:div) '/) |
---|
352 | ((ncml:gt) '>) |
---|
353 | ((ncml:lt) '<) |
---|
354 | ((ncml:lte) '<=) |
---|
355 | ((ncml:gte) '>=) |
---|
356 | ((ncml:eq) '=) |
---|
357 | (else (match (string-split (->string op) ":") |
---|
358 | ((pre op) ($ op)) |
---|
359 | (else (error 'ncml-op->op "invalid operator" op)))))) |
---|
360 | |
---|
361 | |
---|
362 | (define (nemo-constructor name declarations parse-expr) |
---|
363 | (let* ((nemo (make-nemo-core)) |
---|
364 | (sys ((nemo 'system) name)) |
---|
365 | (qs (eval-nemo-system-decls nemo name sys declarations parse-expr: parse-expr))) |
---|
366 | (list sys nemo qs))) |
---|
367 | |
---|
368 | |
---|
369 | (define (sexp->model-decls doc) |
---|
370 | (match doc |
---|
371 | ((or ('nemo-model model-name model-decls) |
---|
372 | ('nemo-model (model-name . model-decls))) |
---|
373 | (list model-name model-decls)) |
---|
374 | ((or ('nemo-model model-name model-decls user-templates) |
---|
375 | ('nemo-model (model-name . model-decls) user-templates)) |
---|
376 | (list model-name model-decls |
---|
377 | (map (lambda (x) (list (->string (car x)) |
---|
378 | (map ->string (cadr x)) |
---|
379 | (ersatz:statements-from-string |
---|
380 | (ersatz:template-std-env) |
---|
381 | (caddr x)))) |
---|
382 | user-templates))) |
---|
383 | (else (error 'sexp->model "unknown model format")) |
---|
384 | )) |
---|
385 | |
---|
386 | |
---|
387 | (define (sexp-model-decls->model options model-name model-decls parse-expr) |
---|
388 | (let* ((model+nemo (nemo-constructor model-name model-decls parse-expr)) |
---|
389 | (model (first model+nemo)) |
---|
390 | (nemo (second model+nemo))) |
---|
391 | (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) parse-expr))) |
---|
392 | (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1))) |
---|
393 | (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1))) |
---|
394 | (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1))) |
---|
395 | (if (assoc 'components options) |
---|
396 | (for-each (lambda (x) |
---|
397 | (print "component " x ": " ((nemo 'component-exports) model-1 (second x))) |
---|
398 | (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x)))) |
---|
399 | ((nemo 'components) model-1))) |
---|
400 | model-1))) |
---|
401 | |
---|
402 | |
---|
403 | (define model->nmodl |
---|
404 | (if nemo-nmodl? |
---|
405 | (lambda (options model) |
---|
406 | (nemo:nmodl-translator model |
---|
407 | (lookup-def 'method options) |
---|
408 | (lookup-def 'kinetic options) |
---|
409 | (lookup-def 'dump-template-env options) )) |
---|
410 | (lambda (options model) |
---|
411 | (void)))) |
---|
412 | |
---|
413 | |
---|
414 | (define model->nest |
---|
415 | (if nemo-nest? |
---|
416 | (lambda (options model) |
---|
417 | (nemo:nest-translator model |
---|
418 | (lookup-def 'dirname options) |
---|
419 | (lookup-def 'method options) |
---|
420 | (lookup-def 'ss-method options) |
---|
421 | (lookup-def 'abstol options) |
---|
422 | (lookup-def 'reltol options) |
---|
423 | (lookup-def 'maxstep options) |
---|
424 | (lookup-def 'dump-template-env options) )) |
---|
425 | (lambda (options model) |
---|
426 | (void)))) |
---|
427 | |
---|
428 | (define model->pyparams |
---|
429 | (if nemo-pyparams? |
---|
430 | (lambda (options model) |
---|
431 | (nemo:pyparams-translator (list model) |
---|
432 | (lookup-def 'mode options) |
---|
433 | (lookup-def 'filename options))) |
---|
434 | (lambda (options model) |
---|
435 | (void)))) |
---|
436 | |
---|
437 | |
---|
438 | (define model->matlab |
---|
439 | (if nemo-matlab? |
---|
440 | (lambda (options model) |
---|
441 | (nemo:matlab-translator model #f (lookup-def 'dirname options))) |
---|
442 | (lambda (options model) |
---|
443 | (void)))) |
---|
444 | |
---|
445 | |
---|
446 | (define model->vclamp-hoc |
---|
447 | (lambda (options model) |
---|
448 | (nemo:vclamp-translator model 'hoc (lookup-def 'filename options)))) |
---|
449 | |
---|
450 | |
---|
451 | (define model->vclamp-octave |
---|
452 | (lambda (options model) |
---|
453 | (nemo:vclamp-translator model 'matlab |
---|
454 | (lookup-def 'filename options) |
---|
455 | (lookup-def 'octave-method options)))) |
---|
456 | |
---|
457 | |
---|
458 | (define model->iclamp-hoc |
---|
459 | (lambda (options model) |
---|
460 | (nemo:iclamp-translator model 'hoc (lookup-def 'filename options)))) |
---|
461 | |
---|
462 | (define model->iclamp-nest |
---|
463 | (lambda (options model) |
---|
464 | (nemo:iclamp-translator model 'nest (lookup-def 'filename options)))) |
---|
465 | |
---|
466 | |
---|
467 | (define model->octave |
---|
468 | (if nemo-matlab? |
---|
469 | (lambda (options model) |
---|
470 | (nemo:octave-translator model |
---|
471 | (lookup-def 'filename options) |
---|
472 | (lookup-def 'dirname options))) |
---|
473 | (lambda (options model) |
---|
474 | (void)))) |
---|
475 | |
---|
476 | |
---|
477 | (define (transition->ncml-transition x) |
---|
478 | (match x |
---|
479 | (('-> src dst rate) |
---|
480 | `((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate))))) |
---|
481 | ((src '-> dst rate) |
---|
482 | `((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate))))) |
---|
483 | (('<-> src dst rate1 rate2) |
---|
484 | `((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate1))) |
---|
485 | (ncml:transition (@ (src ,dst) (dst ,src)) (ncml:rate ,(expr->ncml-expr rate2))))) |
---|
486 | ((src '<-> dst rate1 rate2) |
---|
487 | `((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate1))) |
---|
488 | (ncml:transition (@ (src ,dst) (dst ,src)) (ncml:rate ,(expr->ncml-expr rate2))))) |
---|
489 | (else (error 'transition->ncml-transition "invalid transition " x)))) |
---|
490 | |
---|
491 | |
---|
492 | (define (conseq->ncml-conseq parse-expr) |
---|
493 | (lambda (x) |
---|
494 | (match x |
---|
495 | (((and i (? integer?)) '= rhs) |
---|
496 | `(ncml:conseq (@ (val ,(->string i))) |
---|
497 | (ncml:expr ,(expr->ncml-expr (parse-expr rhs))))) |
---|
498 | (else (error 'conseq->ncml-conseq "invalid linear equation " x))))) |
---|
499 | |
---|
500 | |
---|
501 | (define builtin-fns |
---|
502 | `(+ - * / pow neg abs atan asin acos sin cos exp ln |
---|
503 | sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube |
---|
504 | > < <= >= = and or round ceiling floor max min)) |
---|
505 | |
---|
506 | |
---|
507 | (define (binding->ncml-binding bnd) |
---|
508 | (match bnd |
---|
509 | ((id expr) `(ncml:bnd (@ (id ,id)) (ncml:expr ,(expr->ncml-expr expr)))) |
---|
510 | (else (error 'binding->ncml-binding "invalid binding " bnd)))) |
---|
511 | |
---|
512 | |
---|
513 | (define (expr->ncml-expr x) |
---|
514 | (match x |
---|
515 | ((? number?) x) |
---|
516 | |
---|
517 | ((? symbol?) `(ncml:id ,x)) |
---|
518 | |
---|
519 | (('let bnds expr) |
---|
520 | `(ncml:let (ncml:bnds . ,(map binding->ncml-binding bnds)) |
---|
521 | (ncml:expr ,(expr->ncml-expr expr)))) |
---|
522 | |
---|
523 | (((and op (? symbol?)) . args) |
---|
524 | (let ((ncml-expr (if (member op builtin-fns) |
---|
525 | (cons (op->ncml-op op) (map expr->ncml-expr args)) |
---|
526 | `(ncml:apply (@ (id ,op)) ,@(map expr->ncml-expr args))))) |
---|
527 | ncml-expr)) |
---|
528 | |
---|
529 | (else (error 'expr->ncml-expr "unknown expression " x)))) |
---|
530 | |
---|
531 | |
---|
532 | |
---|
533 | (define (op->ncml-op op) |
---|
534 | (case op |
---|
535 | ((+) 'ncml:sum) |
---|
536 | ((-) 'ncml:sub) |
---|
537 | ((*) 'ncml:mul) |
---|
538 | ((/) 'ncml:div) |
---|
539 | ((>) 'ncml:gt) |
---|
540 | ((<) 'ncml:lt) |
---|
541 | ((<=) 'ncml:lte) |
---|
542 | ((>=) 'ncml:gte) |
---|
543 | ((=) 'ncml:eq) |
---|
544 | (else ($ (string-append "ncml:" (->string op)))))) |
---|
545 | |
---|
546 | |
---|
547 | |
---|
548 | (define (declaration->ncml parse-expr) |
---|
549 | (lambda (x) |
---|
550 | |
---|
551 | (match x |
---|
552 | (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?))) |
---|
553 | `(ncml:label (@ (id ,(->string id))) ,v)) |
---|
554 | |
---|
555 | (((or 'input 'INPUT) . lst) |
---|
556 | (map (lambda (x) |
---|
557 | (match x |
---|
558 | ((? symbol?) |
---|
559 | `(ncml:input (@ (name ,(->string x))))) |
---|
560 | ((id1 (or 'as 'AS) x1) |
---|
561 | `(ncml:input (@ (name ,(->string id1)) (as ,(->string x1))))) |
---|
562 | ((id1 (or 'from 'FROM) n1) |
---|
563 | `(ncml:input (@ (name ,(->string id1)) (from ,(->string n1))))) |
---|
564 | ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1) |
---|
565 | `(ncml:input (@ (name ,(->string id1)) |
---|
566 | (as ,(->string x1)) (from ,(->string n1))))))) |
---|
567 | lst)) |
---|
568 | |
---|
569 | |
---|
570 | (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x))))) |
---|
571 | (map (lambda (x) `(ncml:output (@ (name ,(->string x))))) lst)) |
---|
572 | |
---|
573 | |
---|
574 | (((or 'const 'CONST) (and id (? symbol?)) '= expr) |
---|
575 | `(ncml:const (@ (name ,(->string id))) (ncml:expr ,(expr->ncml-expr (parse-expr expr))))) |
---|
576 | |
---|
577 | |
---|
578 | (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) ) |
---|
579 | (let ((trs (lookup-def 'transitions alst)) |
---|
580 | (initial (lookup-def 'initial alst)) |
---|
581 | (open (lookup-def 'open alst)) |
---|
582 | (cons (lookup-def 'conserve alst)) |
---|
583 | (p (lookup-def 'power alst))) |
---|
584 | (let ((sxml-trs (append-map transition->ncml-transition trs))) |
---|
585 | `(ncml:reaction (@ (id ,(->string id))) |
---|
586 | (ncml:open ,(if (list? open) |
---|
587 | (string-concatenate (intersperse (map ->string open) ",")) |
---|
588 | open)) |
---|
589 | ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) ) |
---|
590 | ,(and cons `(ncml:conserve ,((conseq->ncml-conseq parse-expr) cons)) ) |
---|
591 | (ncml:transitions ,@sxml-trs) |
---|
592 | (ncml:power ,(expr->ncml-expr (parse-expr p))))))) |
---|
593 | |
---|
594 | (((or 't 'T 'transient) ((and id (? symbol?))) '= (and expr (? nemo:expr?) ) . rest) |
---|
595 | (let ((trs (lookup-def 'transitions rest)) |
---|
596 | (initial (lookup-def 'initial rest)) |
---|
597 | (asgn (lookup-def 'onevent rest)) |
---|
598 | (p (lookup-def 'power rest)) |
---|
599 | ) |
---|
600 | `(ncml:transient (@ (id ,(->string id))) |
---|
601 | (ncml:expr ,(expr->ncml-expr (parse-expr expr))) |
---|
602 | (ncml:onevent ,(expr->ncml-expr (parse-expr asgn))) |
---|
603 | ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) ) |
---|
604 | ,(and p `(ncml:power ,(expr->ncml-expr (parse-expr p)))) |
---|
605 | )) |
---|
606 | ) |
---|
607 | |
---|
608 | (((or 'd 'D) ((and id (? symbol?))) '= expr . rest) |
---|
609 | (let ((initial (lookup-def 'initial rest))) |
---|
610 | `(ncml:rate (@ (name ,(->string id)) ) |
---|
611 | ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial)))) |
---|
612 | (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))) |
---|
613 | |
---|
614 | |
---|
615 | (((and id (? symbol?)) '= expr . rest) |
---|
616 | `(ncml:asgn (@ (name ,id)) (ncml:expr ,(expr->ncml-expr (parse-expr expr))))) |
---|
617 | |
---|
618 | (((or 'defun 'DEFUN 'fun 'FUN 'rel 'REL) (and id (? symbol?)) |
---|
619 | (and idlist (? (lambda (x) (every symbol? x)))) expr) |
---|
620 | `(ncml:defun (@ (id ,x)) |
---|
621 | ,@(map (lambda (v) `(ncml:arg ,(->string v))) idlist) |
---|
622 | (ncml:body ,(expr->ncml-expr (parse-expr expr))))) |
---|
623 | |
---|
624 | (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) ((or 'name 'NAME) name) . lst) |
---|
625 | `(ncml:component (@ (name ,(->string name)) (type ,(->string typ))) |
---|
626 | ,@(map (declaration->ncml parse-expr) lst))) |
---|
627 | |
---|
628 | (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) . lst) |
---|
629 | `(ncml:component (@ (type ,(->string typ))) |
---|
630 | ,@(map (declaration->ncml parse-expr) lst))) |
---|
631 | |
---|
632 | (((or 'component 'COMPONENT) ((or 'name 'NAME) name) '= |
---|
633 | (and functor-name (? symbol?)) (and args (? list?))) |
---|
634 | `(ncml:component (@ (name ,(->string name)) |
---|
635 | (functor-name ,(->string functor-name))) |
---|
636 | ,@(map (declaration->ncml parse-expr) lst))) |
---|
637 | |
---|
638 | (else (error 'declarations->ncml "unknown declaration " x)) |
---|
639 | |
---|
640 | ))) |
---|
641 | |
---|
642 | |
---|
643 | (define (make-component->ncml dis model parse-expr) |
---|
644 | (lambda (x) |
---|
645 | (let ((en (hash-table-ref model x))) |
---|
646 | (cond ((procedure? en) |
---|
647 | (let ((fd (procedure-data en))) |
---|
648 | `(ncml:defun (@ (id ,x)) |
---|
649 | ,@(map (lambda (v) `(ncml:arg ,v)) (lookup-def 'vars fd)) |
---|
650 | (ncml:body ,(expr->ncml-expr (lookup-def 'body fd)))))) |
---|
651 | (else |
---|
652 | (match en |
---|
653 | (($ nemo:quantity 'LABEL v) |
---|
654 | `(ncml:label (@ (id ,name)) ,v)) |
---|
655 | |
---|
656 | (($ nemo:quantity 'EXTERNAL local-name name namespace u) |
---|
657 | (if namespace |
---|
658 | `(ncml:input (@ (name ,name)) (as ,local-name) (from ,namespace)) |
---|
659 | `(ncml:input (@ (name ,name)) (as ,local-name)))) |
---|
660 | |
---|
661 | (($ nemo:quantity 'CONST name value) |
---|
662 | `(ncml:const (@ (name ,name)) (ncml:expr ,value))) |
---|
663 | |
---|
664 | (($ nemo:quantity 'ASGN name value rhs) |
---|
665 | (let ((expr (expr->ncml-expr rhs))) |
---|
666 | `(ncml:asgn (@ (name ,name)) (ncml:expr ,expr)))) |
---|
667 | |
---|
668 | (($ nemo:quantity 'RATE name initial rhs power u) |
---|
669 | (let ((expr (expr->ncml-expr rhs)) |
---|
670 | (initial (and initial (expr->ncml-expr initial)))) |
---|
671 | |
---|
672 | `(ncml:rate (@ (name ,name)) |
---|
673 | ,(and initial `(ncml:initial ,initial)) |
---|
674 | (ncml:expr ,expr) |
---|
675 | (ncml:power ,(or (and power (expr->ncml-expr power)) |
---|
676 | (expr->ncml-expr 1.0))) |
---|
677 | ))) |
---|
678 | |
---|
679 | (($ nemo:quantity 'TRANSIENT name initial rhs asgn power u) |
---|
680 | (let ((expr (expr->ncml-expr rhs)) |
---|
681 | (asgn (expr->ncml-expr asgn)) |
---|
682 | (initial (and initial (expr->ncml-expr initial)))) |
---|
683 | |
---|
684 | `(ncml:transient (@ (id ,name)) |
---|
685 | ,(and initial `(ncml:initial ,initial)) |
---|
686 | (ncml:expr ,expr) |
---|
687 | (ncml:onevent ,asgn) |
---|
688 | (ncml:power ,(or (and power (expr->ncml-expr power)) |
---|
689 | (expr->ncml-expr 1.0))) |
---|
690 | ))) |
---|
691 | |
---|
692 | (($ nemo:quantity 'REACTION name initial open trs cons p u) |
---|
693 | (let ((sxml-trs (append-map transition->ncml-transition trs))) |
---|
694 | `(ncml:reaction (@ (id ,name)) |
---|
695 | (ncml:open ,(if (list? open) |
---|
696 | (string-concatenate (intersperse (map ->string open) ",")) |
---|
697 | open)) |
---|
698 | ,(and initial `(ncml:initial ,(expr->ncml-expr initial))) |
---|
699 | ,(and cons `(ncml:conserve ,(map (conseq->ncml-conseq identity) cons)) ) |
---|
700 | (ncml:transitions ,@sxml-trs) |
---|
701 | (ncml:power ,(expr->ncml-expr p))))) |
---|
702 | |
---|
703 | (($ nemo:quantity 'COMPONENT name type lst) |
---|
704 | (let ((component->ncml (make-component->ncml dis model parse-expr)) |
---|
705 | (component-exports ((dis 'component-exports) model x))) |
---|
706 | (case type |
---|
707 | ((toplevel) `(,@(map component->ncml lst) |
---|
708 | ,@(map (lambda (x) `(ncml:output (@ (name ,x)))) component-exports))) |
---|
709 | (else `(ncml:component (@ (name ,name) (type ,type)) |
---|
710 | ,@(filter-map component->ncml lst) |
---|
711 | ,@(map (lambda (x) `(ncml:output (@ (name ,x)))) component-exports) |
---|
712 | ))))) |
---|
713 | |
---|
714 | (($ nemo:quantity 'FUNCTOR name args type lst) |
---|
715 | (let ((component->ncml (make-component->ncml dis model parse-expr))) |
---|
716 | `(ncml:functor (@ (name ,name) (type ,type) |
---|
717 | (parameters ,(string-intersperse (map ->string args) ","))) |
---|
718 | ,@(filter-map (declaration->ncml parse-expr) lst) |
---|
719 | ))) |
---|
720 | |
---|
721 | (else #f))))))) |
---|
722 | |
---|
723 | |
---|
724 | (define (model->ncml model parse-expr) |
---|
725 | (match-let ((($ nemo:quantity 'DISPATCH dis) |
---|
726 | (hash-table-ref model (nemo-intern 'dispatch)))) |
---|
727 | (let ((sysname ((dis 'sysname) model)) |
---|
728 | (component->ncml (make-component->ncml dis model parse-expr))) |
---|
729 | `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel)))))) |
---|
730 | |
---|
731 | |
---|
732 | (define (transition->text-transition x) |
---|
733 | (match x |
---|
734 | (('-> src dst rate) |
---|
735 | `(-> ,src ,dst ,(expr->text-expr rate) )) |
---|
736 | ((src '-> dst rate) |
---|
737 | `(-> ,src ,dst ,(expr->text-expr rate) )) |
---|
738 | (('<-> src dst rate1 rate2) |
---|
739 | `(<-> ,src ,dst ,(expr->text-expr rate) )) |
---|
740 | (('src <-> dst rate1 rate2) |
---|
741 | `(<-> ,src ,dst ,(expr->text-expr rate) )) |
---|
742 | (else (error 'transition->text-transition "invalid transition " x)))) |
---|
743 | |
---|
744 | |
---|
745 | (define (conseq->text-conseq parse-expr) |
---|
746 | (lambda (x) |
---|
747 | (match x |
---|
748 | (((and i (? integer?)) '= rhs) |
---|
749 | `(,(->string i) = |
---|
750 | ,(expr->text-expr (parse-expr rhs)))) |
---|
751 | (else (error 'conseq->text-conseq "invalid linear equation " x))))) |
---|
752 | |
---|
753 | |
---|
754 | (define (binding->text-binding bnd) |
---|
755 | (match bnd |
---|
756 | ((id expr) `(,id = ,(expr->text-expr expr))) |
---|
757 | (else (error 'binding->text-binding "invalid binding " bnd)))) |
---|
758 | |
---|
759 | |
---|
760 | (define (expr->text-expr x) |
---|
761 | (match x |
---|
762 | ((? number?) x) |
---|
763 | ((? symbol?) x) |
---|
764 | (('let bnds expr) |
---|
765 | `(let (,(map binding->text-binding bnds)) |
---|
766 | ,(expr->text-expr expr))) |
---|
767 | (((and op (? symbol?)) . args) |
---|
768 | (let ((ncml-expr `(apply ,op ,@(map expr->text-expr args)))) |
---|
769 | ncml-expr)) |
---|
770 | (else (error 'expr->text-expr "unknown expression " x)))) |
---|
771 | |
---|
772 | |
---|
773 | (define (make-component->text dis model parse-expr) |
---|
774 | (lambda (x) |
---|
775 | (let ((en (hash-table-ref model x))) |
---|
776 | (cond ((procedure? en) |
---|
777 | (let ((fd (procedure-data en))) |
---|
778 | `(function ,x |
---|
779 | ,(lookup-def 'vars fd) = |
---|
780 | ,(expr->text-expr (lookup-def 'body fd))) |
---|
781 | )) |
---|
782 | (else |
---|
783 | (match en |
---|
784 | (($ nemo:quantity 'LABEL v) |
---|
785 | `(label ,name = ,v)) |
---|
786 | |
---|
787 | (($ nemo:quantity 'EXTERNAL local-name name namespace u) |
---|
788 | (if namespace |
---|
789 | `(input ,name as ,local-name from ,namespace) |
---|
790 | `(input ,name as ,local-name))) |
---|
791 | |
---|
792 | (($ nemo:quantity 'CONST name value) |
---|
793 | `(const ,name = ,value)) |
---|
794 | |
---|
795 | (($ nemo:quantity 'ASGN name value rhs) |
---|
796 | (let ((expr (expr->text-expr rhs))) |
---|
797 | `(,name = ,expr))) |
---|
798 | |
---|
799 | (($ nemo:quantity 'RATE name initial rhs power u) |
---|
800 | (let ((expr (expr->ncml-expr rhs)) |
---|
801 | (initial (and initial (expr->text-expr initial))) |
---|
802 | (power (or (and power (expr->text-expr power)) |
---|
803 | (expr->text-expr 1.0)))) |
---|
804 | |
---|
805 | `(d (,name) = (,expr) |
---|
806 | (initial: ,initial) |
---|
807 | (power: ,power)) |
---|
808 | )) |
---|
809 | |
---|
810 | |
---|
811 | (($ nemo:quantity 'REACTION name initial open trs cons p u) |
---|
812 | (let ((sxml-trs (append-map transition->text-transition trs))) |
---|
813 | `(reaction ,name |
---|
814 | (open-state: ,open) |
---|
815 | (initial: ,(expr->text-expr initial)) |
---|
816 | (conserve: ,(map (conseq->text-conseq identity) cons)) |
---|
817 | (transitions: ,text-trs) |
---|
818 | (power: ,(expr->ncml-expr p)) |
---|
819 | ))) |
---|
820 | |
---|
821 | |
---|
822 | (($ nemo:quantity 'COMPONENT name type lst) |
---|
823 | (let ((component->text (make-component->text dis model parse-expr)) |
---|
824 | (component-exports ((dis 'component-exports) model x))) |
---|
825 | (case type |
---|
826 | ((toplevel) `(,@(map component->text lst) |
---|
827 | ,@(map (lambda (x) `(output ,x)) component-exports))) |
---|
828 | (else `(component ,name (type: ,(->string type) ) |
---|
829 | ,@(filter-map component->text lst) |
---|
830 | ,@(map (lambda (x) `(output ,x)) component-exports) |
---|
831 | ))))) |
---|
832 | |
---|
833 | (($ nemo:quantity 'FUNCTOR name args type lst) |
---|
834 | (let ((component->ncml (make-component->ncml dis model parse-expr))) |
---|
835 | `(functor ,name (type: ,(->string type) ) |
---|
836 | (parameters: ,(string-intersperse (map ->string args) ",")) |
---|
837 | ,@(filter-map (declaration->ncml parse-expr) lst) |
---|
838 | ))) |
---|
839 | |
---|
840 | (else #f))) |
---|
841 | )) |
---|
842 | )) |
---|
843 | |
---|
844 | |
---|
845 | (define (model->text model parse-expr) |
---|
846 | (match-let ((($ nemo:quantity 'DISPATCH dis) |
---|
847 | (hash-table-ref model (nemo-intern 'dispatch)))) |
---|
848 | (let ((sysname ((dis 'sysname) model)) |
---|
849 | (component->text (make-component->text dis model parse-expr))) |
---|
850 | `(model ,sysname ,@(component->text (nemo-intern 'toplevel))) |
---|
851 | ))) |
---|
852 | |
---|
853 | |
---|
854 | (include "expr-parser.scm") |
---|
855 | (include "SXML.scm") |
---|
856 | (include "SXML-to-XML.scm") |
---|
857 | (include "stx-engine.scm") |
---|
858 | |
---|
859 | |
---|
860 | |
---|
861 | (define (ensure-xmlns doc) |
---|
862 | (let ((doc1 (sxml:add-attr doc '(xmlns:ncml "ncml")))) |
---|
863 | (sxml:add-attr doc1 '(xmlns ncml)))) |
---|
864 | |
---|
865 | |
---|
866 | ;; based on SRV:send-reply by Oleg Kiselyov |
---|
867 | (define (print-fragments b) |
---|
868 | (let loop ((fragments b) (result #f)) |
---|
869 | (cond |
---|
870 | ((null? fragments) result) |
---|
871 | ((not (car fragments)) (loop (cdr fragments) result)) |
---|
872 | ((null? (car fragments)) (loop (cdr fragments) result)) |
---|
873 | ((eq? #t (car fragments)) (loop (cdr fragments) #t)) |
---|
874 | ((pair? (car fragments)) |
---|
875 | (loop (cdr fragments) (loop (car fragments) result))) |
---|
876 | ((procedure? (car fragments)) |
---|
877 | ((car fragments)) |
---|
878 | (loop (cdr fragments) #t)) |
---|
879 | (else |
---|
880 | (display (car fragments)) |
---|
881 | (loop (cdr fragments) #t))))) |
---|
882 | |
---|
883 | |
---|
884 | (define (ncml->declarations ncml:model parse-expr) |
---|
885 | (letrec |
---|
886 | ((label-template |
---|
887 | (sxml:match 'ncml:label |
---|
888 | (lambda (node bindings root env) |
---|
889 | (let ((id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
890 | (v (or (sxml:attr node 'value) |
---|
891 | (sxml:text node))) |
---|
892 | ) |
---|
893 | (if (not id) (error 'output-template "label declaration requires id attribute")) |
---|
894 | `(label ,($ id) = ,($ v)) |
---|
895 | )) |
---|
896 | )) |
---|
897 | |
---|
898 | (input-template |
---|
899 | (sxml:match 'ncml:input |
---|
900 | (lambda (node bindings root env) |
---|
901 | (let ((id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
902 | (from (sxml:attr node 'from)) |
---|
903 | (as (sxml:attr node 'as)) |
---|
904 | (unit (sxml:attr node 'unit)) |
---|
905 | ) |
---|
906 | (if (not id) (error 'input-template "input declaration requires id attribute")) |
---|
907 | (cond ((and from as unit) |
---|
908 | `(input (,($ id) as ,($ as ) from ,($ from) (unit ,($ unit))))) |
---|
909 | ((and from as) |
---|
910 | `(input (,($ id) as ,($ as ) from ,($ from) ))) |
---|
911 | ((and from unit) |
---|
912 | `(input (,($ id) from ,($ from) (unit ,($ unit))))) |
---|
913 | (from |
---|
914 | `(input (,($ id) from ,($ from)))) |
---|
915 | (as |
---|
916 | `(input (,($ id) as ,($ as)))) |
---|
917 | ((and as unit) |
---|
918 | `(input (,($ id) as ,($ as) (unit ,($ unit))))) |
---|
919 | (else |
---|
920 | `(input ,($ id)))) |
---|
921 | )) |
---|
922 | )) |
---|
923 | |
---|
924 | (output-template |
---|
925 | (sxml:match 'ncml:output |
---|
926 | (lambda (node bindings root env) |
---|
927 | (let ((id (or (sxml:attr node 'id) |
---|
928 | (sxml:attr node 'name)))) |
---|
929 | (if (not id) (error 'output-template "output declaration requires id attribute")) |
---|
930 | `(output ,($ id)) |
---|
931 | )) |
---|
932 | )) |
---|
933 | |
---|
934 | (const-template |
---|
935 | (sxml:match 'ncml:const |
---|
936 | (lambda (node bindings root env) |
---|
937 | (let* ((unit (sxml:attr node 'unit)) |
---|
938 | (id (or (sxml:attr node 'id) |
---|
939 | (sxml:attr node 'name))) |
---|
940 | (expr ((lambda (x) |
---|
941 | (if (not x) |
---|
942 | (error 'const-template "const declaration " id " requires expr element") |
---|
943 | (parse-expr (second x) id))) |
---|
944 | (or (sxml:kidn* 'ncml:expr node) |
---|
945 | (let ((vattr (sxml:attr node 'value))) |
---|
946 | (and vattr (list 'value vattr ))) |
---|
947 | (list 'value (sxml:text node)) |
---|
948 | ) |
---|
949 | ))) |
---|
950 | (if (not id) (error 'const-template "const declaration requires id attribute")) |
---|
951 | (if unit |
---|
952 | `(const ,($ id) = ,expr (unit ,($ unit))) |
---|
953 | `(const ,($ id) = ,expr) |
---|
954 | ) |
---|
955 | )) |
---|
956 | )) |
---|
957 | |
---|
958 | (reaction-transition-template |
---|
959 | (sxml:match 'ncml:transition |
---|
960 | (lambda (node bindings root env) |
---|
961 | (let ( |
---|
962 | (src (sxml:attr node 'src)) |
---|
963 | (dst (sxml:attr node 'dst)) |
---|
964 | (rate ((lambda (x) |
---|
965 | (if (not x) |
---|
966 | (error 'reaction-transition-template |
---|
967 | "reaction transition requires rate element") |
---|
968 | (parse-expr (second x)))) |
---|
969 | (sxml:kidn* 'ncml:rate node)))) |
---|
970 | (if (not src) (error 'reaction-transition-template |
---|
971 | "reaction transition requires src attribute")) |
---|
972 | (if (not dst) (error 'reaction-transition-template |
---|
973 | "reaction transition requires dst attribute")) |
---|
974 | |
---|
975 | `(-> ,($ src) ,($ dst) ,rate))) |
---|
976 | )) |
---|
977 | |
---|
978 | (asgn-template |
---|
979 | (sxml:match 'ncml:asgn |
---|
980 | (lambda (node bindings root env) |
---|
981 | (let* ((unit (sxml:attr node 'unit)) |
---|
982 | (id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
983 | (expr ((lambda (x) |
---|
984 | (if (not x) |
---|
985 | (error 'asgn-template "algebraic assignment requires expr element") |
---|
986 | (parse-expr (second x) id))) |
---|
987 | (or (sxml:kidn* 'ncml:expr node) |
---|
988 | (list 'expr (sxml:text node)) |
---|
989 | )) |
---|
990 | ) |
---|
991 | ) |
---|
992 | (if (not id) (error 'asgn-template "algebraic assignment requires id attribute")) |
---|
993 | (if unit |
---|
994 | `(,($ id) = ,expr) |
---|
995 | `(,($ id) = ,expr (unit ,($ unit)))) |
---|
996 | )) |
---|
997 | )) |
---|
998 | |
---|
999 | (rate-template |
---|
1000 | (sxml:match 'ncml:rate |
---|
1001 | (lambda (node bindings root env) |
---|
1002 | (let* ((unit (sxml:attr node 'unit)) |
---|
1003 | (id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
1004 | (rhs ((lambda (x) |
---|
1005 | (if (not x) |
---|
1006 | (error 'rate-template "rate equation requires expr element") |
---|
1007 | (parse-expr (second x) id))) |
---|
1008 | (sxml:kidn* 'ncml:expr node))) |
---|
1009 | (initial ((lambda (x) (and x (parse-expr (second x) id))) |
---|
1010 | (sxml:kidn* 'ncml:initial node))) |
---|
1011 | (power ((lambda (x) (and x (parse-expr (second x) id))) |
---|
1012 | (sxml:kidn* 'ncml:power node))) |
---|
1013 | ) |
---|
1014 | (if (not id) (error 'rate-template "rate equation requires id attribute")) |
---|
1015 | (cond |
---|
1016 | ((and power initial unit) |
---|
1017 | `(d (,($ id)) = ,rhs (initial ,initial) (power ,power) (unit ,($ unit)))) |
---|
1018 | ((and power initial) |
---|
1019 | `(d (,($ id)) = ,rhs (initial ,initial) (power ,power))) |
---|
1020 | ((and power unit) |
---|
1021 | `(d (,($ id)) = ,rhs (power ,power) (unit ,($ unit)))) |
---|
1022 | ((and initial unit) |
---|
1023 | `(d (,($ id)) = ,rhs (initial ,initial) (unit ,($ unit)))) |
---|
1024 | (initial |
---|
1025 | `(d (,($ id)) = ,rhs (initial ,initial))) |
---|
1026 | (power |
---|
1027 | `(d (,($ id)) = ,rhs (power ,power))) |
---|
1028 | (unit |
---|
1029 | `(d (,($ id)) = ,rhs (unit ,($ unit)))) |
---|
1030 | (else |
---|
1031 | `(d (,($ id)) = ,rhs)) |
---|
1032 | ) |
---|
1033 | )) |
---|
1034 | )) |
---|
1035 | |
---|
1036 | (transient-template |
---|
1037 | (sxml:match 'ncml:transient |
---|
1038 | (lambda (node bindings root env) |
---|
1039 | (let* ((unit (sxml:attr node 'unit)) |
---|
1040 | (id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
1041 | (rhs ((lambda (x) |
---|
1042 | (if (not x) |
---|
1043 | (error 'rate-template "rate equation requires expr element") |
---|
1044 | (parse-expr (second x) id))) |
---|
1045 | (sxml:kidn* 'ncml:expr node))) |
---|
1046 | (initial ((lambda (x) (and x (parse-expr (second x) id))) |
---|
1047 | (sxml:kidn* 'ncml:initial node))) |
---|
1048 | (onevent ((lambda (x) (and x (parse-expr (second x) id))) |
---|
1049 | (sxml:kidn* 'ncml:onevent node))) |
---|
1050 | (power ((lambda (x) (and x (parse-expr (second x) id))) |
---|
1051 | (sxml:kidn* 'ncml:power node))) |
---|
1052 | ) |
---|
1053 | (if (not id) (error 'transient-template "transient equation requires id attribute")) |
---|
1054 | (cond |
---|
1055 | ((and power initial unit) |
---|
1056 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1057 | (initial ,initial) (power ,power) (unit ,($ unit)))) |
---|
1058 | ((and power initial) |
---|
1059 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1060 | (initial ,initial) (power ,power))) |
---|
1061 | ((and power unit) |
---|
1062 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1063 | (power ,power) (unit ,($ unit)))) |
---|
1064 | ((and initial unit) |
---|
1065 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1066 | (initial ,initial) (unit ,($ unit)))) |
---|
1067 | (initial |
---|
1068 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1069 | (initial ,initial))) |
---|
1070 | (power |
---|
1071 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1072 | (power ,power))) |
---|
1073 | (unit |
---|
1074 | `(transient (,($ id)) = ,rhs (onevent ,onevent) |
---|
1075 | (unit ,($ unit)))) |
---|
1076 | (else |
---|
1077 | `(transient (,($ id)) = ,rhs (onevent ,onevent) )) |
---|
1078 | )) |
---|
1079 | )) |
---|
1080 | ) |
---|
1081 | |
---|
1082 | (conseq-template |
---|
1083 | (sxml:match 'ncml:conseq |
---|
1084 | (lambda (node bindings root env) |
---|
1085 | (let ((val (string->number (->string (sxml:attr node 'val)))) |
---|
1086 | (rhs ((lambda (x) |
---|
1087 | (if (not x) |
---|
1088 | (error 'conseq-template |
---|
1089 | "conseq definition requires expr element") |
---|
1090 | (parse-expr (second x)))) |
---|
1091 | (sxml:kidn* 'ncml:expr node)))) |
---|
1092 | `(,val = ,rhs))) |
---|
1093 | )) |
---|
1094 | |
---|
1095 | (reaction-template |
---|
1096 | (sxml:match 'ncml:reaction |
---|
1097 | (lambda (node bindings root env) |
---|
1098 | (let* ((unit (sxml:attr node 'unit)) |
---|
1099 | (id ($ (or (sxml:attr node 'id) (sxml:attr node 'name)))) |
---|
1100 | (initial ((lambda (x) (and x (parse-expr (second x) id))) |
---|
1101 | (sxml:kidn* 'ncml:initial node))) |
---|
1102 | |
---|
1103 | (open ((lambda (x) |
---|
1104 | (if (not x) |
---|
1105 | (error 'reaction-template |
---|
1106 | "reaction declaration requires open element") |
---|
1107 | (let ((os (string-split (second x) ","))) |
---|
1108 | (map $ os)))) |
---|
1109 | (sxml:kidn* 'ncml:open node))) |
---|
1110 | |
---|
1111 | (conserve ((lambda (x) |
---|
1112 | (and x (let ((tmpl (sxml:make-null-ss conseq-template))) |
---|
1113 | (stx:apply-templates (cdr x) tmpl root env)))) |
---|
1114 | (sxml:kidn* 'ncml:conserve node))) |
---|
1115 | |
---|
1116 | (power ((lambda (x) |
---|
1117 | (if (not x) |
---|
1118 | (error 'reaction-template |
---|
1119 | "reaction declaration requires open element") |
---|
1120 | (parse-expr (second x) id))) |
---|
1121 | (sxml:kidn* 'ncml:power node))) |
---|
1122 | |
---|
1123 | (transitions ((lambda (x) |
---|
1124 | (if (not x) |
---|
1125 | (error 'reaction-template |
---|
1126 | "reaction declaration requires transitions element") |
---|
1127 | (let ((tmpl (sxml:make-null-ss reaction-transition-template))) |
---|
1128 | (stx:apply-templates (cdr x) tmpl root env)))) |
---|
1129 | (sxml:kidn* 'ncml:transitions node))) |
---|
1130 | |
---|
1131 | ) |
---|
1132 | |
---|
1133 | (if (not id) (error 'reaction-template "reaction declaration requires id attribute")) |
---|
1134 | (cond |
---|
1135 | ((and conserve unit) |
---|
1136 | `(reaction (,id (initial ,initial) (open ,open) (power ,power) |
---|
1137 | (conserve ,conserve) |
---|
1138 | (transitions ,@transitions) |
---|
1139 | (unit ,($ unit))))) |
---|
1140 | (conserve |
---|
1141 | `(reaction (,id (initial ,initial) (open ,open) (power ,power) |
---|
1142 | (conserve ,conserve) |
---|
1143 | (transitions ,@transitions)))) |
---|
1144 | |
---|
1145 | (unit |
---|
1146 | `(reaction (,id (initial ,initial) (open ,open) (power ,power) |
---|
1147 | (transitions ,@transitions) |
---|
1148 | (unit ,($ unit))))) |
---|
1149 | )) |
---|
1150 | )) |
---|
1151 | ) |
---|
1152 | |
---|
1153 | (defun-template |
---|
1154 | (sxml:match 'ncml:defun |
---|
1155 | (lambda (node bindings root env) |
---|
1156 | |
---|
1157 | (let* ((id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
1158 | (args ((lambda (x) |
---|
1159 | (if (null? x) |
---|
1160 | (error 'defun-template |
---|
1161 | "function definition requires at least one arg element") |
---|
1162 | (map (compose $ second) x))) |
---|
1163 | (sxml:kidsn 'ncml:arg node))) |
---|
1164 | (body ((lambda (x) |
---|
1165 | (if (not x) |
---|
1166 | (error 'defun-template |
---|
1167 | "function definition requires body element") |
---|
1168 | (parse-expr (second x) id))) |
---|
1169 | (sxml:kidn* 'ncml:body node)))) |
---|
1170 | (if (not id) (error 'defun-template "function definition requires id attribute")) |
---|
1171 | |
---|
1172 | `(defun ,($ id) ,args ,body))))) |
---|
1173 | |
---|
1174 | (component-template |
---|
1175 | (sxml:match 'ncml:component |
---|
1176 | (lambda (node bindings root env) |
---|
1177 | |
---|
1178 | (let ((name (sxml:attr node 'name)) |
---|
1179 | (functor-name (or (sxml:attr node 'functor-name) |
---|
1180 | (sxml:attr node 'functor))) |
---|
1181 | (type (sxml:attr node 'type))) |
---|
1182 | |
---|
1183 | (if (and (not functor-name) (not type) ) |
---|
1184 | (error 'component-template "component definition requires type attribute" name)) |
---|
1185 | (if (and functor-name (not name) ) |
---|
1186 | (error 'component-template "component definition requires name attribute")) |
---|
1187 | (if functor-name |
---|
1188 | `(component (name ,($ name)) = ,($ functor-name) |
---|
1189 | ,(ncml->declarations (sxml:kids node) parse-expr)) |
---|
1190 | (if name |
---|
1191 | `(component (type ,($ type)) (name ,($ name)) |
---|
1192 | ,@(ncml->declarations (sxml:kids node) parse-expr)) |
---|
1193 | `(component (type ,($ type)) |
---|
1194 | ,@(ncml->declarations (sxml:kids node) parse-expr)) |
---|
1195 | )) |
---|
1196 | )) |
---|
1197 | )) |
---|
1198 | |
---|
1199 | (functor-template |
---|
1200 | (sxml:match 'ncml:functor |
---|
1201 | (lambda (node bindings root env) |
---|
1202 | |
---|
1203 | (let ((parameters (sxml:attr node 'parameters)) |
---|
1204 | (name (sxml:attr node 'name)) |
---|
1205 | (type (sxml:attr node 'type))) |
---|
1206 | (if (not type) (error 'functor-template "functor definition requires type attribute")) |
---|
1207 | (if (not name) (error 'functor-template "functor definition requires name attribute")) |
---|
1208 | (if (not parameters) |
---|
1209 | (error 'functor-template "functor definition requires parameters attribute")) |
---|
1210 | `(functor (name ,($ name)) (type ,($ type)) |
---|
1211 | ,(map $ (string-split parameters ",")) |
---|
1212 | = . ,(ncml->declarations (sxml:kids node) parse-expr)))))) |
---|
1213 | |
---|
1214 | (hh-template |
---|
1215 | (sxml:match 'ncml:hh_ionic_gate |
---|
1216 | (lambda (node bindings root env) |
---|
1217 | (let* ( |
---|
1218 | (id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
1219 | (and-expr (lambda (x) (and x (parse-expr (second x) id)))) |
---|
1220 | (initial_m (and-expr (sxml:kidn* 'ncml:initial_m node))) |
---|
1221 | (initial_h (and-expr (sxml:kidn* 'ncml:initial_h node))) |
---|
1222 | (m_power (and-expr (sxml:kidn* 'ncml:m_power node))) |
---|
1223 | (h_power (and-expr (sxml:kidn* 'ncml:h_power node))) |
---|
1224 | (m_alpha (and-expr (sxml:kidn* 'ncml:m_alpha node))) |
---|
1225 | (m_beta (and-expr (sxml:kidn* 'ncml:m_beta node))) |
---|
1226 | (h_alpha (and-expr (sxml:kidn* 'ncml:h_alpha node))) |
---|
1227 | (h_beta (and-expr (sxml:kidn* 'ncml:h_beta node))) |
---|
1228 | (m_tau (and-expr (sxml:kidn* 'ncml:m_tau node))) |
---|
1229 | (m_inf (and-expr (sxml:kidn* 'ncml:m_inf node))) |
---|
1230 | (h_tau (and-expr (sxml:kidn* 'ncml:h_tau node))) |
---|
1231 | (h_inf (and-expr (sxml:kidn* 'ncml:h_inf node))) |
---|
1232 | ) |
---|
1233 | |
---|
1234 | (if (not id) |
---|
1235 | (error 'hh-template "hh ionic conductance definition requires id attribute")) |
---|
1236 | `(hh-ionic-gate |
---|
1237 | (,($ id) |
---|
1238 | ,@(if initial_m `((initial-m ,initial_m)) `()) |
---|
1239 | ,@(if initial_h `((initial-h ,initial_h)) `()) |
---|
1240 | ,@(if m_power `((m-power ,m_power)) '()) |
---|
1241 | ,@(if h_power `((h-power ,h_power)) '()) |
---|
1242 | ,@(if m_alpha `((m-alpha ,m_alpha)) '()) |
---|
1243 | ,@(if h_alpha `((h-alpha ,h_alpha)) '()) |
---|
1244 | ,@(if m_beta `((m-beta ,m_beta)) '()) |
---|
1245 | ,@(if h_beta `((h-beta ,h_beta)) '()) |
---|
1246 | ,@(if m_inf `((m-inf ,m_inf)) '()) |
---|
1247 | ,@(if h_inf `((h-inf ,h_inf)) '()) |
---|
1248 | ,@(if m_tau `((m-tau ,m_tau)) '()) |
---|
1249 | ,@(if h_tau `((h-tau ,h_tau)) '()) |
---|
1250 | )))))) |
---|
1251 | |
---|
1252 | (decaying-pool-template |
---|
1253 | (sxml:match 'ncml:decaying_pool |
---|
1254 | (lambda (node bindings root env) |
---|
1255 | (let* ((id (sxml:attr node 'id)) |
---|
1256 | (and-expr (lambda (x) (and x (parse-expr (second x) id)))) |
---|
1257 | (initial (and-expr (sxml:kidn* 'ncml:initial node))) |
---|
1258 | (beta (and-expr (sxml:kidn* 'ncml:beta node))) |
---|
1259 | (depth (and-expr (sxml:kidn* 'ncml:depth node))) |
---|
1260 | (temp-adj (and-expr (sxml:kidn* 'ncml:temp_adj node)))) |
---|
1261 | (if (not id) |
---|
1262 | (error 'decaying-pool-template "decaying pool definition requires id attribute")) |
---|
1263 | (if (not initial) |
---|
1264 | (error 'decaying-pool-template "decaying pool definition requires initial value")) |
---|
1265 | (if (not beta) |
---|
1266 | (error 'decaying-pool-template "decaying pool definition requires beta parameter")) |
---|
1267 | (if (not depth) |
---|
1268 | (error 'decaying-pool-template "decaying pool definition requires depth parameter")) |
---|
1269 | |
---|
1270 | `(decaying-pool |
---|
1271 | (,($ id) |
---|
1272 | ,@(if temp_adj `((temp_adj ,temp_adj)) `()) |
---|
1273 | (beta ,beta) |
---|
1274 | (depth ,depth) |
---|
1275 | (initial ,initial))))))) |
---|
1276 | ) |
---|
1277 | |
---|
1278 | (stx:apply-templates |
---|
1279 | ncml:model |
---|
1280 | (sxml:make-null-ss label-template |
---|
1281 | input-template |
---|
1282 | output-template |
---|
1283 | const-template |
---|
1284 | asgn-template |
---|
1285 | rate-template |
---|
1286 | reaction-template |
---|
1287 | transient-template |
---|
1288 | defun-template |
---|
1289 | component-template |
---|
1290 | functor-template |
---|
1291 | hh-template |
---|
1292 | decaying-pool-template) |
---|
1293 | ncml:model (list)) |
---|
1294 | |
---|
1295 | )) |
---|
1296 | |
---|
1297 | |
---|
1298 | (define sxslt-preamble |
---|
1299 | `( |
---|
1300 | (import scheme chicken) |
---|
1301 | (require-extension sxml-transforms sxpath sxpath-lolevel) |
---|
1302 | (define-syntax sxml:match |
---|
1303 | (syntax-rules () |
---|
1304 | ((match pattern handler) |
---|
1305 | (list (if (symbol? pattern) pattern (sxpath pattern)) |
---|
1306 | handler)) |
---|
1307 | )) |
---|
1308 | (define identity-template |
---|
1309 | `(*default* ,(lambda (node bindings root env) |
---|
1310 | (begin |
---|
1311 | node)))) |
---|
1312 | (define-syntax sxml:make-ss |
---|
1313 | (syntax-rules () |
---|
1314 | ((stx rule ...) |
---|
1315 | (list |
---|
1316 | identity-template |
---|
1317 | (list '*text* (lambda (text) text)) |
---|
1318 | rule ...)) |
---|
1319 | )) |
---|
1320 | (define (sxml:kid node) |
---|
1321 | (let ((v ((select-first-kid |
---|
1322 | (lambda (x) (not (eq? (car x) '@)))) node))) |
---|
1323 | (if (not v) |
---|
1324 | (error 'sxml:kid "node does not have children" node) v))) |
---|
1325 | (define (sxml:kids node) |
---|
1326 | ((select-kids (lambda (x) (not (eq? (car x) '@)))) node)) |
---|
1327 | (define (sxml:kidsn name node) |
---|
1328 | ((select-kids (lambda (x) (eq? (car x) name))) node)) |
---|
1329 | (define (sxml:kidn name node) |
---|
1330 | ((select-first-kid (lambda (x) (eq? (car x) name))) node)) |
---|
1331 | )) |
---|
1332 | |
---|
1333 | |
---|
1334 | (define (ncml->model-decls options doc) |
---|
1335 | |
---|
1336 | (define (load-ss in) |
---|
1337 | (eval `(begin |
---|
1338 | ,@sxslt-preamble |
---|
1339 | (sxml:make-ss ,@(read in)) |
---|
1340 | ))) |
---|
1341 | |
---|
1342 | (define (make-ss-fname dirname fname) |
---|
1343 | (or (and dirname (make-pathname dirname fname)) fname)) |
---|
1344 | |
---|
1345 | (let* ((source-path (lookup-def 'source-path options)) |
---|
1346 | (dirname (pathname-directory source-path)) |
---|
1347 | (parse-expr (or (lookup-def 'parse-expr options) identity)) |
---|
1348 | (ncml:model ((lambda (x) |
---|
1349 | (if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x))) |
---|
1350 | (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc)))) |
---|
1351 | (model-name ($ (or (sxml:attr ncml:model 'name) (gensym 'model)))) |
---|
1352 | (membraneprops (ncml:sxpath '(// cell biophysicalProperties membraneProperties) |
---|
1353 | `(*TOP* . ,ncml:model))) |
---|
1354 | (ncml-ss (ncml:sxpath '(// ncml:sxslt) `(*TOP* . ,ncml:model))) |
---|
1355 | (ncml-templates (ncml:sxpath '(// ncml:template) `(*TOP* . ,ncml:model))) |
---|
1356 | (ncml-decls ((lambda (doc) |
---|
1357 | (if (null? ncml-ss) doc |
---|
1358 | (let ((ss (map |
---|
1359 | (lambda (x) |
---|
1360 | (let ((fn (sxml:attr x 'filename))) |
---|
1361 | (or (and fn (call-with-input-file (make-ss-fname dirname fn) load-ss)) |
---|
1362 | (call-with-input-string (sxml:text x) load-ss)) |
---|
1363 | )) |
---|
1364 | ncml-ss))) |
---|
1365 | (fold (lambda (s doc) (stx:apply-templates doc s doc (list))) doc ss)) |
---|
1366 | )) |
---|
1367 | (if (null? membraneprops) |
---|
1368 | (sxml:kids ncml:model) |
---|
1369 | (sxml:kids membraneprops)))) |
---|
1370 | (dd (if (lookup-def 'debug options) |
---|
1371 | (begin (pp ncml-decls)))) |
---|
1372 | (model-decls (ncml->declarations ncml-decls parse-expr)) |
---|
1373 | (user-templates (map (lambda (t) |
---|
1374 | (let ((name (or (sxml:attr t 'name) (->string (gensym 'template)))) |
---|
1375 | (args (or (let ((xs (sxml:attr t 'args))) |
---|
1376 | (or (and xs (string-split xs ",")) '()))))) |
---|
1377 | (list name args (ersatz:statements-from-string |
---|
1378 | (ersatz:template-std-env) |
---|
1379 | (sxml:text t))) |
---|
1380 | )) |
---|
1381 | ncml-templates)) |
---|
1382 | ) |
---|
1383 | (list model-name model-decls user-templates))) |
---|
1384 | |
---|
1385 | |
---|
1386 | (define (ncml-model-decls->model options model-name model-decls) |
---|
1387 | |
---|
1388 | (if (or (null? model-decls) (and (pair? model-decls) (every null? model-decls))) |
---|
1389 | (error 'ncml-model-decls->model "ncml declaration elements not found in input document")) |
---|
1390 | |
---|
1391 | (let* ((model+nemo (nemo-constructor model-name model-decls (lambda (x . rest) (identity x)))) |
---|
1392 | (model (first model+nemo)) |
---|
1393 | (nemo (second model+nemo))) |
---|
1394 | |
---|
1395 | (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) (lambda (x . rest) (identity x))))) |
---|
1396 | |
---|
1397 | (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1))) |
---|
1398 | (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1))) |
---|
1399 | (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1))) |
---|
1400 | (if (assoc 'components options) |
---|
1401 | (for-each (lambda (x) |
---|
1402 | (print "component " x ": " ((nemo 'component-exports) model-1 (second x))) |
---|
1403 | (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x)))) |
---|
1404 | ((nemo 'components) model-1))) |
---|
1405 | model-1))) |
---|
1406 | |
---|
1407 | |
---|
1408 | |
---|
1409 | (define nineml-reaction-transition-template |
---|
1410 | (sxml:match 'nmlb:transition |
---|
1411 | (lambda (node bindings root env) |
---|
1412 | (let ( |
---|
1413 | (src (sxml:attr node 'src)) |
---|
1414 | (dst (sxml:attr node 'dst)) |
---|
1415 | (rate ((lambda (x) |
---|
1416 | (if (not x) |
---|
1417 | (error 'nineml-reaction-transition-template |
---|
1418 | "reaction transition requires rate element") |
---|
1419 | (sxml:text x))) |
---|
1420 | (sxml:kidn* 'nmlb:rate node))) |
---|
1421 | ) |
---|
1422 | (if (not src) (error 'nineml-reaction-transition-template |
---|
1423 | "reaction transition requires src attribute")) |
---|
1424 | (if (not dst) (error 'nineml-reaction-transition-template |
---|
1425 | "reaction transition requires dst attribute")) |
---|
1426 | |
---|
1427 | `(ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,rate)) |
---|
1428 | )) |
---|
1429 | )) |
---|
1430 | |
---|
1431 | |
---|
1432 | |
---|
1433 | (define nineml-ss |
---|
1434 | |
---|
1435 | (sxml:make-null-ss |
---|
1436 | |
---|
1437 | (sxml:match 'nmlb:ComponentClass |
---|
1438 | (lambda (node bindings root env) |
---|
1439 | (let* ((name (sxml:attr node 'name)) |
---|
1440 | (type (sxml:attr node 'type)) |
---|
1441 | (interface (sxml:kidn 'nmlb:Interface node)) |
---|
1442 | (parameters (let ((xs (sxml:kidsn 'nmlb:Parameter interface))) |
---|
1443 | (filter-map (lambda (x) (sxml:attr x 'name)) xs))) |
---|
1444 | (decls (let ((xs (sxml:kids node))) |
---|
1445 | (filter (lambda (x) |
---|
1446 | (not (equal? (sxml:element-name x) 'nmlb:Interface))) |
---|
1447 | xs))) |
---|
1448 | ) |
---|
1449 | (let ((decls1 (stx:apply-templates decls nineml-ss root env))) |
---|
1450 | `(ncml:functor (@ (type ,type) (name ,name) |
---|
1451 | (parameters ,(slp "," parameters))) |
---|
1452 | . ,decls1) ) |
---|
1453 | ))) |
---|
1454 | |
---|
1455 | |
---|
1456 | (sxml:match 'nmlb:Component |
---|
1457 | |
---|
1458 | (lambda (node bindings root env) |
---|
1459 | |
---|
1460 | (define (read-xml-string s) |
---|
1461 | (call-with-input-string s |
---|
1462 | (lambda (port) |
---|
1463 | (ssax:xml->sxml port |
---|
1464 | '((nmlb . "http://www.nineml.org/Biophysics"))) |
---|
1465 | ))) |
---|
1466 | |
---|
1467 | (let ((name (sxml:attr node 'name)) |
---|
1468 | (type (sxml:attr node 'type)) |
---|
1469 | (definition (sxml:attr node 'definition)) |
---|
1470 | (definition-uri (let ((link (or (sxml:kidn 'nmlb:link node) |
---|
1471 | (sxml:kidn 'nmlb:url node)))) |
---|
1472 | (and link (uri-reference link)))) |
---|
1473 | (decls (sxml:kids node)) |
---|
1474 | (properties (map cdr (sxml:kidsn 'nmlb:properties node))) |
---|
1475 | ) |
---|
1476 | |
---|
1477 | (let ( |
---|
1478 | (parameters (stx:apply-templates |
---|
1479 | (concatenate properties) |
---|
1480 | nineml-ss |
---|
1481 | root env)) |
---|
1482 | ) |
---|
1483 | |
---|
1484 | (cond (definition-uri |
---|
1485 | (let* ( |
---|
1486 | (definition-str (nemo:fetch definition-uri)) |
---|
1487 | (definition-sxml (read-xml-string definition-str)) |
---|
1488 | (definition (stx:apply-templates definition-sxml nineml-ss root env)) |
---|
1489 | ) |
---|
1490 | (case (car definition) |
---|
1491 | ((ncml:functor) |
---|
1492 | (let* ( |
---|
1493 | (definition-attrs (alist-ref '@ definition)) |
---|
1494 | (definition-name (alist-ref 'name definition-attrs)) |
---|
1495 | ) |
---|
1496 | (env (cons `(,definition-name . ,definition) (env))) |
---|
1497 | `(ncml:component (@ (name ,name) (functor-name ,definition-name) ) |
---|
1498 | . ,parameters)) |
---|
1499 | ) |
---|
1500 | (else (error 'nineml->model-decls |
---|
1501 | "unable to find component class in definition uri " |
---|
1502 | definition-uri)) |
---|
1503 | )) |
---|
1504 | ) |
---|
1505 | (definition |
---|
1506 | `(ncml:component (@ (name ,name) (functor-name ,definition) ) |
---|
1507 | . ,parameters)) |
---|
1508 | (else |
---|
1509 | (let ((decls1 (stx:apply-templates decls nineml-ss root env))) |
---|
1510 | (cond ((and name type) |
---|
1511 | `(ncml:component (@ (name ,name) (type ,type) ) |
---|
1512 | . ,(append parameters decls1))) |
---|
1513 | (type |
---|
1514 | `(ncml:component (@ (type ,type) ) |
---|
1515 | . ,(append parameters decls1))) |
---|
1516 | (else |
---|
1517 | `(ncml:component . ,(append parameters decls1))))) |
---|
1518 | )) |
---|
1519 | )) |
---|
1520 | )) |
---|
1521 | |
---|
1522 | |
---|
1523 | (sxml:match 'nmlb:Parameter |
---|
1524 | (lambda (node bindings root env) |
---|
1525 | (let ( |
---|
1526 | (name (sxml:attr node 'name)) |
---|
1527 | (value (sxml:text (sxml:kidn* 'nmlb:value node))) |
---|
1528 | (unit (sxml:kidn 'nmlb:unit node)) |
---|
1529 | ) |
---|
1530 | `(ncml:const (@ (name ,name) ,@(if unit `((unit ,(sxml:text unit))) `())) (ncml:expr ,value) ) |
---|
1531 | )) |
---|
1532 | ) |
---|
1533 | |
---|
1534 | (sxml:match 'nmlb:Alias |
---|
1535 | (lambda (node bindings root env) |
---|
1536 | (let ((name (sxml:attr node 'name)) |
---|
1537 | (arguments (string-split |
---|
1538 | (or (sxml:attr node 'argument) |
---|
1539 | (sxml:attr node 'arguments)) ",")) |
---|
1540 | ) |
---|
1541 | `(ncml:defun (@ (name ,name)) |
---|
1542 | ,@(map (lambda (x) `(ncml:arg ,x)) arguments) |
---|
1543 | (ncml:body ,(sxml:text (sxml:kid node))) |
---|
1544 | )) |
---|
1545 | )) |
---|
1546 | |
---|
1547 | (sxml:match 'nmlb:AnalogPort |
---|
1548 | (lambda (node bindings root env) |
---|
1549 | (let ((name (sxml:attr node 'name)) |
---|
1550 | (mode (sxml:attr node 'mode)) |
---|
1551 | (from (sxml:attr node 'from)) |
---|
1552 | (unit (sxml:kidn 'nmlb:unit node)) |
---|
1553 | ) |
---|
1554 | (cond |
---|
1555 | ((string=? mode "receive") |
---|
1556 | (if from |
---|
1557 | `(ncml:input (@ (name ,name) (from ,from) ,@(if unit `((unit ,(sxml:text unit))) `()))) |
---|
1558 | `(ncml:input (@ (name ,name) ,@(if unit `((unit ,(sxml:text unit))) `()))) |
---|
1559 | )) |
---|
1560 | ((string=? mode "send") |
---|
1561 | `(ncml:output (@ (name ,name) ,@(if unit `((unit ,(sxml:text unit))) `())))) |
---|
1562 | |
---|
1563 | (error 'nineml->model-decls "unknown analog port mode" mode)) |
---|
1564 | ) |
---|
1565 | )) |
---|
1566 | |
---|
1567 | (sxml:match 'nmlb:Assignment |
---|
1568 | (lambda (node bindings root env) |
---|
1569 | (let ( |
---|
1570 | (name (sxml:attr node 'name)) |
---|
1571 | (rhs (sxml:text (sxml:kidn* 'nmlb:rhs node))) |
---|
1572 | (unit (sxml:kidn 'nmlb:unit node)) |
---|
1573 | ) |
---|
1574 | `(ncml:asgn (@ (name ,name) ,@(if unit `((unit ,(sxml:text unit))) `())) |
---|
1575 | (ncml:expr ,rhs)) |
---|
1576 | )) |
---|
1577 | ) |
---|
1578 | |
---|
1579 | (sxml:match 'nmlb:TimeDerivative |
---|
1580 | (lambda (node bindings root env) |
---|
1581 | (let ( |
---|
1582 | (name (sxml:attr node 'variable)) |
---|
1583 | (rhs (sxml:kidn* 'nmlb:rhs node)) |
---|
1584 | (initial (sxml:kidn* 'nmlb:initial node)) |
---|
1585 | (unit (sxml:kidn 'nmlb:unit node)) |
---|
1586 | ) |
---|
1587 | `(ncml:rate (@ (name ,name) ) |
---|
1588 | (ncml:expr ,(sxml:text rhs)) |
---|
1589 | ,@(if initial `((ncml:initial ,(sxml:text initial))) '()) |
---|
1590 | ,@(if unit `((unit ,(sxml:text unit))) `()) |
---|
1591 | ) |
---|
1592 | )) |
---|
1593 | ) |
---|
1594 | |
---|
1595 | (sxml:match 'nmlb:Transient |
---|
1596 | (lambda (node bindings root env) |
---|
1597 | (let ( |
---|
1598 | (name (sxml:attr node 'variable)) |
---|
1599 | (onevent (sxml:kidn* 'nmlb:onevent node)) |
---|
1600 | (power (sxml:kidn* 'nmlb:power node)) |
---|
1601 | (rhs (sxml:kidn* 'nmlb:rhs node)) |
---|
1602 | (initial (sxml:kidn* 'nmlb:initial node)) |
---|
1603 | (unit (sxml:kidn 'nmlb:unit node)) |
---|
1604 | ) |
---|
1605 | `(ncml:transient (@ (name ,name) ) |
---|
1606 | (ncml:expr ,(sxml:text rhs)) |
---|
1607 | (ncml:onevent ,(sxml:text onevent)) |
---|
1608 | ,@(if initial `((ncml:initial ,(sxml:text initial))) '()) |
---|
1609 | ,@(if power `((ncml:power ,(sxml:text power))) '()) |
---|
1610 | ,@(if unit `((unit ,(sxml:text unit))) `()) |
---|
1611 | ) |
---|
1612 | )) |
---|
1613 | ) |
---|
1614 | |
---|
1615 | |
---|
1616 | (sxml:match 'nmlb:Reaction |
---|
1617 | (lambda (node bindings root env) |
---|
1618 | (let ( |
---|
1619 | (name (sxml:attr node 'variable)) |
---|
1620 | (open (sxml:text (sxml:kidn* 'nmlb:open node))) |
---|
1621 | (power (sxml:text (sxml:kidn* 'nmlb:power node))) |
---|
1622 | (conserve (sxml:kidn* 'nmlb:conserve node)) |
---|
1623 | (transitions (let ((tmpl (sxml:make-null-ss nineml-reaction-transition-template))) |
---|
1624 | (stx:apply-templates (sxml:kids (sxml:kidn* 'nmlb:transitions node)) tmpl root env))) |
---|
1625 | (initial (sxml:kidn* 'nmlb:initial node)) |
---|
1626 | (unit (sxml:kidn 'nmlb:unit node)) |
---|
1627 | ) |
---|
1628 | `(ncml:reaction (@ (name ,name) ) |
---|
1629 | (ncml:transitions . ,transitions) |
---|
1630 | (ncml:open ,open) |
---|
1631 | ,(if conserve |
---|
1632 | `(ncml:conserve |
---|
1633 | (ncml:conseq (@ (val ,(sxml:attr conserve 'val))) |
---|
1634 | (ncml:expr ,(sxml:text conserve)))) |
---|
1635 | '()) |
---|
1636 | ,@(if initial `((ncml:initial ,initial)) '()) |
---|
1637 | ,@(if power `((ncml:power ,power)) '()) |
---|
1638 | ,@(if unit `((unit ,(sxml:text unit))) `()) |
---|
1639 | ) |
---|
1640 | )) |
---|
1641 | ) |
---|
1642 | |
---|
1643 | |
---|
1644 | (sxml:match 'nmlb:hh_ionic_gate |
---|
1645 | (lambda (node bindings root env) |
---|
1646 | (let* ( |
---|
1647 | (id (or (sxml:attr node 'id) (sxml:attr node 'name))) |
---|
1648 | (and-text (lambda (x) (and x (sxml:text x)))) |
---|
1649 | (initial_m (and-text (sxml:kidn* 'nmlb:initial_m node))) |
---|
1650 | (initial_h (and-text (sxml:kidn* 'nmlb:initial_h node))) |
---|
1651 | (m_power (and-text (sxml:kidn* 'nmlb:m_power node))) |
---|
1652 | (h_power (and-text (sxml:kidn* 'nmlb:h_power node))) |
---|
1653 | (m_alpha (and-text (sxml:kidn* 'nmlb:m_alpha node))) |
---|
1654 | (m_beta (and-text (sxml:kidn* 'nmlb:m_beta node))) |
---|
1655 | (h_alpha (and-text (sxml:kidn* 'nmlb:h_alpha node))) |
---|
1656 | (h_beta (and-text (sxml:kidn* 'nmlb:h_beta node))) |
---|
1657 | (m_tau (and-text (sxml:kidn* 'nmlb:m_tau node))) |
---|
1658 | (m_inf (and-text (sxml:kidn* 'nmlb:m_inf node))) |
---|
1659 | (h_tau (and-text (sxml:kidn* 'nmlb:h_tau node))) |
---|
1660 | (h_inf (and-text (sxml:kidn* 'nmlb:h_inf node))) |
---|
1661 | ) |
---|
1662 | |
---|
1663 | `(ncml:hh_ionic_gate (@ (name ,id)) |
---|
1664 | ,@(if initial_m `((ncml:initial_m ,initial_m)) `()) |
---|
1665 | ,@(if initial_h `((ncml:initial_h ,initial_h)) `()) |
---|
1666 | ,@(if m_power `((ncml:m_power ,m_power)) '()) |
---|
1667 | ,@(if h_power `((ncml:h_power ,h_power)) '()) |
---|
1668 | ,@(if m_alpha `((ncml:m_alpha ,m_alpha)) '()) |
---|
1669 | ,@(if h_alpha `((ncml:h_alpha ,h_alpha)) '()) |
---|
1670 | ,@(if m_beta `((ncml:m_beta ,m_beta)) '()) |
---|
1671 | ,@(if h_beta `((ncml:h_beta ,h_beta)) '()) |
---|
1672 | ,@(if m_inf `((ncml:m_inf ,m_inf)) '()) |
---|
1673 | ,@(if h_inf `((ncml:h_inf ,h_inf)) '()) |
---|
1674 | ,@(if m_tau `((ncml:m_tau ,m_tau)) '()) |
---|
1675 | ,@(if h_tau `((ncml:h_tau ,h_tau)) '()) |
---|
1676 | ) |
---|
1677 | )) |
---|
1678 | ) |
---|
1679 | |
---|
1680 | |
---|
1681 | )) |
---|
1682 | |
---|
1683 | (define (nineml->model-decls options doc) |
---|
1684 | |
---|
1685 | (define (load-ss in) |
---|
1686 | (eval `(begin |
---|
1687 | ,@sxslt-preamble |
---|
1688 | (sxml:make-ss ,@(read in)) |
---|
1689 | ))) |
---|
1690 | |
---|
1691 | (define (make-ss-fname dirname fname) |
---|
1692 | (or (and dirname (make-pathname dirname fname)) fname)) |
---|
1693 | |
---|
1694 | (let* ((source-path (lookup-def 'source-path options)) |
---|
1695 | (dirname (pathname-directory source-path)) |
---|
1696 | (parse-expr (or (lookup-def 'parse-expr options) identity)) |
---|
1697 | |
---|
1698 | (nmlb:model ((lambda (x) |
---|
1699 | (if (null? x) (error 'nineml->model "NineML Biophysics element not found in input document") (car x))) |
---|
1700 | (nmlb:sxpath '(// nmlb:Biophysics) `(*TOP* . ,doc)))) |
---|
1701 | (model-name ($ (or (sxml:attr nmlb:model 'name) (gensym 'model)))) |
---|
1702 | |
---|
1703 | (nmlb-ss (ncml:sxpath '(// nmlb:sxslt) `(*TOP* . ,nmlb:model))) |
---|
1704 | (nmlb-decls ((lambda (doc) |
---|
1705 | (if (null? nmlb-ss) doc |
---|
1706 | (let ((ss (map |
---|
1707 | (lambda (x) |
---|
1708 | (let ((fn (sxml:attr x 'filename))) |
---|
1709 | (or (and fn (call-with-input-file (make-ss-fname dirname fn) load-ss)) |
---|
1710 | (call-with-input-string (sxml:text x) load-ss)) |
---|
1711 | )) |
---|
1712 | nmlb-ss))) |
---|
1713 | (fold (lambda (s doc) (stx:apply-templates doc s doc (list))) doc ss)) |
---|
1714 | )) |
---|
1715 | (sxml:kids nmlb:model))) |
---|
1716 | |
---|
1717 | (ncml-env (make-parameter '())) |
---|
1718 | (ncml-decls (stx:apply-templates (sxml:kids nmlb:model) nineml-ss nmlb-decls ncml-env)) |
---|
1719 | (model-decls (ncml->declarations |
---|
1720 | (append (delete-duplicates (ncml-env) (lambda (x y) (equal? (car x) (car y)))) ncml-decls) |
---|
1721 | parse-expr)) |
---|
1722 | ) |
---|
1723 | (list model-name model-decls '()))) |
---|
1724 | |
---|
1725 | |
---|
1726 | |
---|
1727 | (define (entry->surface-xml x . rest) |
---|
1728 | (let-optionals rest ((ns-prefix "nemo")) |
---|
1729 | |
---|
1730 | (let ((ns-prefix (if (or (not ns-prefix) (string-null? ns-prefix)) "" |
---|
1731 | (string-append ns-prefix ":"))) |
---|
1732 | (xmlstr (lambda (x) (let recur ((x x)) |
---|
1733 | (if (pair? x) (map recur x) |
---|
1734 | (let ((v (string->goodHTML (->string x)))) |
---|
1735 | (if (pair? v) (string-concatenate v) v))) |
---|
1736 | )) |
---|
1737 | )) |
---|
1738 | |
---|
1739 | (let ((transition-str |
---|
1740 | (lambda (t) |
---|
1741 | (match t |
---|
1742 | (('-> src dst rate) |
---|
1743 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
1744 | ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix)) |
---|
1745 | |
---|
1746 | ((src '-> dst rate) |
---|
1747 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
1748 | ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix)) |
---|
1749 | |
---|
1750 | (('<-> src dst rate1 rate2) |
---|
1751 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
1752 | ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix |
---|
1753 | ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix |
---|
1754 | )) |
---|
1755 | |
---|
1756 | ((src '<-> dst rate1 rate2) |
---|
1757 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
1758 | ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix |
---|
1759 | ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix |
---|
1760 | )) |
---|
1761 | |
---|
1762 | (else (error 'transition-str "invalid transition " x)))) |
---|
1763 | ) |
---|
1764 | |
---|
1765 | (ionic-gate-str |
---|
1766 | (lambda (ion #!key |
---|
1767 | (initial-m-expr #f) |
---|
1768 | (initial-h-expr #f) |
---|
1769 | (m-power #f) |
---|
1770 | (h-power #f) |
---|
1771 | (m-inf-expr #f) |
---|
1772 | (m-tau-expr #f) |
---|
1773 | (h-inf-expr #f) |
---|
1774 | (h-tau-expr #f) |
---|
1775 | (m-alpha-expr #f) |
---|
1776 | (m-beta-expr #f) |
---|
1777 | (h-alpha-expr #f) |
---|
1778 | (h-beta-expr #f)) |
---|
1779 | |
---|
1780 | (let ((initial-m-str (or (and initial-m-expr |
---|
1781 | (sprintf "<~Ainitial_m>~A</~Ainitial_m>~%" |
---|
1782 | ns-prefix (xmlstr initial-m-expr) ns-prefix)) "")) |
---|
1783 | (initial-h-str (or (and initial-h-expr |
---|
1784 | (sprintf "<~Ainitial_h>~A</~Ainitial_h>~%" |
---|
1785 | ns-prefix (xmlstr initial-h-expr) ns-prefix)) "")) |
---|
1786 | |
---|
1787 | (m-power-str (or (and m-power |
---|
1788 | (sprintf "<~Am_power>~A</~Am_power>~%" |
---|
1789 | ns-prefix m-power ns-prefix)) "")) |
---|
1790 | (h-power-str (or (and h-power |
---|
1791 | (sprintf "<~Ah_power>~A</~Ah_power>~%" |
---|
1792 | ns-prefix h-power ns-prefix)) "")) |
---|
1793 | |
---|
1794 | (m-inf-str (or (and m-inf-expr |
---|
1795 | (sprintf "<~Am_inf>~A</~Am_inf>~%" |
---|
1796 | ns-prefix (xmlstr m-inf-expr) ns-prefix)) "")) |
---|
1797 | (m-tau-str (or (and m-tau-expr |
---|
1798 | (sprintf "<~Am_tau>~A</~Am_tau>~%" |
---|
1799 | ns-prefix (xmlstr m-tau-expr) ns-prefix)) "")) |
---|
1800 | |
---|
1801 | (h-inf-str (or (and h-inf-expr |
---|
1802 | (sprintf "<~Ah_inf>~A</~Ah_inf>~%" |
---|
1803 | ns-prefix (xmlstr h-inf-expr) ns-prefix)) "")) |
---|
1804 | (h-tau-str (or (and h-tau-expr |
---|
1805 | (sprintf "<~Ah_tau>~A</~Ah_tau>~%" |
---|
1806 | ns-prefix (xmlstr h-tau-expr) ns-prefix)) "")) |
---|
1807 | |
---|
1808 | (m-alpha-str (or (and m-alpha-expr |
---|
1809 | (sprintf "<~Am_alpha>~A</~Am_alpha>~%" |
---|
1810 | ns-prefix (xmlstr m-alpha-expr) ns-prefix)) "")) |
---|
1811 | (m-beta-str (or (and m-beta-expr |
---|
1812 | (sprintf "<~Am_beta>~A</~Am_beta>~%" |
---|
1813 | ns-prefix (xmlstr m-beta-expr) ns-prefix)) "")) |
---|
1814 | |
---|
1815 | (h-alpha-str (or (and h-alpha-expr |
---|
1816 | (sprintf "<~Ah_alpha>~A</~Ah_alpha>~%" |
---|
1817 | ns-prefix (xmlstr h-alpha-expr) ns-prefix)) "")) |
---|
1818 | (h-beta-str (or (and h-beta-expr |
---|
1819 | (sprintf "<~Ah_beta>~A</~Ah_beta>~%" |
---|
1820 | ns-prefix (xmlstr h-beta-expr) ns-prefix)) "")) |
---|
1821 | ) |
---|
1822 | |
---|
1823 | (sprintf "<~Ahh_ionic_gate name=\"~A\">~A</~Ahh_ionic_gate>~%" |
---|
1824 | ns-prefix ion |
---|
1825 | (string-append initial-m-str initial-h-str |
---|
1826 | m-power-str h-power-str m-inf-str |
---|
1827 | m-tau-str h-inf-str h-tau-str |
---|
1828 | m-alpha-str m-beta-str h-alpha-str h-beta-str |
---|
1829 | ) |
---|
1830 | ns-prefix)) |
---|
1831 | ))) |
---|
1832 | |
---|
1833 | (match x |
---|
1834 | (('nemo-model name decls) |
---|
1835 | (map entry->surface-xml decls)) |
---|
1836 | |
---|
1837 | (('output . names) |
---|
1838 | (string-concatenate (map (lambda (name) (sprintf "<~Aoutput name=\"~A\"/>~%" ns-prefix name)) names))) |
---|
1839 | |
---|
1840 | (('input . names) |
---|
1841 | (string-concatenate (map (lambda (name) |
---|
1842 | (match name |
---|
1843 | ((and name (? symbol?)) |
---|
1844 | (sprintf "<~Ainput name=\"~A\"/>~%" ns-prefix name)) |
---|
1845 | |
---|
1846 | ((name 'from ns) |
---|
1847 | (sprintf "<~Ainput name=\"~A\" from=\"~A\"/>~%" ns-prefix name ns)) |
---|
1848 | |
---|
1849 | )) |
---|
1850 | names))) |
---|
1851 | |
---|
1852 | (('const name '= value) |
---|
1853 | (if (number? value) |
---|
1854 | (sprintf "<~Aconst name=\"~A\" value=\"~A\"/>~%" |
---|
1855 | ns-prefix name value) |
---|
1856 | (sprintf "<~Aconst name=\"~A\">~%~A~%</~Aconst>~%" |
---|
1857 | ns-prefix name (xmlstr value) ns-prefix) |
---|
1858 | )) |
---|
1859 | |
---|
1860 | (((or 'defun 'fun) name args body) |
---|
1861 | (sprintf "<~Adefun name=\"~A\">~%~A~%<~Abody>~A</~Abody>~%</~Adefun>~%" |
---|
1862 | ns-prefix |
---|
1863 | name (string-concatenate (map (lambda (x) (sprintf "<~Aarg>~A</~Aarg>" ns-prefix x ns-prefix)) args)) |
---|
1864 | ns-prefix (xmlstr body) ns-prefix ns-prefix)) |
---|
1865 | |
---|
1866 | ((name '= expr) |
---|
1867 | (sprintf "<~Aasgn name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Aasgn>~%" |
---|
1868 | ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix)) |
---|
1869 | |
---|
1870 | (('d ( name ) '= expr) |
---|
1871 | (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Arate>~%" |
---|
1872 | ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix)) |
---|
1873 | |
---|
1874 | (('d ( name ) '= expr ('initial initial-expr)) |
---|
1875 | (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Ainitial>~A</~Ainitial>~%</~Arate>~%" |
---|
1876 | ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix)) |
---|
1877 | |
---|
1878 | (((or 't 'T 'transient) ( name ) '= expr ('onevent event-expr) ('initial initial-expr)) |
---|
1879 | (sprintf "<~Atransient name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Aonevent>~A</~Aonevent>~%<~Ainitial>~A</~Ainitial>~%</~Atransient>~%" |
---|
1880 | ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr event-expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix)) |
---|
1881 | |
---|
1882 | (('reaction ( name ('transitions . transitions) ('conserve conserve) ('initial . initial-expr) ('open . open) ('power power))) |
---|
1883 | (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%<~Ainitial>~A</~Ainitial>~%</~Areaction>~%" |
---|
1884 | ns-prefix name |
---|
1885 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
1886 | ns-prefix (xmlstr power) ns-prefix |
---|
1887 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
1888 | ns-prefix (xmlstr initial-expr) ns-prefix |
---|
1889 | ns-prefix)) |
---|
1890 | |
---|
1891 | (('reaction ( name ('transitions . transitions) ('conserve conserve) ('open . open) ('power power))) |
---|
1892 | (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%" |
---|
1893 | ns-prefix name |
---|
1894 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
1895 | ns-prefix (xmlstr power) ns-prefix |
---|
1896 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
1897 | ns-prefix)) |
---|
1898 | |
---|
1899 | (('reaction ( name ('transitions . transitions) ('open . open) ('power power))) |
---|
1900 | (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%" |
---|
1901 | ns-prefix name |
---|
1902 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
1903 | ns-prefix (xmlstr power) ns-prefix |
---|
1904 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
1905 | ns-prefix)) |
---|
1906 | |
---|
1907 | |
---|
1908 | (('hh-ionic-gate |
---|
1909 | (ion |
---|
1910 | ('initial-m initial-m-expr) |
---|
1911 | ('initial-h initial-h-expr) |
---|
1912 | ('m-power m-power) |
---|
1913 | ('h-power h-power) |
---|
1914 | ('m-inf m-inf-expr) |
---|
1915 | ('m-tau m-tau-expr) |
---|
1916 | ('h-inf h-inf-expr) |
---|
1917 | ('h-tau h-tau-expr) |
---|
1918 | )) |
---|
1919 | |
---|
1920 | (ionic-gate-str ion |
---|
1921 | initial-m-expr: initial-m-expr |
---|
1922 | initial-h-expr: initial-h-expr |
---|
1923 | m-power: m-power |
---|
1924 | h-power: h-power |
---|
1925 | m-inf-expr: m-inf-expr |
---|
1926 | m-tau-expr: m-tau-expr |
---|
1927 | h-inf-expr: h-inf-expr |
---|
1928 | h-tau-expr: h-tau-expr)) |
---|
1929 | |
---|
1930 | |
---|
1931 | (('hh-ionic-gate |
---|
1932 | (ion |
---|
1933 | ('initial-m initial-m-expr) |
---|
1934 | ('m-power m-power) |
---|
1935 | ('h-power h-power) |
---|
1936 | ('m-inf m-inf-expr) |
---|
1937 | ('m-tau m-tau-expr) |
---|
1938 | )) |
---|
1939 | |
---|
1940 | (ionic-gate-str ion |
---|
1941 | initial-m-expr: initial-m-expr |
---|
1942 | m-power: m-power |
---|
1943 | h-power: h-power |
---|
1944 | m-inf-expr: m-inf-expr |
---|
1945 | m-tau-expr: m-tau-expr)) |
---|
1946 | |
---|
1947 | (('hh-ionic-gate |
---|
1948 | (ion |
---|
1949 | ('initial-m initial-m-expr) |
---|
1950 | ('m-power m-power) |
---|
1951 | ('h-power h-power) |
---|
1952 | ('m-tau m-tau-expr) |
---|
1953 | ('m-inf m-inf-expr) |
---|
1954 | )) |
---|
1955 | |
---|
1956 | (ionic-gate-str ion |
---|
1957 | initial-m-expr: initial-m-expr |
---|
1958 | m-power: m-power |
---|
1959 | h-power: h-power |
---|
1960 | m-inf-expr: m-inf-expr |
---|
1961 | m-tau-expr: m-tau-expr)) |
---|
1962 | |
---|
1963 | (('hh-ionic-gate |
---|
1964 | (ion |
---|
1965 | ('initial-m initial-m-expr) |
---|
1966 | ('initial-h initial-h-expr) |
---|
1967 | ('m-power m-power) |
---|
1968 | ('h-power h-power) |
---|
1969 | ('m-alpha m-alpha-expr) |
---|
1970 | ('m-beta m-beta-expr) |
---|
1971 | ('h-alpha h-alpha-expr) |
---|
1972 | ('h-beta h-beta-expr) |
---|
1973 | )) |
---|
1974 | |
---|
1975 | (ionic-gate-str ion |
---|
1976 | initial-m-expr: initial-m-expr |
---|
1977 | initial-h-expr: initial-h-expr |
---|
1978 | m-power: m-power |
---|
1979 | h-power: h-power |
---|
1980 | m-alpha-expr: m-alpha-expr |
---|
1981 | m-beta-expr: m-beta-expr |
---|
1982 | h-alpha-expr: h-alpha-expr |
---|
1983 | h-beta-expr: h-beta-expr)) |
---|
1984 | |
---|
1985 | (('hh-ionic-gate |
---|
1986 | (ion |
---|
1987 | ('initial-m initial-m-expr) |
---|
1988 | ('m-power m-power) |
---|
1989 | ('h-power h-power) |
---|
1990 | ('m-alpha m-alpha-expr) |
---|
1991 | ('m-beta m-beta-expr) |
---|
1992 | )) |
---|
1993 | |
---|
1994 | (ionic-gate-str ion |
---|
1995 | initial-m-expr: initial-m-expr |
---|
1996 | m-power: m-power |
---|
1997 | h-power: h-power |
---|
1998 | m-alpha-expr: m-alpha-expr |
---|
1999 | m-beta-expr: m-beta-expr)) |
---|
2000 | |
---|
2001 | |
---|
2002 | (('component ('type ty) ('name name) . rest) |
---|
2003 | (sprintf "<~Acomponent type=\"~A\" name=\"~A\">~%~A</~Acomponent>~%" |
---|
2004 | ns-prefix ty name (string-concatenate (map entry->surface-xml rest)) ns-prefix )) |
---|
2005 | |
---|
2006 | (('component ('type ty) . rest) |
---|
2007 | (sprintf "<~Acomponent type=\"~A\">~%~A</~Acomponent>~%" |
---|
2008 | ns-prefix ty (string-concatenate (map entry->surface-xml rest)) ns-prefix )) |
---|
2009 | |
---|
2010 | (('component ('name name) '= func decls) |
---|
2011 | (sprintf "<~Acomponent name=\"~A\" functor=\"~A\">~%~A</~Acomponent>~%" |
---|
2012 | ns-prefix name func (string-concatenate (map entry->surface-xml decls)) ns-prefix )) |
---|
2013 | |
---|
2014 | (('functor ('type ty) ('name name) args '= . rest) |
---|
2015 | (sprintf "<~Afunctor type=\"~A\" name=\"~A\">~%~A~%~A</~Afunctor>~%" |
---|
2016 | ns-prefix ty name |
---|
2017 | (string-concatenate (map (lambda (x) (sprintf "<~Aarg>~A</~Aarg>" ns-prefix x ns-prefix)) args)) |
---|
2018 | (string-concatenate (map entry->surface-xml rest)) |
---|
2019 | ns-prefix )) |
---|
2020 | |
---|
2021 | |
---|
2022 | (else (error 'nemo "unknown declaration" x)) |
---|
2023 | |
---|
2024 | ))) |
---|
2025 | )) |
---|
2026 | |
---|
2027 | |
---|
2028 | (define (entry->nineml x . rest) |
---|
2029 | (let-optionals rest ((ns-prefix-str "Biophysics9ML")) |
---|
2030 | |
---|
2031 | (let ((ns-prefix (if (or (not ns-prefix-str) (string-null? ns-prefix-str)) "" |
---|
2032 | (string-append ns-prefix-str ":"))) |
---|
2033 | (xmlstr (lambda (x) (let recur ((x x)) |
---|
2034 | (if (pair? x) (map recur x) |
---|
2035 | (let ((v (string->goodHTML (->string x)))) |
---|
2036 | (if (pair? v) (string-concatenate v) v))) |
---|
2037 | )) |
---|
2038 | )) |
---|
2039 | |
---|
2040 | (let ((unit-str |
---|
2041 | (lambda (u) |
---|
2042 | (or (and u (sprintf "<~Aunit>~A</~Aunit>" ns-prefix u ns-prefix)) ""))) |
---|
2043 | |
---|
2044 | (conserve-str |
---|
2045 | (lambda (e) |
---|
2046 | (match e |
---|
2047 | ((v '= rhs) |
---|
2048 | (sprintf "<~Aconserve val=\"~A\">~%~A </~Aconserve>~%" |
---|
2049 | ns-prefix v (xmlstr rhs) ns-prefix)) |
---|
2050 | (else (error 'conserve-str "invalid conservation equation " e)))) |
---|
2051 | ) |
---|
2052 | |
---|
2053 | (transition-str |
---|
2054 | (lambda (t) |
---|
2055 | (match t |
---|
2056 | (('-> src dst rate) |
---|
2057 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
2058 | ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix)) |
---|
2059 | |
---|
2060 | ((src '-> dst rate) |
---|
2061 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
2062 | ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix)) |
---|
2063 | |
---|
2064 | (('<-> src dst rate1 rate2) |
---|
2065 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
2066 | ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix |
---|
2067 | ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix |
---|
2068 | )) |
---|
2069 | |
---|
2070 | ((src '<-> dst rate1 rate2) |
---|
2071 | (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%" |
---|
2072 | ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix |
---|
2073 | ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix |
---|
2074 | )) |
---|
2075 | |
---|
2076 | (else (error 'transition-str "invalid transition " x)))) |
---|
2077 | ) |
---|
2078 | |
---|
2079 | (ionic-gate-str |
---|
2080 | (lambda (ion #!key |
---|
2081 | (initial-m-expr #f) |
---|
2082 | (initial-h-expr #f) |
---|
2083 | (m-power #f) |
---|
2084 | (h-power #f) |
---|
2085 | (m-inf-expr #f) |
---|
2086 | (m-tau-expr #f) |
---|
2087 | (h-inf-expr #f) |
---|
2088 | (h-tau-expr #f) |
---|
2089 | (m-alpha-expr #f) |
---|
2090 | (m-beta-expr #f) |
---|
2091 | (h-alpha-expr #f) |
---|
2092 | (h-beta-expr #f)) |
---|
2093 | |
---|
2094 | (let ((initial-m-str (or (and initial-m-expr |
---|
2095 | (sprintf "<~Ainitial_m>~A</~Ainitial_m>~%" |
---|
2096 | ns-prefix (xmlstr initial-m-expr) ns-prefix)) "")) |
---|
2097 | (initial-h-str (or (and initial-h-expr |
---|
2098 | (sprintf "<~Ainitial_h>~A</~Ainitial_h>~%" |
---|
2099 | ns-prefix (xmlstr initial-h-expr) ns-prefix)) "")) |
---|
2100 | |
---|
2101 | (m-power-str (or (and m-power |
---|
2102 | (sprintf "<~Am_power>~A</~Am_power>~%" |
---|
2103 | ns-prefix m-power ns-prefix)) "")) |
---|
2104 | (h-power-str (or (and h-power |
---|
2105 | (sprintf "<~Ah_power>~A</~Ah_power>~%" |
---|
2106 | ns-prefix h-power ns-prefix)) "")) |
---|
2107 | |
---|
2108 | (m-inf-str (or (and m-inf-expr |
---|
2109 | (sprintf "<~Am_inf>~A</~Am_inf>~%" |
---|
2110 | ns-prefix (xmlstr m-inf-expr) ns-prefix)) "")) |
---|
2111 | (m-tau-str (or (and m-tau-expr |
---|
2112 | (sprintf "<~Am_tau>~A</~Am_tau>~%" |
---|
2113 | ns-prefix (xmlstr m-tau-expr) ns-prefix)) "")) |
---|
2114 | |
---|
2115 | (h-inf-str (or (and h-inf-expr |
---|
2116 | (sprintf "<~Ah_inf>~A</~Ah_inf>~%" |
---|
2117 | ns-prefix (xmlstr h-inf-expr) ns-prefix)) "")) |
---|
2118 | (h-tau-str (or (and h-tau-expr |
---|
2119 | (sprintf "<~Ah_tau>~A</~Ah_tau>~%" |
---|
2120 | ns-prefix (xmlstr h-tau-expr) ns-prefix)) "")) |
---|
2121 | |
---|
2122 | (m-alpha-str (or (and m-alpha-expr |
---|
2123 | (sprintf "<~Am_alpha>~A</~Am_alpha>~%" |
---|
2124 | ns-prefix (xmlstr m-alpha-expr) ns-prefix)) "")) |
---|
2125 | (m-beta-str (or (and m-beta-expr |
---|
2126 | (sprintf "<~Am_beta>~A</~Am_beta>~%" |
---|
2127 | ns-prefix (xmlstr m-beta-expr) ns-prefix)) "")) |
---|
2128 | |
---|
2129 | (h-alpha-str (or (and h-alpha-expr |
---|
2130 | (sprintf "<~Ah_alpha>~A</~Ah_alpha>~%" |
---|
2131 | ns-prefix (xmlstr h-alpha-expr) ns-prefix)) "")) |
---|
2132 | (h-beta-str (or (and h-beta-expr |
---|
2133 | (sprintf "<~Ah_beta>~A</~Ah_beta>~%" |
---|
2134 | ns-prefix (xmlstr h-beta-expr) ns-prefix)) "")) |
---|
2135 | ) |
---|
2136 | |
---|
2137 | (sprintf "<~Ahh_ionic_gate name=\"~A\">~A</~Ahh_ionic_gate>~%" |
---|
2138 | ns-prefix ion |
---|
2139 | (string-append initial-m-str initial-h-str |
---|
2140 | m-power-str h-power-str m-inf-str |
---|
2141 | m-tau-str h-inf-str h-tau-str |
---|
2142 | m-alpha-str m-beta-str h-alpha-str h-beta-str |
---|
2143 | ) |
---|
2144 | ns-prefix)) |
---|
2145 | ))) |
---|
2146 | |
---|
2147 | (match x |
---|
2148 | (('nemo-model name decls) |
---|
2149 | `(,(sprintf "<NineML xmlns=\"http://nineml.org/9ML/1.0\">~%" ) |
---|
2150 | ,(sprintf "<~ABiophysics xmlns:~A=\"http://www.nineml.org/Biophysics\" name=\"~A\">~%" ns-prefix ns-prefix-str name) |
---|
2151 | ,@(map entry->nineml decls) |
---|
2152 | ,(sprintf "</~ABiophysics>~%" ns-prefix ) |
---|
2153 | ,(sprintf "</NineML>~%"))) |
---|
2154 | |
---|
2155 | (('output . names) |
---|
2156 | (string-concatenate (map (lambda (name) (sprintf "<~AAnalogPort mode='send' name=\"~A\"/>~%" ns-prefix name)) names))) |
---|
2157 | |
---|
2158 | (('input . names) |
---|
2159 | (string-concatenate (map (lambda (name) |
---|
2160 | (match name |
---|
2161 | ((and name (? symbol?)) |
---|
2162 | (sprintf "<~AAnalogPort mode='receive' name=\"~A\"/>~%" ns-prefix name)) |
---|
2163 | |
---|
2164 | (((and name (? symbol?)) ('unit u)) |
---|
2165 | (sprintf "<~AAnalogPort mode='receive' name=\"~A\" unit=\"~A\"/>~%" ns-prefix name u)) |
---|
2166 | |
---|
2167 | ((name 'from ns) |
---|
2168 | (sprintf "<~AAnalogPort mode='receive' name=\"~A\" from=\"~A\"/>~%" ns-prefix name ns)) |
---|
2169 | |
---|
2170 | ((name 'from ns ('unit u)) |
---|
2171 | (sprintf "<~AAnalogPort mode='receive' name=\"~A\" from=\"~A\" unit=\"~A\"/>~%" ns-prefix name ns u)) |
---|
2172 | |
---|
2173 | (else (error 'entry->nineml "invalid input declaration" x)) |
---|
2174 | )) |
---|
2175 | names))) |
---|
2176 | |
---|
2177 | (('const name '= value . rest) |
---|
2178 | (let* ((u (lookup-def 'unit rest))) |
---|
2179 | (if (number? value) |
---|
2180 | (sprintf "<~AParameter name=\"~A\">~%~A<~Avalue>~A</~Avalue>~%</~AParameter>~%" |
---|
2181 | ns-prefix name (unit-str u) ns-prefix value ns-prefix ns-prefix) |
---|
2182 | (sprintf "<~AParameter name=\"~A\">~%~A<~Avalue>~A</~Avalue>~%</~AParameter>~%" |
---|
2183 | ns-prefix name (unit-str u) ns-prefix (xmlstr value) ns-prefix ns-prefix) |
---|
2184 | ))) |
---|
2185 | |
---|
2186 | (((or 'defun 'fun) name args body) |
---|
2187 | (sprintf "<~AAlias name=\"~A\" arguments=\"~A\">~%<~Abody>~A</~Abody>~%</~AAlias>~%" |
---|
2188 | ns-prefix |
---|
2189 | name (string-concatenate (intersperse (map ->string args) ",")) |
---|
2190 | ns-prefix (xmlstr body) ns-prefix ns-prefix)) |
---|
2191 | |
---|
2192 | ((name '= expr . rest) |
---|
2193 | (let ((u (lookup-def 'unit rest))) |
---|
2194 | (sprintf "<~AAssignment name=\"~A\">~A<~Arhs>~A</~Arhs>~%</~AAssignment>~%" |
---|
2195 | ns-prefix name (unit-str u) ns-prefix (xmlstr expr) ns-prefix ns-prefix))) |
---|
2196 | |
---|
2197 | (('d ( name ) '= expr . rest) |
---|
2198 | (let ((u (lookup-def 'unit rest)) |
---|
2199 | (initial-expr (lookup-def 'initial rest))) |
---|
2200 | (if initial-expr |
---|
2201 | (sprintf "<~ATimeDerivative variable=\"~A\">~A<~Arhs>~A</~Arhs>~%<~Ainitial>~A</~Ainitial>~%</~ATimeDerivative>~%" |
---|
2202 | ns-prefix name (unit-str u) ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix) |
---|
2203 | (sprintf "<~ATimeDerivative variable=\"~A\">~A<~Arhs>~A</~Arhs>~%</~ATimeDerivative>~%" |
---|
2204 | ns-prefix name (unit-str u) ns-prefix (xmlstr expr) ns-prefix ns-prefix) |
---|
2205 | ))) |
---|
2206 | |
---|
2207 | (((or 't 'T 'transient) ( name ) '= expr . rest) |
---|
2208 | (let ((u (lookup-def 'unit rest)) |
---|
2209 | (event-expr (lookup-def 'onevent rest)) |
---|
2210 | (initial-expr (lookup-def 'initial rest))) |
---|
2211 | |
---|
2212 | (if (not event-expr) (error 'entry->nineml "invalid transient declaration" x)) |
---|
2213 | |
---|
2214 | (sprintf "<~ATransient variable=\"~A\">~A<~Arhs>~A</~Arhs>~%<~Aonevent>~A</~Aonevent>~%<~Ainitial>~A</~Ainitial>~%</~ATransient>~%" |
---|
2215 | ns-prefix name (unit-str u) ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr event-expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix))) |
---|
2216 | |
---|
2217 | (('reaction ( name . rest)) |
---|
2218 | (let ((u (lookup-def 'unit rest)) |
---|
2219 | (transitions (lookup-def 'transitions rest)) |
---|
2220 | (conserve (lookup-def 'conserve rest)) |
---|
2221 | (initial-expr (lookup-def 'initial rest)) |
---|
2222 | (open (let ((v (lookup-def 'open rest))) |
---|
2223 | (if (symbol? v) (list v) v))) |
---|
2224 | (power (lookup-def 'power rest))) |
---|
2225 | |
---|
2226 | (if (not (and transitions open)) (error 'entry->nineml "invalid reaction declaration" x)) |
---|
2227 | |
---|
2228 | (cond ((and conserve initial-expr power) |
---|
2229 | (sprintf "<~AReaction variable=\"~A\">~A<~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%~A<~Atransitions>~A</~Atransitions>~%<~Ainitial>~A</~Ainitial>~%</~AReaction>~%" |
---|
2230 | ns-prefix name (unit-str u) |
---|
2231 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
2232 | ns-prefix (xmlstr power) ns-prefix |
---|
2233 | (conserve-str (car conserve)) |
---|
2234 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
2235 | ns-prefix (xmlstr initial-expr) ns-prefix |
---|
2236 | ns-prefix)) |
---|
2237 | |
---|
2238 | ((and conserve power) |
---|
2239 | (sprintf "<~AReaction variable=\"~A\">~A<~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%~A<~Atransitions>~A</~Atransitions>~%</~AReaction>~%" |
---|
2240 | ns-prefix name (unit-str u) |
---|
2241 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
2242 | ns-prefix (xmlstr power) ns-prefix |
---|
2243 | (conserve-str (car conserve)) |
---|
2244 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
2245 | ns-prefix)) |
---|
2246 | |
---|
2247 | (power |
---|
2248 | (sprintf "<~AReaction variable=\"~A\">~A<~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~AReaction>~%" |
---|
2249 | ns-prefix name (unit-str u) |
---|
2250 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
2251 | ns-prefix (xmlstr power) ns-prefix |
---|
2252 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
2253 | ns-prefix)) |
---|
2254 | |
---|
2255 | (else |
---|
2256 | (sprintf "<~AReaction variable=\"~A\">~A<~Aopen>~A</~Aopen>~%<~Atransitions>~A</~Atransitions>~%</~AReaction>~%" |
---|
2257 | ns-prefix name (unit-str u) |
---|
2258 | ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix |
---|
2259 | ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix |
---|
2260 | ns-prefix)) |
---|
2261 | ))) |
---|
2262 | |
---|
2263 | |
---|
2264 | (('hh-ionic-gate |
---|
2265 | (ion |
---|
2266 | ('initial-m initial-m-expr) |
---|
2267 | ('initial-h initial-h-expr) |
---|
2268 | ('m-power m-power) |
---|
2269 | ('h-power h-power) |
---|
2270 | ('m-inf m-inf-expr) |
---|
2271 | ('m-tau m-tau-expr) |
---|
2272 | ('h-inf h-inf-expr) |
---|
2273 | ('h-tau h-tau-expr) |
---|
2274 | )) |
---|
2275 | |
---|
2276 | (ionic-gate-str ion |
---|
2277 | initial-m-expr: initial-m-expr |
---|
2278 | initial-h-expr: initial-h-expr |
---|
2279 | m-power: m-power |
---|
2280 | h-power: h-power |
---|
2281 | m-inf-expr: m-inf-expr |
---|
2282 | m-tau-expr: m-tau-expr |
---|
2283 | h-inf-expr: h-inf-expr |
---|
2284 | h-tau-expr: h-tau-expr)) |
---|
2285 | |
---|
2286 | |
---|
2287 | (('hh-ionic-gate |
---|
2288 | (ion |
---|
2289 | ('initial-m initial-m-expr) |
---|
2290 | ('m-power m-power) |
---|
2291 | ('h-power h-power) |
---|
2292 | ('m-inf m-inf-expr) |
---|
2293 | ('m-tau m-tau-expr) |
---|
2294 | )) |
---|
2295 | |
---|
2296 | (ionic-gate-str ion |
---|
2297 | initial-m-expr: initial-m-expr |
---|
2298 | m-power: m-power |
---|
2299 | h-power: h-power |
---|
2300 | m-inf-expr: m-inf-expr |
---|
2301 | m-tau-expr: m-tau-expr)) |
---|
2302 | |
---|
2303 | (('hh-ionic-gate |
---|
2304 | (ion |
---|
2305 | ('initial-m initial-m-expr) |
---|
2306 | ('m-power m-power) |
---|
2307 | ('h-power h-power) |
---|
2308 | ('m-tau m-tau-expr) |
---|
2309 | ('m-inf m-inf-expr) |
---|
2310 | )) |
---|
2311 | |
---|
2312 | (ionic-gate-str ion |
---|
2313 | initial-m-expr: initial-m-expr |
---|
2314 | m-power: m-power |
---|
2315 | h-power: h-power |
---|
2316 | m-inf-expr: m-inf-expr |
---|
2317 | m-tau-expr: m-tau-expr)) |
---|
2318 | |
---|
2319 | (('hh-ionic-gate |
---|
2320 | (ion |
---|
2321 | ('initial-m initial-m-expr) |
---|
2322 | ('initial-h initial-h-expr) |
---|
2323 | ('m-power m-power) |
---|
2324 | ('h-power h-power) |
---|
2325 | ('m-alpha m-alpha-expr) |
---|
2326 | ('m-beta m-beta-expr) |
---|
2327 | ('h-alpha h-alpha-expr) |
---|
2328 | ('h-beta h-beta-expr) |
---|
2329 | )) |
---|
2330 | |
---|
2331 | (ionic-gate-str ion |
---|
2332 | initial-m-expr: initial-m-expr |
---|
2333 | initial-h-expr: initial-h-expr |
---|
2334 | m-power: m-power |
---|
2335 | h-power: h-power |
---|
2336 | m-alpha-expr: m-alpha-expr |
---|
2337 | m-beta-expr: m-beta-expr |
---|
2338 | h-alpha-expr: h-alpha-expr |
---|
2339 | h-beta-expr: h-beta-expr)) |
---|
2340 | |
---|
2341 | (('hh-ionic-gate |
---|
2342 | (ion |
---|
2343 | ('initial-m initial-m-expr) |
---|
2344 | ('m-power m-power) |
---|
2345 | ('h-power h-power) |
---|
2346 | ('m-alpha m-alpha-expr) |
---|
2347 | ('m-beta m-beta-expr) |
---|
2348 | )) |
---|
2349 | |
---|
2350 | (ionic-gate-str ion |
---|
2351 | initial-m-expr: initial-m-expr |
---|
2352 | m-power: m-power |
---|
2353 | h-power: h-power |
---|
2354 | m-alpha-expr: m-alpha-expr |
---|
2355 | m-beta-expr: m-beta-expr)) |
---|
2356 | |
---|
2357 | |
---|
2358 | (('component ('type ty) ('name name) . rest) |
---|
2359 | (sprintf "<~AComponent type=\"~A\" name=\"~A\">~%~A</~AComponent>~%~%" |
---|
2360 | ns-prefix ty name (string-concatenate (map entry->nineml rest)) ns-prefix )) |
---|
2361 | |
---|
2362 | (('component ('type ty) . rest) |
---|
2363 | (sprintf "<~AComponent type=\"~A\">~%~A</~AComponent>~%~%" |
---|
2364 | ns-prefix ty (string-concatenate (map entry->nineml rest)) ns-prefix )) |
---|
2365 | |
---|
2366 | (('component ('name name) '= func decls) |
---|
2367 | (sprintf "<~AComponent name=\"~A\" definition=\"~A\">~%<~Aproperties>~A</~Aproperties></~AComponent>~%~%" |
---|
2368 | ns-prefix name func ns-prefix (string-concatenate (map entry->nineml decls)) ns-prefix ns-prefix )) |
---|
2369 | |
---|
2370 | (('functor ('type ty) ('name name) args '= . rest) |
---|
2371 | (sprintf "<~AComponentClass type=\"~A\" name=\"~A\">~%<~AInterface>~A</~AInterface>~%~A</~AComponentClass>~%~%" |
---|
2372 | ns-prefix ty name |
---|
2373 | ns-prefix (string-concatenate (map (lambda (x) (sprintf "<~AParameter name=\"~A\"/>~%" ns-prefix x)) args)) ns-prefix |
---|
2374 | (string-concatenate (map entry->nineml rest)) |
---|
2375 | ns-prefix )) |
---|
2376 | |
---|
2377 | |
---|
2378 | (else (error 'entry->nineml "unknown declaration" x)) |
---|
2379 | |
---|
2380 | ))) |
---|
2381 | )) |
---|
2382 | |
---|
2383 | |
---|
2384 | (define (partition-model opt decls) |
---|
2385 | |
---|
2386 | (define (update-bkts name decl bkts) |
---|
2387 | (let ((bkt (alist-ref name bkts))) |
---|
2388 | (if bkt |
---|
2389 | (alist-update name (cons decl bkt) bkts) |
---|
2390 | (alist-update name (list decl) bkts) |
---|
2391 | ))) |
---|
2392 | |
---|
2393 | (let recur ((bkts '()) (toplevel '()) (decls decls)) |
---|
2394 | (if (null? decls) |
---|
2395 | (list bkts (reverse toplevel)) |
---|
2396 | (let ((decl (car decls))) |
---|
2397 | (if (opt 'debug) |
---|
2398 | (begin (print "partition-model: decl = ") |
---|
2399 | (pp decl))) |
---|
2400 | (match decl |
---|
2401 | |
---|
2402 | (((or 'component 'COMPONENT) |
---|
2403 | ((or 'type 'TYPE) typ) |
---|
2404 | ((or 'name 'NAME) name) . rest) |
---|
2405 | (recur (update-bkts name decl bkts) |
---|
2406 | toplevel (cdr decls))) |
---|
2407 | |
---|
2408 | (((or 'component 'COMPONENT) |
---|
2409 | ((or 'name 'NAME) name) . rest) |
---|
2410 | (recur (update-bkts name decl bkts) |
---|
2411 | toplevel (cdr decls))) |
---|
2412 | |
---|
2413 | (else (recur bkts (cons decl toplevel) (cdr decls))))) |
---|
2414 | )) |
---|
2415 | ) |
---|
2416 | |
---|
2417 | |
---|
2418 | (define (process-model opt source-path in-format prefix sys model-decls iexpr? parse-expr) |
---|
2419 | |
---|
2420 | (match-let ((($ nemo:quantity 'DISPATCH dis) |
---|
2421 | (hash-table-ref sys (nemo-intern 'dispatch)))) |
---|
2422 | |
---|
2423 | (let* ( |
---|
2424 | (sysname ((lambda (x) (or (and prefix ($ (s+ prefix "_" x))) x)) ((dis 'sysname) sys))) |
---|
2425 | (dirname (pathname-directory source-path)) |
---|
2426 | (plain-fname (make-output-fname dirname sysname ".txt" (opt 'plain) )) |
---|
2427 | (sxml-fname (make-output-fname dirname sysname ".sxml" (opt 'sxml) )) |
---|
2428 | (surface-xml-fname (make-output-fname dirname sysname ".xml" (opt 'surface-xml) )) |
---|
2429 | (nineml-fname (make-output-fname dirname sysname ".9ml" (opt 'surface-nineml) )) |
---|
2430 | (xml-fname (make-output-fname dirname sysname ".xml" (opt 'xml) )) |
---|
2431 | (pyparams-fname (make-output-fname dirname sysname ".py" (opt 'pyparams) )) |
---|
2432 | (mod-fname (make-output-fname dirname sysname ".mod" (opt 'nmodl))) |
---|
2433 | (vclamp-ses-fname (make-output-fname dirname sysname "_vclamp.hoc" (opt 'vclamp-hoc) )) |
---|
2434 | (vclamp-octave-fname (make-output-fname dirname sysname "_vclamp.m" (opt 'vclamp-octave) )) |
---|
2435 | (iclamp-ses-fname (make-output-fname dirname sysname "_iclamp.hoc" (opt 'iclamp-hoc) )) |
---|
2436 | (iclamp-sli-fname (make-output-fname dirname sysname "_iclamp.sli" (opt 'iclamp-nest) )) |
---|
2437 | |
---|
2438 | (pyparams (opt 'pyparams)) |
---|
2439 | (nest (and nemo-nest? (opt 'nest))) |
---|
2440 | (matlab (opt 'matlab)) |
---|
2441 | (octave (opt 'octave)) |
---|
2442 | (vclamp-hoc (opt 'vclamp-hoc)) |
---|
2443 | (vclamp-octave (opt 'vclamp-octave)) |
---|
2444 | (iclamp-hoc (opt 'iclamp-hoc)) |
---|
2445 | (iclamp-nest (opt 'iclamp-nest)) |
---|
2446 | |
---|
2447 | (nmodl-method |
---|
2448 | (let ((method (or ($ (opt 'nmodl-method) ) (defopt 'nmodl-method)))) |
---|
2449 | (case method |
---|
2450 | ((adams runge euler adeuler heun adrunge gear |
---|
2451 | newton simplex simeq seidel sparse derivimplicit cnexp clsoda |
---|
2452 | after_cvode cvode_t cvode_t_v expeuler #f) method) |
---|
2453 | (else (error "unknown NMODL method " method))))) |
---|
2454 | |
---|
2455 | (octave-method |
---|
2456 | (let ((method ($ (opt 'octave-method) ))) |
---|
2457 | (case method |
---|
2458 | ((cvode lsode odepkg ode2r ode5r odesx oders) method) |
---|
2459 | ((#f) 'lsode) |
---|
2460 | (else (error "unknown Octave method " method))))) |
---|
2461 | |
---|
2462 | (nest-method |
---|
2463 | (and nemo-nest? |
---|
2464 | (let ((method ($ (opt 'nest-method) ))) |
---|
2465 | (case method |
---|
2466 | ((cvode ida gsl #f) method) |
---|
2467 | (else (error "unknown NEST method " method)))))) |
---|
2468 | |
---|
2469 | (nest-ss-method |
---|
2470 | (and nemo-nest? |
---|
2471 | (let ((method ($ (opt 'nest-ss-method) ))) |
---|
2472 | (case method |
---|
2473 | ((gsl kinsol #f) method) |
---|
2474 | (else (error "unknown NEST steady state solving method " method)))))) |
---|
2475 | |
---|
2476 | (nest-abstol |
---|
2477 | (and nemo-nest? |
---|
2478 | (opt 'nest-abstol))) |
---|
2479 | |
---|
2480 | (nest-reltol |
---|
2481 | (and nemo-nest? |
---|
2482 | (opt 'nest-reltol))) |
---|
2483 | |
---|
2484 | (nest-maxstep |
---|
2485 | (and nemo-nest? |
---|
2486 | (opt 'nest-maxstep))) |
---|
2487 | |
---|
2488 | (parse-expr (case in-format |
---|
2489 | ((sxml xml nineml) identity) |
---|
2490 | ((sexp) identity) |
---|
2491 | ((ixml) (lambda (x #!optional loc) |
---|
2492 | (let ((xs (if (string? x) x |
---|
2493 | (string-concatenate |
---|
2494 | (map (lambda (el) |
---|
2495 | (if (string? el) el |
---|
2496 | (if (equal? el '(divide)) " / " |
---|
2497 | (->string el)))) |
---|
2498 | x))))) |
---|
2499 | (nemo:parse-string-expr xs loc)))) |
---|
2500 | ((nemo) (if iexpr? |
---|
2501 | (lambda (x #!optional loc) |
---|
2502 | (if (string? x) (nemo:parse-string-expr x loc) |
---|
2503 | (nemo:parse-sym-expr x loc))) |
---|
2504 | nemo:parse-sym-expr)) |
---|
2505 | (else (error 'nemo "unknown input format" in-format)))) |
---|
2506 | |
---|
2507 | ) |
---|
2508 | |
---|
2509 | (if (or (and xml-fname surface-xml-fname) |
---|
2510 | (and xml-fname nineml-fname) |
---|
2511 | (and nineml-fname surface-xml-fname)) |
---|
2512 | (error 'nemo "only one of --xml, --surface-xml, and --nineml options are permitted")) |
---|
2513 | |
---|
2514 | (if plain-fname |
---|
2515 | (with-output-to-file plain-fname |
---|
2516 | (lambda () (pretty-print (model->text sys parse-expr))))) |
---|
2517 | |
---|
2518 | (if sxml-fname |
---|
2519 | (with-output-to-file sxml-fname |
---|
2520 | (lambda () (pretty-print (model->ncml sys parse-expr))))) |
---|
2521 | |
---|
2522 | (if xml-fname |
---|
2523 | (let* ((doc (model->ncml sys parse-expr)) |
---|
2524 | (doc1 (ensure-xmlns |
---|
2525 | (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc))) |
---|
2526 | (else doc))))) |
---|
2527 | (with-output-to-file xml-fname |
---|
2528 | (lambda () (print-fragments (generate-XML `(begin ,doc1))))))) |
---|
2529 | |
---|
2530 | (if surface-xml-fname |
---|
2531 | (with-output-to-file surface-xml-fname |
---|
2532 | (lambda () (print-fragments (map entry->surface-xml model-decls))))) |
---|
2533 | |
---|
2534 | (if nineml-fname |
---|
2535 | (with-output-to-file nineml-fname |
---|
2536 | (lambda () (print-fragments (entry->nineml `(nemo-model ,sysname ,model-decls)))))) |
---|
2537 | |
---|
2538 | (if mod-fname |
---|
2539 | (with-output-to-file |
---|
2540 | mod-fname (lambda () |
---|
2541 | (model->nmodl |
---|
2542 | `( |
---|
2543 | (method . ,nmodl-method) |
---|
2544 | (kinetic . ,(opt 'nmodl-kinetic)) |
---|
2545 | (dump-template-env . ,(opt 'dump-template-env)) |
---|
2546 | ) |
---|
2547 | sys)))) |
---|
2548 | |
---|
2549 | (if octave (model->octave `((filename . ,(or (and (string? octave) (pathname-file octave)) octave)) |
---|
2550 | (dirname . ,(or (and (string? octave) (pathname-directory octave)) dirname)) |
---|
2551 | ) |
---|
2552 | sys)) |
---|
2553 | |
---|
2554 | (if matlab (model->matlab `((dirname . ,(or (and (string? matlab) matlab) dirname))) sys)) |
---|
2555 | |
---|
2556 | (if pyparams |
---|
2557 | (model->pyparams `((filename . ,pyparams-fname) |
---|
2558 | (mode . ,(if (opt 'partition) 'single 'multiple))) |
---|
2559 | sys)) |
---|
2560 | |
---|
2561 | |
---|
2562 | (if (and nemo-nest? nest) |
---|
2563 | (model->nest `((dirname . ,(or (and (string? nest) nest) dirname)) |
---|
2564 | (method . ,nest-method) |
---|
2565 | (ss-method . ,nest-ss-method) |
---|
2566 | (abstol . ,nest-abstol) |
---|
2567 | (reltol . ,nest-reltol) |
---|
2568 | (maxstep . ,nest-maxstep) |
---|
2569 | (dump-template-env . ,(opt 'dump-template-env)) |
---|
2570 | ) |
---|
2571 | sys)) |
---|
2572 | |
---|
2573 | (if vclamp-hoc (model->vclamp-hoc `((filename . ,vclamp-ses-fname) |
---|
2574 | |
---|
2575 | ) |
---|
2576 | sys)) |
---|
2577 | |
---|
2578 | (if vclamp-octave (model->vclamp-octave `((filename . ,vclamp-octave-fname) |
---|
2579 | (octave-method . ,(case octave-method |
---|
2580 | ((odepkg) 'ode2r) |
---|
2581 | (else octave-method))) |
---|
2582 | ) |
---|
2583 | sys)) |
---|
2584 | |
---|
2585 | (if iclamp-hoc (model->iclamp-hoc `((filename . ,iclamp-ses-fname) |
---|
2586 | ) |
---|
2587 | sys)) |
---|
2588 | |
---|
2589 | (if iclamp-nest (model->iclamp-nest `((filename . ,iclamp-sli-fname) |
---|
2590 | ) |
---|
2591 | sys)) |
---|
2592 | )) |
---|
2593 | ) |
---|
2594 | |
---|
2595 | |
---|
2596 | |
---|
2597 | (define (process-template model-name template-name template-args template-out user-templates source-path) |
---|
2598 | |
---|
2599 | (let ( |
---|
2600 | (template-vars (cons (cons 'model_name |
---|
2601 | (ersatz:Tstr (->string model-name)) ) |
---|
2602 | (map (lambda (x) |
---|
2603 | (let ((kv (string-split x "="))) |
---|
2604 | (cons ($ (car kv)) |
---|
2605 | (ersatz:Tstr (cadr kv))))) |
---|
2606 | template-args))) |
---|
2607 | ) |
---|
2608 | |
---|
2609 | (let* ((dirname (pathname-directory source-path)) |
---|
2610 | (output-name (if (string-prefix? "." template-out) |
---|
2611 | (make-pathname dirname (s+ model-name template-out)) |
---|
2612 | (make-pathname dirname (s+ model-name "_" template-out)) ))) |
---|
2613 | (with-output-to-file output-name |
---|
2614 | (lambda () (instantiate-template* user-templates template-name template-vars)) |
---|
2615 | )) |
---|
2616 | )) |
---|
2617 | |
---|
2618 | |
---|
2619 | |
---|
2620 | (define (detect-xml-type doc) |
---|
2621 | (let* ( |
---|
2622 | (ncml:model ((lambda (x) |
---|
2623 | (and (not (null? x)) (car x))) |
---|
2624 | (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc)))) |
---|
2625 | (nineml:biophys ((lambda (x) |
---|
2626 | (and (not (null? x)) (car x))) |
---|
2627 | (ncml:sxpath '(// nmlb:Biophysics) `(*TOP* . ,doc)))) |
---|
2628 | (membraneprops (ncml:sxpath '(// cell biophysicalProperties membraneProperties) |
---|
2629 | `(*TOP* . ,ncml:model))) |
---|
2630 | ) |
---|
2631 | (cond (nineml:biophys 'nineml) |
---|
2632 | (membraneprops 'ixml) |
---|
2633 | (else 'xml)) |
---|
2634 | )) |
---|
2635 | |
---|
2636 | |
---|
2637 | (define (model-source->model source-path in-format model-name model-decls user-templates iexpr parse-expr) |
---|
2638 | |
---|
2639 | (case in-format |
---|
2640 | ((sxml xml ixml nineml) |
---|
2641 | (SingleModel source-path in-format model-name |
---|
2642 | (ncml-model-decls->model |
---|
2643 | `((hh-markov . ,(opt 'hh-markov)) |
---|
2644 | (parse-expr . ,parse-expr)) |
---|
2645 | model-name model-decls) |
---|
2646 | model-decls user-templates iexpr parse-expr)) |
---|
2647 | |
---|
2648 | ((sexp nemo) |
---|
2649 | (SingleModel source-path in-format model-name |
---|
2650 | (sexp-model-decls->model |
---|
2651 | `((hh-markov . ,(opt 'hh-markov))) |
---|
2652 | model-name model-decls parse-expr) |
---|
2653 | model-decls user-templates iexpr parse-expr)) |
---|
2654 | |
---|
2655 | (else (error 'nemo "invalid input format")) |
---|
2656 | )) |
---|
2657 | |
---|
2658 | |
---|
2659 | (define (model-source->model-parts opt source-path in-format |
---|
2660 | model-name model-decls |
---|
2661 | user-templates iexpr parse-expr) |
---|
2662 | (let ((pmodels (partition-model opt model-decls))) |
---|
2663 | (if (opt 'debug) |
---|
2664 | (begin (print "length pmodels = " (length pmodels)) |
---|
2665 | (print "pmodels = " ) |
---|
2666 | (pp pmodels))) |
---|
2667 | (let ((model-parts |
---|
2668 | (match-let (((bkts toplevel) pmodels)) |
---|
2669 | (map (lambda (bkt) |
---|
2670 | (let ((part-decls (append toplevel (cdr bkt))) |
---|
2671 | (part-name (car bkt))) |
---|
2672 | |
---|
2673 | (case in-format |
---|
2674 | ((sxml xml ixml nineml) |
---|
2675 | (ModelPart source-path in-format model-name part-name |
---|
2676 | (ncml-model-decls->model |
---|
2677 | `((hh-markov . ,(opt 'hh-markov)) |
---|
2678 | (parse-expr . ,parse-expr)) |
---|
2679 | ($ (s+ model-name "_" (car bkt))) part-decls) |
---|
2680 | part-decls model-decls user-templates iexpr parse-expr) |
---|
2681 | ) |
---|
2682 | |
---|
2683 | ((sexp nemo) |
---|
2684 | (ModelPart source-path in-format model-name part-name |
---|
2685 | (sexp-model-decls->model |
---|
2686 | `((hh-markov . ,(opt 'hh-markov))) |
---|
2687 | ($ (s+ model-name "_" (car bkt))) part-decls parse-expr) |
---|
2688 | part-decls model-decls user-templates iexpr parse-expr) |
---|
2689 | ) |
---|
2690 | |
---|
2691 | (else (error 'nemo "invalid input format" in-format)) |
---|
2692 | ))) |
---|
2693 | bkts)) |
---|
2694 | )) |
---|
2695 | model-parts |
---|
2696 | ))) |
---|
2697 | |
---|
2698 | |
---|
2699 | |
---|
2700 | (define (main opt operands) |
---|
2701 | |
---|
2702 | (if (opt 'version) |
---|
2703 | (begin |
---|
2704 | (print (nemo:version-string)) |
---|
2705 | (exit 0))) |
---|
2706 | |
---|
2707 | (let ((v (opt 'default-units))) |
---|
2708 | (if v |
---|
2709 | (nemo:default-units (fold (lambda (x ax) (alist-update (car x) (cdr x) ax)) |
---|
2710 | (nemo:default-units) v)) |
---|
2711 | )) |
---|
2712 | |
---|
2713 | (if (opt 'print-default-units) |
---|
2714 | (begin |
---|
2715 | (for-each (lambda (x) |
---|
2716 | (printf "~A: ~A~%" (nemo:quantity-name (car x)) (cdr x))) |
---|
2717 | (nemo:default-units)))) |
---|
2718 | |
---|
2719 | (if (opt 'debug) |
---|
2720 | (nemo:fetch-verbose #t)) |
---|
2721 | |
---|
2722 | (if (null? operands) |
---|
2723 | |
---|
2724 | (nemo:usage) |
---|
2725 | |
---|
2726 | (let* ( |
---|
2727 | (model-sources |
---|
2728 | (map (lambda (operand) |
---|
2729 | (let* ((read-xml (lambda (name) |
---|
2730 | (call-with-input-file name |
---|
2731 | (lambda (port) |
---|
2732 | (ssax:xml->sxml port |
---|
2733 | '((ncml . "ncml") |
---|
2734 | (nmlb . "http://www.nineml.org/Biophysics"))) |
---|
2735 | )) |
---|
2736 | )) |
---|
2737 | (read-sexp (lambda (name) (call-with-input-file name read))) |
---|
2738 | (read-iexpr (lambda (name) (call-with-input-file name |
---|
2739 | (lambda (port) |
---|
2740 | (let ((content |
---|
2741 | (iexpr:tree->list |
---|
2742 | (iexpr:parse operand port)))) |
---|
2743 | (car content)))))) |
---|
2744 | |
---|
2745 | (in-format (cond ((opt 'input-format) => |
---|
2746 | (lambda (x) |
---|
2747 | (case ($ x) |
---|
2748 | ((nemo) 'nemo) |
---|
2749 | ((s-exp sexp) 'sexp) |
---|
2750 | ((xml) 'xml) |
---|
2751 | ((ixml) 'ixml) |
---|
2752 | ((sxml) 'sxml) |
---|
2753 | ((9ml 9ML nineml) 'nineml) |
---|
2754 | (else (error 'nemo "unknown input format" x))))) |
---|
2755 | (else (case ((lambda (x) (or (not x) ($ x))) |
---|
2756 | (pathname-extension operand)) |
---|
2757 | ((s-exp sexp) 'sexp) |
---|
2758 | ((sxml) 'sxml) |
---|
2759 | ((xml 9ml 9ML nineml) (detect-xml-type (read-xml operand))) |
---|
2760 | (else 'nemo))))) |
---|
2761 | |
---|
2762 | (doc.iexpr (case in-format |
---|
2763 | ((nemo) |
---|
2764 | (let ((content (read-sexp operand))) |
---|
2765 | (if (eq? content 'nemo-model) |
---|
2766 | (cons (read-iexpr operand) #t) |
---|
2767 | (cons content #f)))) |
---|
2768 | ((sxml sexp) |
---|
2769 | (cons (read-sexp operand) #f)) |
---|
2770 | ((xml ixml nineml) |
---|
2771 | (cons (read-xml operand) #f)) |
---|
2772 | (else (error 'nemo "unknown input format" in-format)))) |
---|
2773 | |
---|
2774 | (dd (if (opt 'debug) |
---|
2775 | (pp (car doc.iexpr)))) |
---|
2776 | |
---|
2777 | (parse-expr (case in-format |
---|
2778 | ((sxml sexp) identity) |
---|
2779 | ((nemo) (if (cdr doc.iexpr) |
---|
2780 | (lambda (x #!optional loc) |
---|
2781 | (if (string? x) (nemo:parse-string-expr x loc) |
---|
2782 | (nemo:parse-sym-expr x loc))) |
---|
2783 | nemo:parse-sym-expr)) |
---|
2784 | ((xml) (lambda (x #!optional loc) |
---|
2785 | (ncml-expr->expr x))) |
---|
2786 | ((ixml nineml) (lambda (x #!optional loc) |
---|
2787 | (nemo:parse-string-expr x loc))) |
---|
2788 | (else (error 'nemo "unknown input format" in-format)))) |
---|
2789 | |
---|
2790 | (model-name.model-decls |
---|
2791 | (case in-format |
---|
2792 | ((nineml) (nineml->model-decls |
---|
2793 | `((parse-expr . ,parse-expr) |
---|
2794 | (debug . ,(opt 'debug) ) |
---|
2795 | (source-path . ,operand) |
---|
2796 | ) |
---|
2797 | (car doc.iexpr))) |
---|
2798 | ((sxml xml ixml) (ncml->model-decls |
---|
2799 | `((parse-expr . ,parse-expr) |
---|
2800 | (debug . ,(opt 'debug) ) |
---|
2801 | (source-path . ,operand) |
---|
2802 | ) |
---|
2803 | (car doc.iexpr))) |
---|
2804 | ((sexp nemo) (sexp->model-decls (car doc.iexpr))) |
---|
2805 | (else (error 'nemo "unknown input format" in-format)))) |
---|
2806 | |
---|
2807 | ) |
---|
2808 | |
---|
2809 | (ModelSource operand in-format |
---|
2810 | (car model-name.model-decls) |
---|
2811 | (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls)) |
---|
2812 | (match model-name.model-decls |
---|
2813 | ((_ _ user-templates) |
---|
2814 | user-templates) |
---|
2815 | (else '())) |
---|
2816 | (cdr doc.iexpr) |
---|
2817 | parse-expr) |
---|
2818 | )) |
---|
2819 | operands)) |
---|
2820 | |
---|
2821 | (models |
---|
2822 | (if (opt 'partition) |
---|
2823 | |
---|
2824 | (let recur ((srcs model-sources) (ax '())) |
---|
2825 | (if (null? srcs) ax |
---|
2826 | (let ((src (car srcs))) |
---|
2827 | (cases nemo:model src |
---|
2828 | |
---|
2829 | (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr) |
---|
2830 | (recur (cdr srcs) |
---|
2831 | (append (model-source->model-parts opt source-path in-format |
---|
2832 | model-name model-decls |
---|
2833 | user-templates iexpr parse-expr) ax))) |
---|
2834 | |
---|
2835 | (else (error 'nemo "invalid model source" src))) |
---|
2836 | ))) |
---|
2837 | |
---|
2838 | (map (lambda (x) |
---|
2839 | (cases nemo:model x |
---|
2840 | |
---|
2841 | (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr) |
---|
2842 | (model-source->model source-path in-format model-name |
---|
2843 | model-decls user-templates iexpr parse-expr)) |
---|
2844 | |
---|
2845 | |
---|
2846 | (else (error 'name "invalid model source" x)))) |
---|
2847 | |
---|
2848 | model-sources)) |
---|
2849 | ) |
---|
2850 | ) |
---|
2851 | |
---|
2852 | |
---|
2853 | (let ((template-insts (opt 'template))) |
---|
2854 | |
---|
2855 | (for-each |
---|
2856 | |
---|
2857 | (lambda (model) |
---|
2858 | |
---|
2859 | (cases nemo:model model |
---|
2860 | |
---|
2861 | (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr) |
---|
2862 | |
---|
2863 | (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr) |
---|
2864 | |
---|
2865 | (if template-insts |
---|
2866 | (for-each |
---|
2867 | (lambda (template-inst) |
---|
2868 | (match-let (((template-name . template-args) |
---|
2869 | (string-split template-inst ":"))) |
---|
2870 | (let ((output-file-suffix (or (opt 'template-prefix) template-name))) |
---|
2871 | (process-template model-name template-name template-args |
---|
2872 | output-file-suffix user-templates source-path)) |
---|
2873 | )) |
---|
2874 | template-insts)) |
---|
2875 | ) |
---|
2876 | |
---|
2877 | |
---|
2878 | (ModelPart (source-path in-format model-name part-name sys model-decls parent-decls user-templates iexpr? parse-expr) |
---|
2879 | |
---|
2880 | (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr) |
---|
2881 | |
---|
2882 | (if template-insts |
---|
2883 | (for-each |
---|
2884 | (lambda (template-inst) |
---|
2885 | (match-let (((template-name . template-args) |
---|
2886 | (string-split template-inst ":"))) |
---|
2887 | (let ((output-file-suffix (or (opt 'template-prefix) template-name))) |
---|
2888 | (process-template (s+ model-name "_" part-name) |
---|
2889 | template-name template-args |
---|
2890 | output-file-suffix user-templates source-path)) |
---|
2891 | )) |
---|
2892 | template-insts)) |
---|
2893 | ) |
---|
2894 | |
---|
2895 | (else (error 'nemo "invalid model" model)))) |
---|
2896 | |
---|
2897 | models)) |
---|
2898 | ) |
---|
2899 | )) |
---|
2900 | |
---|
2901 | |
---|
2902 | (main opt (opt '@)) |
---|
2903 | |
---|