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

Last change on this file since 31480 was 31480, checked in by Ivan Raikov, 5 years ago

nemo: ensure compatibility of code generation templates with jinja

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