Context Navigation

source: project/release/4/nemo/trunk/nemo.scm @ 25870

Last change on this file since 25870 was 25870, checked in by Ivan Raikov, 9 years ago
nemo: updated copyright year
File size: 33.8 KB

Line
1	;;
2	;; NEMO
3	;;
4	;; Copyright 2008-2012 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 scheme chicken srfi-1)
22
23	(require-extension nemo-core nemo-macros nemo-hh nemo-vclamp)
24	(require-extension matchable ssax sxml-transforms sxpath sxpath-lolevel
25	environments getopt-long)
26
27	(define nemo-nmodl? (extension-information 'nemo-nmodl))
28	(define nemo-matlab? (extension-information 'nemo-matlab))
29	(define nemo-nest? (extension-information 'nemo-nest))
30	(define nemo-pyparams? (extension-information 'nemo-pyparams))
31
32	(if nemo-nmodl? (use nemo-nmodl))
33	(if nemo-matlab? (use nemo-matlab))
34	(if nemo-nest? (use nemo-nest))
35	(if nemo-pyparams? (use nemo-pyparams))
36
37	(define (lookup-def k lst . rest)
38	(let-optionals rest ((default #f))
39	(let ((kv (assoc k lst)))
40	(if (not kv) default
41	(match kv ((k v) v) (else (cdr kv)))))))
42
43	(define ($ x) (and x (string->symbol (->string x))))
44
45	;;; Procedures for string concatenation and pretty-printing
46
47	(define (s+ . lst) (string-concatenate (map ->string lst)))
48	(define (sw+ lst) (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
49	(define (s\ p . lst) (string-intersperse (map ->string lst) p))
50	(define (sl\ p lst) (string-intersperse (map ->string lst) p))
51	(define nl "\n")
52
53
54	(define (warn port message . specialising-msgs)
55	(print-error-message message (current-output-port) "Warning")
56	(print (string-concatenate (map ->string specialising-msgs))))
57
58	;;; Error procedure for the XML parser
59
60	(define (parser-error port message . specialising-msgs)
61	(error (string-append message (string-concatenate (map ->string specialising-msgs)))))
62
63	(define ssax:warn warn)
64
65	(define opt-defaults
66	`(
67	(nmodl-kinetic . all)
68	))
69
70	(define (defopt x)
71	(lookup-def x opt-defaults))
72
73	(define opt-grammar
74	`(
75	(input-format
76	"specify input format (nemo, xml, sxml, s-exp)"
77	(single-char #\i)
78	(value (required FORMAT)
79	(transformer ,string->symbol)))
80
81	(xml
82	"write XML output to file (default: <model-name>.xml)"
83	(value (optional FILENAME)
84	))
85
86	(sxml
87	"write SXML output to file (default: <model-name>.sxml)"
88	(value (optional FILENAME)
89	))
90
91	(hh-markov
92	"convert HH rate equations to Markov chain form")
93
94	,@(if nemo-nest?
95	`(
96	(nest
97	"write NEST output to given file (default: <model-name>.cpp)"
98	(value (optional FILENAME)))
99
100	)
101	`())
102
103	,@(if nemo-pyparams?
104	`(
105	(pyparams
106	"write Python representation of parameters to given file (default: <model-name>.py)"
107	(value (optional FILENAME)))
108	)
109	`())
110
111	,@(if nemo-matlab?
112	`((matlab
113	"write MATLAB output")
114
115	(octave
116	"write Octave output to given file (default: <model-name>.m)"
117	(value (optional FILENAME)))
118
119	(octave-method
120	"specify Octave integration method (lsode or odepkg)"
121	(value (required METHOD)
122	(transformer ,string->symbol)))
123	)
124	`())
125
126	,@(if nemo-nmodl?
127	`(
128	(nmodl "write NMODL output to file (default: <model-name>.mod)"
129	(value (optional FILENAME)))
130
131	(nmodl-kinetic ,(s+ "use NMODL kinetic equations for the given reactions "
132	"(or for all reactions)")
133	(value (optional STATES)
134	(default ,(defopt 'nmodl-kinetic))
135	(transformer
136	,(lambda (x)
137	(if (string=? x "all") 'all
138	(map string->symbol (string-split x ",")))))))
139
140	(nmodl-method "specify NMODL integration method"
141	(value (required METHOD)
142	(transformer ,string->symbol)))
143
144	(nmodl-depend "specify DEPEND variables for NMODL interpolation tables"
145	(value (required VARS)
146	(transformer
147	,(lambda (x)
148	(map string->symbol (string-split x ","))))))
149
150	)
151	`())
152
153	(vclamp-hoc
154	"write voltage clamp scripts to HOC file (default: <model-name>.(ses\|hoc))"
155	(value (optional FILENAME)
156	))
157
158	(vclamp-octave
159	"write voltage clamp script to Octave file (default: <model-name>_vclamp.m)"
160	(value (optional FILENAME)
161	))
162
163	(t "use interpolation tables in generated code, if possible")
164
165	(help (single-char #\h))
166
167
168	))
169
170
171	;; Use args:usage to generate a formatted list of options (from OPTS),
172	;; suitable for embedding into help text.
173	(define (nemo:usage)
174	(print "Usage: " (car (argv)) " <list of files to be processed> [options...] ")
175	(newline)
176	(print "The following options are recognized: ")
177	(newline)
178	(print (parameterize ((indent 5) (width 30)) (usage opt-grammar)))
179	(exit 1))
180
181
182	;; Process arguments and collate options and arguments into OPTIONS
183	;; alist, and operands (filenames) into OPERANDS. You can handle
184	;; options as they are processed, or afterwards.
185
186	(define opts (getopt-long (command-line-arguments) opt-grammar))
187	(define opt (make-option-dispatch opts opt-grammar))
188
189
190	(define (ncml:sxpath query doc)
191	((sxpath query '((ncml . "ncml"))) doc))
192
193	(define (ncml:car-sxpath query doc)
194	(let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
195	(car lst)))
196
197	(define (ncml:if-car-sxpath query doc)
198	(let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
199	(and (not (null? lst)) (car lst))))
200
201	(define (ncml:if-sxpath query doc)
202	(let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
203	(and (not (null? lst)) lst)))
204
205	(define (ncml-binding->binding node)
206	(match node
207	(('ncml:bnd ('@ ('id id)) ('ncml:expr expr))
208	`(,($ id) ,(ncml-expr->expr expr)))
209	(else (error 'ncml-binding->binding "invalid binding " node))))
210
211	(define (ncml-expr->expr node)
212	(match node
213	((? number?) node)
214	((? string?) (sxml:number node))
215	(('ncml:id id) ($ id))
216	(('ncml:apply ('@ ('id id)) . args) (cons ($ id) (map ncml-expr->expr args)))
217	(('ncml:let ('ncml:bnds . bnds) ('ncml:expr body))
218	`(let ,(map ncml-binding->binding bnds) ,(ncml-expr->expr body)))
219	(((and op (? symbol?)) . args)
220	(cons (ncml-op->op op) (map ncml-expr->expr args)))
221	(else (error 'ncml-expr->expr "unknown expression " node))))
222
223
224	(define (ncml-op->op op)
225	(case op
226	((ncml:sum) '+)
227	((ncml:sub) '-)
228	((ncml:mul) '*)
229	((ncml:div) '/)
230	((ncml:gt) '>)
231	((ncml:lt) '<)
232	((ncml:lte) '<=)
233	((ncml:gte) '>=)
234	((ncml:eq) '=)
235	(else (match (string-split (->string op) ":")
236	((pre op) (string->symbol op))
237	(else (error 'ncml-op->op "invalid operator" op))))))
238
239
240	(define (nemo-constructor name declarations parse-expr)
241	(let* ((nemo (make-nemo-core))
242	(sys ((nemo 'system) name))
243	(qs (eval-nemo-system-decls nemo name sys declarations parse-expr)))
244	(list sys nemo qs)))
245
246	(define (sexp->model options doc parse-expr)
247	(match doc
248	(('nemo-model model-name model-decls)
249	(let* ((model+nemo (nemo-constructor model-name model-decls parse-expr))
250	(model (first model+nemo))
251	(nemo (second model+nemo)))
252	(let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) parse-expr)))
253	(if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
254	(if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))
255	(if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
256	(if (assoc 'components options)
257	(for-each (lambda (x)
258	(print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
259	(print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
260	((nemo 'components) model-1)))
261	model-1)))
262	(else (error 'sexp->model "unknown model format"))))
263
264	(define model->nmodl
265	(if nemo-nmodl?
266	(lambda (options model)
267	(nemo:nmodl-translator model (lookup-def 'method options) (lookup-def 'table options)
268	-150 150 1 (lookup-def 'depend options)
269	(lookup-def 'kinetic options) ))
270	(lambda (options model)
271	(void))))
272
273	(define models->pyparams
274	(if nemo-pyparams?
275	(lambda (options models)
276	(nemo:pyparams-translator models (lookup-def 'filename options)))
277	(lambda (options model)
278	(void))))
279
280	(define model->nest
281	(if nemo-nest?
282	(lambda (options model)
283	(nemo:nest-translator model (lookup-def 'filename options)))
284	(lambda (options model)
285	(void))))
286
287	(define model->matlab
288	(if nemo-matlab?
289	(lambda (options model)
290	(nemo:matlab-translator model))
291	(lambda (options model)
292	(void))))
293
294	(define model->vclamp-hoc
295	(lambda (options model)
296	(nemo:vclamp-translator model 'hoc (lookup-def 'filename options))))
297
298	(define model->vclamp-octave
299	(lambda (options model)
300	(nemo:vclamp-translator model 'matlab (lookup-def 'filename options))))
301
302	(define model->octave
303	(if nemo-matlab?
304	(lambda (options model)
305	(nemo:octave-translator model
306	(lookup-def 'method options)
307	(lookup-def 'filename options)))
308	(lambda (options model)
309	(void))))
310
311
312	(define (transition->ncml-transition x)
313	(match x
314	(('-> src dst rate)
315	`((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate)))))
316	((src '-> dst rate)
317	`((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate)))))
318	(('<-> src dst rate1 rate2)
319	`((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate1)))
320	(ncml:transition (@ (src ,dst) (dst ,src)) (ncml:rate ,(expr->ncml-expr rate2)))))
321	((src '<-> dst rate1 rate2)
322	`((ncml:transition (@ (src ,src) (dst ,dst)) (ncml:rate ,(expr->ncml-expr rate1)))
323	(ncml:transition (@ (src ,dst) (dst ,src)) (ncml:rate ,(expr->ncml-expr rate2)))))
324	(else (error 'transition->ncml-transition "invalid transition " x))))
325
326	(define (conseq->ncml-conseq parse-expr)
327	(lambda (x)
328	(match x
329	(((and i (? integer?)) '= rhs)
330	`(ncml:conseq (@ (val ,(->string i)))
331	(ncml:expr ,(expr->ncml-expr (parse-expr rhs)))))
332	(else (error 'conseq->ncml-conseq "invalid linear equation " x)))))
333
334	(define builtin-fns
335	`(+ - * / pow neg abs atan asin acos sin cos exp ln
336	sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
337	> < <= >= = and or round ceiling floor max min))
338
339	(define (binding->ncml-binding bnd)
340	(match bnd
341	((id expr) `(ncml:bnd (@ (id ,id)) (ncml:expr ,(expr->ncml-expr expr))))
342	(else (error 'binding->ncml-binding "invalid binding " bnd))))
343
344	(define (expr->ncml-expr x)
345	(match x
346	((? number?) x)
347	((? symbol?) `(ncml:id ,x))
348	(('let bnds expr)
349	`(ncml:let (ncml:bnds . ,(map binding->ncml-binding bnds))
350	(ncml:expr ,(expr->ncml-expr expr))))
351	(((and op (? symbol?)) . args)
352	(let ((ncml-expr (if (member op builtin-fns)
353	(cons (op->ncml-op op) (map expr->ncml-expr args))
354	`(ncml:apply (@ (id ,op)) ,@(map expr->ncml-expr args)))))
355	ncml-expr))
356	(else (error 'expr->ncml-expr "unknown expression " x))))
357
358
359
360	(define (op->ncml-op op)
361	(case op
362	((+) 'ncml:sum)
363	((-) 'ncml:sub)
364	((*) 'ncml:mul)
365	((/) 'ncml:div)
366	((>) 'ncml:gt)
367	((<) 'ncml:lt)
368	((<=) 'ncml:lte)
369	((>=) 'ncml:gte)
370	((=) 'ncml:eq)
371	(else (string->symbol (string-append "ncml:" (->string op))))))
372
373	(define (declaration->ncml parse-expr)
374	(lambda (x)
375	(match x
376	(((or 'input 'INPUT) . lst)
377	(map (lambda (x)
378	(match x
379	((? symbol?)
380	`(ncml:input (@ id ,(->string x))))
381	((id1 (or 'as 'AS) x1)
382	`(ncml:input (@ (id ,(->string id1)) (as ,(->string x1)))))
383	((id1 (or 'from 'FROM) n1)
384	`(ncml:input (@ (id ,(->string id1)) (from ,(->string n1)))))
385	((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1)
386	`(ncml:input (@ (id ,(->string id1))
387	(as ,(->string x1)) (from ,(->string n1)))))))
388	lst))
389
390
391	(((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
392	(map (lambda (x) `(ncml:output (@ (id ,(->string x))))) lst))
393
394
395	(((or 'const 'CONST) (and id (? symbol?)) '= expr)
396	`(ncml:const (@ (id ,(->string id))) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
397
398
399	(((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
400	(let ((trs (lookup-def 'transitions alst))
401	(initial (lookup-def 'initial alst))
402	(open (lookup-def 'open alst))
403	(cons (lookup-def 'conserve alst))
404	(p (lookup-def 'power alst)))
405	(let ((sxml-trs (append-map transition->ncml-transition trs)))
406	`(ncml:reaction (@ (id ,(->string id)))
407	(ncml:open ,open)
408	,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) )
409	,(and cons `(ncml:conserve ,((conseq->ncml-conseq parse-expr) cons)) )
410	(ncml:transitions ,@sxml-trs)
411	(ncml:power ,(expr->ncml-expr (parse-expr p)))))))
412
413
414	(((or 'd 'D) ((and id (? symbol?))) '= expr . rest)
415	(let ((initial (lookup-def 'initial rest)))
416	`(ncml:rate (@ (id ,(->string id)) )
417	,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))))
418	(ncml:expr ,(expr->ncml-expr (parse-expr expr))))))
419
420
421	(((and id (? symbol?)) '= expr)
422	`(ncml:asgn (@ (id ,id)) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
423
424	(((or 'defun 'DEFUN) (and id (? symbol?))
425	(and idlist (? (lambda (x) (every symbol? x)))) expr)
426	`(ncml:defun (@ (id ,x))
427	,@(map (lambda (v) `(ncml:arg ,(->string v))) idlist)
428	(ncml:body ,(expr->ncml-expr (parse-expr expr)))))
429
430	(((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) ((or 'name 'NAME) name) . lst)
431	`(ncml:component (@ (name ,(->string name)) (type ,(->string typ)))
432	,@(map (declaration->ncml parse-expr) lst)))
433
434	(((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) . lst)
435	`(ncml:component (@ (type ,(->string typ)))
436	,@(map (declaration->ncml parse-expr) lst)))
437
438	(((or 'component 'COMPONENT) ((or 'name 'NAME) name) '=
439	(and functor-name (? symbol?)) (and args (? list?)))
440	`(ncml:component (@ (name ,(->string name))
441	(functor-name ,(->string functor-name)))
442	,@(map (declaration->ncml parse-expr) lst)))
443	)))
444
445	(define (make-component->ncml dis model parse-expr)
446	(lambda (x)
447	(let ((en (environment-ref model x)))
448	(cond ((procedure? en)
449	(let ((fd (procedure-data en)))
450	`(ncml:defun (@ (id ,x))
451	,@(map (lambda (v) `(ncml:arg ,v)) (lookup-def 'vars fd))
452	(ncml:body ,(expr->ncml-expr (lookup-def 'body fd))))))
453	(else
454	(match en
455
456	(($ nemo:quantity 'EXTERNAL local-name name namespace)
457	(if namespace
458	`(ncml:input (@ (id ,name)) (as ,local-name) (from ,namespace))
459	`(ncml:input (@ (id ,name)) (as ,local-name))))
460
461	(($ nemo:quantity 'CONST name value)
462	`(ncml:const (@ (id ,name)) (ncml:expr ,value)))
463
464	(($ nemo:quantity 'ASGN name value rhs)
465	(let ((expr (expr->ncml-expr rhs)))
466	`(ncml:asgn (@ (id ,name)) (ncml:expr ,expr))))
467
468	(($ nemo:quantity 'RATE name initial rhs power)
469	(let ((expr (expr->ncml-expr rhs))
470	(initial (and initial (expr->ncml-expr initial))))
471	`(ncml:rate (@ (id ,name))
472	,(and initial `(ncml:initial ,initial))
473	(ncml:expr ,expr)
474	(ncml:power ,(expr->ncml-expr power))
475	)))
476
477	(($ nemo:quantity 'REACTION name initial open trs cons p)
478	(let ((sxml-trs (append-map transition->ncml-transition trs)))
479	`(ncml:reaction (@ (id ,name))
480	(ncml:open ,open)
481	,(and initial `(ncml:initial ,(expr->ncml-expr initial)))
482	,(and cons `(ncml:conserve ,(map (conseq->ncml-conseq identity) cons)) )
483	(ncml:transitions ,@sxml-trs)
484	(ncml:power ,(expr->ncml-expr p)))))
485
486	(($ nemo:quantity 'COMPONENT name type lst)
487	(let ((component->ncml (make-component->ncml dis model parse-expr))
488	(component-exports ((dis 'component-exports) model x)))
489	(case type
490	((toplevel) `(,@(map component->ncml lst)
491	,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)))
492	(else `(ncml:component (@ (name ,name) (type ,type))
493	,@(filter-map component->ncml lst)
494	,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)
495	)))))
496
497	(($ nemo:quantity 'FUNCTOR name args type lst)
498	(let ((component->ncml (make-component->ncml dis model parse-expr)))
499	`(ncml:functor (@ (name ,name) (type ,type)
500	(parameters ,(string-intersperse (map ->string args) ",")))
501	,@(filter-map (declaration->ncml parse-expr) lst)
502	)))
503
504	(else #f)))))))
505
506
507	(define (model->ncml model parse-expr)
508	(match-let ((($ nemo:quantity 'DISPATCH dis)
509	(environment-ref model (nemo-intern 'dispatch))))
510	(let ((sysname ((dis 'sysname) model))
511	(component->ncml (make-component->ncml dis model parse-expr)))
512	`(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel))))))
513
514
515	(include "expr-parser.scm")
516	(include "SXML.scm")
517	(include "SXML-to-XML.scm")
518	(include "stx-engine.scm")
519
520	(define null-template
521	`(default ,(lambda (node bindings root env)
522	(begin
523	(warn "Unrecognized input element:" node)
524	'()))))
525
526	(define-syntax sxml:make-null-ss
527	(syntax-rules ()
528	((stx rule ...)
529	(list
530	; default handler
531	null-template
532	; handler for textual nodes
533	(list 'text (lambda (text) text))
534	rule ...))))
535
536	(define (ensure-xmlns doc)
537	(let ((doc1 (sxml:add-attr doc '(xmlns:ncml "ncml"))))
538	(sxml:add-attr doc1 '(xmlns ncml))))
539
540
541	;; based on SRV:send-reply by Oleg Kiselyov
542	(define (print-fragments b)
543	(let loop ((fragments b) (result #f))
544	(cond
545	((null? fragments) result)
546	((not (car fragments)) (loop (cdr fragments) result))
547	((null? (car fragments)) (loop (cdr fragments) result))
548	((eq? #t (car fragments)) (loop (cdr fragments) #t))
549	((pair? (car fragments))
550	(loop (cdr fragments) (loop (car fragments) result)))
551	((procedure? (car fragments))
552	((car fragments))
553	(loop (cdr fragments) #t))
554	(else
555	(display (car fragments))
556	(loop (cdr fragments) #t)))))
557
558
559	(define (ncml->declarations ncml:model)
560	(letrec
561	((input-template
562	(sxml:match 'ncml:input
563	(lambda (node bindings root env)
564	(let ((id (sxml:attr node 'id))
565	(from (sxml:kidn* 'ncml:from node))
566	(as (sxml:kidn* 'ncml:as node)))
567	(if (not id) (error 'input-template "input declaration requires id attribute"))
568	(cond ((and from as) `(input (,($ id) as ,($ (second as) ) from ,($ (second from)) )))
569	(from `(input (,($ id) from ,($ (second from)))))
570	(as `(input (,($ id) as ,($ (second as)))))
571	(else `(input ,($ id))))))))
572
573	(output-template
574	(sxml:match 'ncml:output
575	(lambda (node bindings root env)
576	(let ((id (sxml:attr node 'id)))
577	(if (not id) (error 'output-template "output declaration requires id attribute"))
578	`(output ,($ id))))))
579
580	(const-template
581	(sxml:match 'ncml:const
582	(lambda (node bindings root env)
583	(let* ((id (sxml:attr node 'id))
584	(expr ((lambda (x)
585	(if (not x)
586	(error 'const-template "const declaration " id " requires expr element")
587	(ncml-expr->expr (second x))))
588	(sxml:kidn* 'ncml:expr node))))
589	(if (not id) (error 'const-template "const declaration requires id attribute"))
590	`(const ,($ id) = ,expr)))))
591
592	(reaction-transition-template
593	(sxml:match 'ncml:transition
594	(lambda (node bindings root env)
595	(let ((src (sxml:attr node 'src))
596	(dst (sxml:attr node 'dst))
597	(rate ((lambda (x)
598	(if (not x)
599	(error 'reaction-transition-template
600	"reaction transition requires rate element")
601	(ncml-expr->expr (second x))))
602	(sxml:kidn* 'ncml:rate node))))
603	(if (not src) (error 'reaction-transition-template
604	"reaction transition requires src attribute"))
605	(if (not dst) (error 'reaction-transition-template
606	"reaction transition requires dst attribute"))
607
608	`(-> ,($ src) ,($ dst) ,rate)))))
609
610	(asgn-template
611	(sxml:match 'ncml:asgn
612	(lambda (node bindings root env)
613	(let ((id (sxml:attr node 'id))
614	(expr ((lambda (x)
615	(if (not x)
616	(error 'asgn-template "algebraic assignment requires expr element")
617	(ncml-expr->expr (second x))))
618	(sxml:kidn* 'ncml:expr node))))
619	(if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
620	`(,($ id) = ,expr)))))
621
622	(rate-template
623	(sxml:match 'ncml:rate
624	(lambda (node bindings root env)
625	(let ((id (sxml:attr node 'id))
626	(rhs ((lambda (x)
627	(if (not x)
628	(error 'rate-template "rate equation requires expr element")
629	(ncml-expr->expr (second x))))
630	(sxml:kidn* 'ncml:expr node)))
631	(initial ((lambda (x) (and x (ncml-expr->expr (second x))))
632	(sxml:kidn* 'ncml:initial node)))
633	(power ((lambda (x) (and x (ncml-expr->expr (second x))))
634	(sxml:kidn* 'ncml:power node)))
635	)
636	(if (not id) (error 'rate-template "rate equation requires id attribute"))
637	`(d (,($ id)) = ,rhs ,(and initial `(initial ,initial) )
638	,(and power `(power ,power) ))))))
639	(conseq-template
640	(sxml:match 'ncml:conseq
641	(lambda (node bindings root env)
642	(let ((val (string->number (->string (sxml:attr node 'val))))
643	(rhs ((lambda (x)
644	(if (not x)
645	(error 'conseq-template
646	"conseq definition requires expr element")
647	(ncml-expr->expr (second x))))
648	(sxml:kidn* 'ncml:expr node))))
649	`(,val = ,rhs)))))
650
651	(reaction-template
652	(sxml:match 'ncml:reaction
653	(lambda (node bindings root env)
654	(let* ((id ($ (sxml:attr node 'id)))
655	(initial ((lambda (x) (and x (ncml-expr->expr (second x))))
656	(sxml:kidn* 'ncml:initial node)))
657
658	(open ((lambda (x)
659	(if (not x)
660	(error 'reaction-template
661	"reaction declaration requires open element")
662	($ (second x))))
663	(sxml:kidn* 'ncml:open node)))
664
665	(conserve ((lambda (x)
666	(and x (let ((tmpl (sxml:make-null-ss conseq-template)))
667	(stx:apply-templates (second x) tmpl root env))))
668	(sxml:kidn* 'ncml:conserve node)))
669
670	(power ((lambda (x)
671	(if (not x)
672	(error 'reaction-template
673	"reaction declaration requires open element")
674	(sxml:number (second x))))
675	(sxml:kidn* 'ncml:power node)))
676
677	(transitions ((lambda (x)
678	(if (not x)
679	(error 'reaction-template
680	"reaction declaration requires transitions element")
681	(let ((tmpl (sxml:make-null-ss reaction-transition-template)))
682	(stx:apply-templates (cdr x) tmpl root env))))
683	(sxml:kidn* 'ncml:transitions node)))
684
685	)
686
687	(if (not id) (error 'reaction-template "reaction transition requires id attribute"))
688	`(reaction (,id (initial ,initial) (open ,open) (power ,power)
689	,(and conserve `(conserve ,conserve) )
690	(transitions ,@transitions)))))))
691
692
693	(defun-template
694	(sxml:match 'ncml:defun
695	(lambda (node bindings root env)
696	(let ((id (sxml:attr node 'id))
697	(args ((lambda (x)
698	(if (null? x)
699	(error 'defun-template
700	"function definition requires at least one arg element")
701	(map (compose $ second) x)))
702	(sxml:kidsn 'ncml:arg node)))
703	(body ((lambda (x)
704	(if (not x)
705	(error 'defun-template
706	"function definition requires body element")
707	(ncml-expr->expr (second x))))
708	(sxml:kidn* 'ncml:body node))))
709	(if (not id) (error 'defun-template "function definition requires id attribute"))
710	`(defun ,($ id) ,args ,body)))))
711
712	(component-template
713	(sxml:match 'ncml:component
714	(lambda (node bindings root env)
715	(let ((name (sxml:attr node 'name))
716	(functor-name (sxml:attr node 'functor-name))
717	(type (sxml:attr node 'type)))
718	(if (not type) (error 'component-template "component definition requires type attribute"))
719	(if name
720	`(component (type ,($ type)) (name ,($ name)) ,@(ncml->declarations (sxml:kids node)))
721	(if functor-name
722	`(component (name ,($ name)) = ,functor-name ,(ncml->declarations (sxml:kids node)))
723	`(component (type ,($ type)) ,@(ncml->declarations (sxml:kids node)))))))))
724
725	(functor-template
726	(sxml:match 'ncml:functor
727	(lambda (node bindings root env)
728	(let ((parameters (sxml:attr node 'parameters))
729	(name (sxml:attr node 'name))
730	(type (sxml:attr node 'type)))
731	(if (not type) (error 'functor-template "functor definition requires type attribute"))
732	(if (not name) (error 'functor-template "functor definition requires name attribute"))
733	(if (not parameters)
734	(error 'functor-template "functor definition requires parameters attribute"))
735	`(functor (type ,($ type)) (name ,($ name))
736	(args ,(map string->symbol (string-split parameters ",")))
737	,@(ncml->declarations (sxml:kids node)))))))
738
739	(hh-template
740	(sxml:match 'ncml:hh_ionic_conductance
741	(lambda (node bindings root env)
742	(let* ((or-expr (lambda (x) (and x (ncml-expr->expr (second x)))))
743	(id (sxml:attr node 'id))
744	(initial_m (or-expr (sxml:kidn* 'ncml:initial_m node)))
745	(initial_h (or-expr (sxml:kidn* 'ncml:initial_h node)))
746	(m_power (or-expr (sxml:kidn* 'ncml:m_power node)))
747	(h_power (or-expr (sxml:kidn* 'ncml:h_power node)))
748	(m_alpha (or-expr (sxml:kidn* 'ncml:m_alpha node)))
749	(m_beta (or-expr (sxml:kidn* 'ncml:m_beta node)))
750	(h_alpha (or-expr (sxml:kidn* 'ncml:h_alpha node)))
751	(h_beta (or-expr (sxml:kidn* 'ncml:h_beta node)))
752	(m_tau (or-expr (sxml:kidn* 'ncml:m_tau node)))
753	(m_inf (or-expr (sxml:kidn* 'ncml:m_inf node)))
754	(h_tau (or-expr (sxml:kidn* 'ncml:h_tau node)))
755	(h_inf (or-expr (sxml:kidn* 'ncml:h_inf node))))
756	(if (not id)
757	(error 'hh-template "hh ionic conductance definition requires id attribute"))
758	`(hh-ionic-gate
759	(,($ id)
760	,@(if initial_m `((initial-m ,initial_m)) `())
761	,@(if initial_h `((initial-h ,initial_h)) `())
762	,@(if m_power `((m-power ,m_power)) '())
763	,@(if h_power `((h-power ,h_power)) '())
764	,@(if m_alpha `((m-alpha ,m_alpha)) '())
765	,@(if h_alpha `((h-alpha ,h_alpha)) '())
766	,@(if m_beta `((m-beta ,m_beta)) '())
767	,@(if h_beta `((h-beta ,h_beta)) '())
768	,@(if m_inf `((m-inf ,m_inf)) '())
769	,@(if h_inf `((h-inf ,h_inf)) '())
770	,@(if m_tau `((m-tau ,m_tau)) '())
771	,@(if h_tau `((h-tau ,h_tau)) '())
772	))))))
773
774	(decaying-pool-template
775	(sxml:match 'ncml:decaying_pool
776	(lambda (node bindings root env)
777	(let* ((or-expr (lambda (x) (and x (ncml-expr->expr (second x)))))
778	(id (sxml:attr node 'id))
779	(initial (or-expr (sxml:kidn* 'ncml:initial node)))
780	(beta (or-expr (sxml:kidn* 'ncml:beta node)))
781	(depth (or-expr (sxml:kidn* 'ncml:depth node)))
782	(temp-adj (or-expr (sxml:kidn* 'ncml:temp_adj node))))
783	(if (not id)
784	(error 'decaying-pool-template "decaying pool definition requires id attribute"))
785	(if (not initial)
786	(error 'decaying-pool-template "decaying pool definition requires initial value"))
787	(if (not beta)
788	(error 'decaying-pool-template "decaying pool definition requires beta parameter"))
789	(if (not depth)
790	(error 'decaying-pool-template "decaying pool definition requires depth parameter"))
791
792	`(decaying-pool
793	(,($ id)
794	,@(if temp_adj `((temp_adj ,temp_adj)) `())
795	(beta ,beta)
796	(depth ,depth)
797	(initial ,initial)))))))
798	)
799
800	(stx:apply-templates ncml:model
801	(sxml:make-null-ss input-template
802	output-template
803	const-template
804	asgn-template
805	rate-template
806	reaction-template
807	defun-template
808	component-template
809	functor-template
810	hh-template
811	decaying-pool-template)
812	ncml:model (list))))
813
814
815
816	(define (ncml->model options doc)
817	(let* ((ncml:model ((lambda (x)
818	(if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x)))
819	(ncml:sxpath '(// ncml:model) `(TOP . ,doc))))
820	(model-name (sxml:attr ncml:model 'name))
821	(model-decls (ncml->declarations (sxml:kids ncml:model))))
822	(let* ((model+nemo (nemo-constructor model-name model-decls (lambda (x . rest) (identity x))))
823	(model (first model+nemo))
824	(nemo (second model+nemo)))
825	(let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) identity)))
826	(if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
827	(if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))
828	(if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
829	(if (assoc 'components options)
830	(for-each (lambda (x)
831	(print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
832	(print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
833	((nemo 'components) model-1)))
834	model-1))))
835
836
837
838	(define (main opt operands)
839	(if (null? operands)
840
841	(nemo:usage)
842
843	(let ((models
844	(map (lambda (operand)
845	(let* ((read-xml (lambda (name) (call-with-input-file name
846	(lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
847	(read-sexp (lambda (name) (call-with-input-file name read)))
848
849	(in-format (cond ((opt 'input-format) =>
850	(lambda (x)
851	(case x
852	((nemo) 'nemo)
853	((s-exp sexp) 'sexp)
854	((sxml) 'sxml)
855	((xml) 'xml)
856	(else (error 'nemo "unknown input format" x)))))
857	(else (case ((lambda (x) (or (not x) ($ x)))
858	(pathname-extension operand))
859	((s-exp sexp) 'sexp)
860	((sxml) 'sxml)
861	((xml) 'xml)
862	(else 'nemo)))))
863
864	(doc (case in-format
865	((nemo sxml s-exp sexp) (read-sexp operand))
866	((xml) (read-xml operand))
867	(else (error 'nemo "unknown input format" in-format))))
868
869	(parse-expr (case in-format
870	((sxml xml) identity)
871	((s-exp sexp) identity)
872	((nemo) nemo:parse-sym-expr)
873	(else (error 'nemo "unknown input format" in-format))))
874
875	(model (case in-format
876	((sxml xml) (ncml->model `((hh-markov . ,(opt 'hh-markov)))
877	doc))
878	((s-exp sexp) (sexp->model `((hh-markov . ,(opt 'hh-markov)))
879	doc parse-expr))
880	((nemo) (sexp->model `((hh-markov . ,(opt 'hh-markov)))
881	doc parse-expr))
882	(else (error 'nemo "unknown input format" in-format))))
883	)
884	model))
885	operands)))
886	(for-each
887	(lambda (operand model)
888	(let* (
889	(make-fname (lambda (operand x suffix)
890	(and x (let ((fname (pathname-strip-extension operand)))
891	(if (string? x) x (s+ fname suffix))))))
892
893	(sxml-fname (make-fname operand (opt 'sxml) ".sxml"))
894	(xml-fname (make-fname operand (opt 'xml) ".xml"))
895	(mod-fname (make-fname operand (opt 'nmodl) ".mod"))
896	(octave-fname (and (string? (opt 'octave)) (make-fname operand (opt 'octave) ".m") ))
897	(nest-fname (and (string? (opt 'nest)) (make-fname operand (opt 'nest) ".cpp") ))
898	(vclamp-ses-fname (make-fname operand (opt 'vclamp-hoc) ".ses"))
899	(vclamp-octave-fname (make-fname operand (opt 'vclamp-octave) "_vclamp.m"))
900
901	(nest (opt 'nest))
902	(matlab (opt 'matlab))
903	(octave (opt 'octave))
904	(vclamp-hoc (opt 'vclamp-hoc))
905	(vclamp-octave (opt 'vclamp-octave))
906
907	(nmodl-depend (opt 'nmodl-depend))
908
909	(nmodl-method
910	(let ((method ($ (opt 'nmodl-method) )))
911	(case method
912
913	((adams runge euler adeuler heun adrunge gear
914	newton simplex simeq seidel sparse derivimplicit cnexp clsoda
915	after_cvode cvode_t cvode_t_v expeuler #f) method)
916	(else (error "unknown nmodl-method " method)))))
917
918	(octave-method
919	(let ((method ($ (opt 'octave-method) )))
920	(case method
921	((lsode odepkg #f) method)
922	(else (error "unknown octave method " method)))))
923	)
924	(if sxml-fname (with-output-to-file sxml-fname
925	(lambda () (pretty-print (model->ncml model parse-expr)))))
926	(if xml-fname (let* ((doc (model->ncml model parse-expr))
927	(doc1 (ensure-xmlns
928	(cond ((eq? (car doc) 'TOP) (assoc 'ncml:model (cdr doc)))
929	(else doc)))))
930	(with-output-to-file xml-fname
931	(lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
932	(if mod-fname
933	(with-output-to-file
934	mod-fname (lambda ()
935	(model->nmodl `((depend . ,nmodl-depend)
936	(method . ,nmodl-method)
937	(table . ,(opt 't))
938	(kinetic . ,(opt 'nmodl-kinetic)))
939	model))))
940
941	(if octave (model->octave `((filename . ,octave-fname)
942	(method . ,octave-method))
943	model))
944
945	(if matlab (model->matlab `() model))
946
947	(if nest (model->nest `((filename . ,nest-fname)) model))
948
949
950	(if vclamp-hoc (model->vclamp-hoc `((filename . ,vclamp-ses-fname)
951	)
952	model))
953	(if vclamp-octave (model->vclamp-octave `((filename . ,vclamp-octave-fname)
954	)
955	model))
956
957	))
958	operands models)
959
960	(let ((pyparams (opt 'pyparams)))
961	(if pyparams
962	(let ((pyparams-fname
963	(or (and (string? (opt 'pyparams))
964	(make-fname operand (opt 'pyparams) ".py") )
965	"pyparams.py")))
966	(models->pyparams `((filename . ,pyparams-fname)) models))))
967
968	)))
969
970	(main opt (opt '@))
971

Note: See TracBrowser for help on using the repository browser.

Download in other formats: