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

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

nemo: bug fixes in NEST templates

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