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

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

nemo release 8.45

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