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

Last change on this file since 29940 was 29940, checked in by Ivan Raikov, 8 years ago

nemo: adding option --nest-ss-method to allow the selection of steady state solving method

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