source: project/release/4/nemo/tags/8.34/nemo.scm @ 29626

Last change on this file since 29626 was 29626, checked in by Ivan Raikov, 7 years ago

nemo release 8.34

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