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

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

nemo: added ability to load sxslt files

File size: 75.8 KB
Line 
1;;
2;; NEMO
3;;
4;; Copyright 2008-2013 Ivan Raikov and the Okinawa Institute of
5;; Science and Technology.
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;; General Public License for more details.
16;;
17;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20
21(import files setup-api srfi-1 srfi-4 srfi-13 srfi-69)
22
23
24(require-extension nemo-core nemo-macros nemo-hh nemo-vclamp nemo-iclamp 
25                   nemo-utils nemo-units)
26(require-library iexpr ersatz-lib)
27(require-extension datatype matchable lalr-driver
28                   ssax sxml-transforms sxpath sxpath-lolevel 
29                   getopt-long)
30(import (prefix iexpr iexpr: )
31        (prefix ersatz-lib ersatz: )
32        )
33
34(define user-template-list?
35  (lambda (ts) 
36    (every (lambda (x) (and (string? (car x))
37                            (every string? (cadr x))
38                            (every ersatz:tstmt? (caddr x)))) ts)))
39
40
41(define-datatype nemo:model nemo:model?
42  (ModelSource (source-path string?) (in-format symbol?) (name symbol?) 
43               (decls list?) 
44               (user-templates user-template-list?)
45               (iexpr boolean?) (parse-expr procedure?))
46  (SingleModel (source-path string?) (in-format symbol?) (name symbol?) 
47               (sys hash-table?) (decls list?) (user-templates user-template-list?)
48               (iexpr boolean?) (parse-expr procedure?))
49  (ModelPart   (source-path string?) (in-format symbol?) (name symbol?) (part-name symbol?) 
50               (sys hash-table?) (decls list?) (parent-decls list?)
51               (user-templates user-template-list?)
52               (iexpr boolean?) (parse-expr procedure?))
53  )
54 
55
56(define nemo-nmodl?       (extension-information 'nemo-nmodl)) 
57(define nemo-matlab?      (extension-information 'nemo-matlab)) 
58(define nemo-nest?        (extension-information 'nemo-nest)) 
59(define nemo-pyparams?    (extension-information 'nemo-pyparams)) 
60
61(if nemo-nmodl?   (use nemo-nmodl))
62(if nemo-matlab?  (use nemo-matlab))
63(if nemo-nest?    (use nemo-nest))
64(if nemo-pyparams?    (use nemo-pyparams))
65
66(define (lookup-def k lst . rest)
67  (let-optionals rest ((default #f))
68      (let ((kv (assoc k lst)))
69        (if (not kv) default
70            (match kv ((k v) v) (else (cdr kv)))))))
71
72(define ($ x)  (and x (string->symbol (->string x))))
73
74;;; Procedures for string concatenation and pretty-printing
75
76(define (s+ . lst)    (string-concatenate (map ->string lst)))
77(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
78(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
79(define (sl\ 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    (plain
121     "write plain text output to file (default: <model-name>.txt)"
122     (value (optional DIRNAME)
123            ))
124
125    (xml
126     "write XML output to file (default: <model-name>.xml)"
127     (value (optional DIRNAME)
128            ))
129
130    (sxml
131     "write SXML output to file (default: <model-name>.sxml)"
132     (value (optional DIRNAME)
133            ))
134
135    (hh-markov
136     "convert HH rate equations to Markov chain form")
137
138    (print-default-units
139     "print default units used for target platform")
140
141    (default-units
142     "set default units used for target platform"
143     (value (required QUANTITY:UNIT)
144            (transformer 
145             ,(lambda (x) 
146                (map (lambda (x) 
147                       (match-let (((dimstr unitstr) (string-split x ":")))
148                                  (let ((dimsym (string->symbol dimstr))
149                                        (unitsym (string->symbol unitstr)))
150                                    (let* ((alldims (map (lambda (x) 
151                                                           (cons (nemo:quantity-name (car x)) (car x)))
152                                                         (nemo:default-units)))
153                                           (dim (lookup-def dimsym alldims))
154                                           (u   (lookup-def unitsym nemo:basic-units)))
155                                      (if (not (and u (= (nemo:quantity-int (nemo:unit-dims u)))
156                                                    (nemo:quantity-int dim)))
157                                          (error 'default-units "invalid unit for given quantity"
158                                                 unitsym dimsym)
159                                          (cons dim u))))
160                                  ))
161                          (string-split x ","))))
162             )
163            )
164
165    ,@(if nemo-nest? 
166          `(
167            (nest
168             "write NEST output files <model-name>.cpp and <model-name>.h in the given directory (default: .)" 
169             (value (optional DIRNAME)))
170
171            (nest-method
172             "specify NEST integration method (gsl, cvode, leapfrog)"
173             (value (required METHOD)
174                    (transformer ,string->symbol)))
175            )
176          `())
177
178    ,@(if nemo-pyparams? 
179          `(
180            (pyparams
181             "write Python representation of parameters to given file (default: <model-name>.py)"
182             (value (optional DIRNAME)))
183            )
184          `())
185
186    ,@(if nemo-matlab? 
187          `((matlab
188             "write MATLAB output in the given directory (default: .)"
189             (value (optional DIRNAME)))
190
191            (octave
192             "write Octave output to given file (default: <model-name>.m)"
193             (value (optional DIRNAME)))
194                     
195            (octave-method
196             "specify Octave integration method (lsode, odepkg, or cvode)"
197             (value (required METHOD)
198                    (transformer ,string->symbol)))
199            )
200          `())
201
202    ,@(if nemo-nmodl?
203          `(
204             (nmodl      "write NMODL output to file (default: <model-name>.mod)"
205                         (value (optional DIRNAME)))
206
207             (nmodl-kinetic  ,(s+ "use NMODL kinetic equations for the given reactions "
208                                  "(or for all reactions)")
209                             (value (optional STATES)
210                                    (default  ,(defopt 'nmodl-kinetic))
211                                    (transformer 
212                                     ,(lambda (x) 
213                                        (if (string=? x "all") 'all
214                                            (map string->symbol (string-split x ",")))))))
215             
216             (nmodl-method   "specify NMODL integration method"
217                             (value (required METHOD)
218                                    (transformer ,string->symbol)))
219             )
220            `())
221
222    (vclamp-hoc
223     "write voltage clamp scripts to HOC file (default: <model-name>.hoc)"
224     (value (optional DIRNAME)
225            ))
226
227    (vclamp-octave
228     "write voltage clamp script to Octave file (default: <model-name>_vclamp.m)"
229     (value (optional DIRNAME)
230            ))
231
232    (iclamp-hoc
233     "write current pulse injection scripts to HOC file (default: <model-name>.hoc)"
234     (value (optional DIRNAME)
235            ))
236
237    (iclamp-nest
238     "write current pulse injection script to NEST SLI file (default: <model-name>.sli)"
239     (value (optional DIRNAME)
240            ))
241
242    (template
243     "instantiate the given template from the model file by setting the given variables to the respective values"
244     (value (required "NAME[:VAR=VAL...]"))
245     (multiple #t)
246     )
247
248    (template-prefix 
249     "output instantiated templates to <PREFIX><template_name> (default is <model-name>_<template_name>)"
250     (value (required PREFIX)
251            ))
252
253    (debug "print additional debugging information")
254
255    (version "print the current version and exit")
256
257    (help         (single-char #\h))
258
259
260    ))
261
262
263;; Use args:usage to generate a formatted list of options (from OPTS),
264;; suitable for embedding into help text.
265(define (nemo:usage)
266  (print "Usage: " (car (argv)) "  <list of files to be processed> [options...] ")
267  (newline)
268  (print "The following options are recognized: ")
269  (newline)
270  (print (parameterize ((indent 5) (width 30)) (usage opt-grammar)))
271  (exit 1))
272
273
274;; Process arguments and collate options and arguments into OPTIONS
275;; alist, and operands (filenames) into OPERANDS.  You can handle
276;; options as they are processed, or afterwards.
277
278(define opts    (getopt-long (command-line-arguments) opt-grammar))
279(define opt     (make-option-dispatch opts opt-grammar))
280
281
282(define (ncml:sxpath query doc)
283  ((sxpath query '((ncml . "ncml"))) doc))
284
285(define (ncml:car-sxpath query doc)
286  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
287    (car lst)))
288
289(define (ncml:if-car-sxpath query doc)
290  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
291    (and (not (null? lst)) (car lst))))
292
293(define (ncml:if-sxpath query doc)
294  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
295    (and (not (null? lst)) lst)))
296
297(define (ncml-binding->binding node)
298  (match node
299    (('ncml:bnd ('@ ('id id)) ('ncml:expr expr))
300     `(,($ id) ,(ncml-expr->expr expr)))
301    (else (error 'ncml-binding->binding "invalid binding " node))))
302 
303(define (ncml-expr->expr node)
304  (match node
305         ((? number?)    node)
306         ((? string?)    (sxml:number node))
307         (('ncml:id id)  ($ id))
308         (('ncml:apply ('@ ('id id)) . args)  (cons ($ id) (map ncml-expr->expr args)))
309         (('ncml:let ('ncml:bnds . bnds) ('ncml:expr body))
310          `(let ,(map ncml-binding->binding bnds) ,(ncml-expr->expr body)))
311         (((and op (? symbol?)) . args)
312          (cons (ncml-op->op op) (map ncml-expr->expr args)))
313         (else (error 'ncml-expr->expr "unknown expression " node))))
314 
315
316(define (ncml-op->op op)
317  (case op
318    ((ncml:sum)    '+)
319    ((ncml:sub)    '-)
320    ((ncml:mul)    '*)
321    ((ncml:div)    '/)
322    ((ncml:gt)     '>)
323    ((ncml:lt)     '<)
324    ((ncml:lte)    '<=)
325    ((ncml:gte)    '>=)
326    ((ncml:eq)     '=)
327    (else          (match (string-split (->string op) ":")
328                          ((pre op)  ($ op))
329                          (else (error 'ncml-op->op "invalid operator" op))))))
330
331
332(define (nemo-constructor name declarations parse-expr)
333  (let* ((nemo   (make-nemo-core))
334         (sys    ((nemo 'system) name))
335         (qs     (eval-nemo-system-decls nemo name sys declarations parse-expr)))
336    (list sys nemo qs)))
337
338
339(define (sexp->model-decls doc)
340  (match doc
341         ((or ('nemo-model model-name model-decls)
342              ('nemo-model (model-name . model-decls)))
343          (list model-name model-decls))
344         ((or ('nemo-model model-name model-decls user-templates)
345              ('nemo-model (model-name . model-decls) user-templates))
346          (list model-name model-decls 
347                (map (lambda (x) (list (->string (car x)) 
348                                       (map ->string (cadr x))
349                                       (ersatz:statements-from-string
350                                        (ersatz:template-std-env) 
351                                        (caddr x))))
352                             user-templates)))
353         (else (error 'sexp->model "unknown model format"))
354         ))
355
356
357(define (sexp-model-decls->model options model-name model-decls parse-expr)
358  (let* ((model+nemo  (nemo-constructor model-name model-decls parse-expr))
359         (model (first model+nemo))
360         (nemo  (second model+nemo)))
361    (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) parse-expr))) 
362      (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
363      (if (assoc 'exports options)  (print "exports: " ((nemo 'exports) model-1)))     
364      (if (assoc 'imports options)  (print "imports: " ((nemo 'imports) model-1)))
365      (if (assoc 'components options)
366          (for-each (lambda (x) 
367                      (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
368                      (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
369                    ((nemo 'components) model-1)))
370      model-1)))
371         
372
373(define model->nmodl 
374  (if nemo-nmodl?
375      (lambda (options model)
376        (nemo:nmodl-translator model
377                               (lookup-def 'method options) 
378                               (lookup-def 'kinetic options) ))
379      (lambda (options model) 
380        (void))))
381
382
383(define model->nest 
384  (if nemo-nest?
385      (lambda (options model)
386        (nemo:nest-translator model (lookup-def 'dirname options) (lookup-def 'method options)))
387      (lambda (options model) 
388        (void))))
389
390(define model->pyparams 
391  (if nemo-pyparams?
392      (lambda (options model)
393        (nemo:pyparams-translator (list model) 
394                                  (lookup-def 'mode options) 
395                                  (lookup-def 'filename options)))
396      (lambda (options model) 
397        (void))))
398
399
400(define model->matlab 
401  (if nemo-matlab?
402      (lambda (options model)
403        (nemo:matlab-translator model #f (lookup-def 'dirname options)))
404      (lambda (options model) 
405        (void))))
406
407
408(define model->vclamp-hoc 
409  (lambda (options model)
410    (nemo:vclamp-translator model 'hoc (lookup-def 'filename options))))
411
412
413(define model->vclamp-octave 
414  (lambda (options model)
415    (nemo:vclamp-translator model 'matlab 
416                            (lookup-def 'filename options)
417                            (lookup-def 'octave-method options))))
418
419
420(define model->iclamp-hoc 
421  (lambda (options model)
422    (nemo:iclamp-translator model 'hoc (lookup-def 'filename options))))
423
424(define model->iclamp-nest 
425  (lambda (options model)
426    (nemo:iclamp-translator model 'nest (lookup-def 'filename options))))
427
428
429(define model->octave 
430  (if nemo-matlab?
431      (lambda (options model)
432        (nemo:octave-translator model 
433                                (lookup-def 'filename options)
434                                (lookup-def 'dirname options)))
435      (lambda (options model) 
436        (void))))
437
438
439(define (transition->ncml-transition x)
440  (match x
441         (('-> src dst rate) 
442          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
443         ((src '-> dst rate) 
444          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
445         (('<-> src dst rate1 rate2) 
446          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
447            (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
448         ((src '<-> dst rate1 rate2) 
449          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
450            (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
451         (else (error 'transition->ncml-transition "invalid transition " x))))
452
453
454(define (conseq->ncml-conseq parse-expr)
455  (lambda (x)
456    (match x 
457           (((and i (? integer?)) '= rhs)
458            `(ncml:conseq (@ (val ,(->string i))) 
459                         (ncml:expr ,(expr->ncml-expr (parse-expr rhs)))))
460           (else (error 'conseq->ncml-conseq "invalid linear equation " x)))))
461
462
463(define builtin-fns
464  `(+ - * / pow neg abs atan asin acos sin cos exp ln
465      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
466      > < <= >= = and or round ceiling floor max min))
467
468
469(define (binding->ncml-binding bnd)
470  (match bnd
471         ((id expr)  `(ncml:bnd (@ (id ,id)) (ncml:expr ,(expr->ncml-expr expr))))
472         (else (error 'binding->ncml-binding "invalid binding " bnd))))
473
474 
475(define (expr->ncml-expr x)
476  (match x
477         ((? number?)    x)
478         ((? symbol?)    `(ncml:id ,x))
479         (('let bnds expr)
480          `(ncml:let (ncml:bnds . ,(map binding->ncml-binding bnds)) 
481                     (ncml:expr ,(expr->ncml-expr expr))))
482         (((and op (? symbol?)) . args)
483          (let ((ncml-expr (if (member op builtin-fns)
484                               (cons (op->ncml-op op) (map expr->ncml-expr args))
485                               `(ncml:apply (@ (id ,op)) ,@(map expr->ncml-expr args)))))
486            ncml-expr))
487         (else (error 'expr->ncml-expr "unknown expression " x))))
488
489 
490
491(define (op->ncml-op op)
492  (case op
493    ((+)  'ncml:sum)
494    ((-)  'ncml:sub)
495    ((*)  'ncml:mul)
496    ((/)  'ncml:div)
497    ((>)  'ncml:gt)
498    ((<)  'ncml:lt)
499    ((<=) 'ncml:lte)
500    ((>=) 'ncml:gte)
501    ((=)  'ncml:eq)
502    (else  ($ (string-append "ncml:" (->string op))))))
503
504
505
506(define (declaration->ncml parse-expr)
507  (lambda (x)
508    (match x
509         (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
510          `(ncml:label (@ (id ,(->string id))) ,v))
511
512         (((or 'input 'INPUT) . lst)
513          (map (lambda (x) 
514                 (match x
515                        ((? symbol?) 
516                         `(ncml:input (@ id ,(->string x))))
517                        ((id1 (or 'as 'AS) x1) 
518                         `(ncml:input (@ (id ,(->string id1)) (as ,(->string x1)))))
519                        ((id1 (or 'from 'FROM) n1)
520                         `(ncml:input (@ (id ,(->string id1)) (from ,(->string n1)))))
521                        ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1)
522                         `(ncml:input (@ (id ,(->string id1)) 
523                                         (as ,(->string x1)) (from ,(->string n1)))))))
524               lst))
525
526
527         (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
528          (map  (lambda (x) `(ncml:output (@ (id ,(->string x))))) lst))
529
530
531         (((or 'const 'CONST) (and id (? symbol?)) '= expr)
532          `(ncml:const (@ (id ,(->string id))) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
533
534
535         (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
536          (let ((trs     (lookup-def 'transitions alst))
537                (initial (lookup-def 'initial alst))
538                (open    (lookup-def 'open alst))
539                (cons    (lookup-def 'conserve alst))
540                (p       (lookup-def 'power alst)))
541            (let ((sxml-trs (append-map transition->ncml-transition trs)))
542              `(ncml:reaction (@ (id ,(->string id))) 
543                              (ncml:open ,(if (list? open) 
544                                              (string-concatenate (intersperse (map ->string open) ",")) 
545                                              open))
546                              ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) )
547                              ,(and cons `(ncml:conserve ,((conseq->ncml-conseq parse-expr) cons)) )
548                              (ncml:transitions ,@sxml-trs)
549                              (ncml:power ,(expr->ncml-expr (parse-expr p)))))))
550
551         (((or 't 'T 'transient) ((and id (? symbol?))) '= (and expr (? expr?) ) . rest)
552          (let ((trs     (lookup-def 'transitions alst))
553                (initial (lookup-def 'initial alst))
554                (asgn    (lookup-def 'onevent alst))
555                (p       (lookup-def 'power alst))
556                )
557            `(ncml:transient (@ (id ,(->string id))) 
558                             (ncml:expr ,(expr->ncml-expr (parse-expr expr)))
559                             (ncml:onevent ,(expr->ncml-expr (parse-expr asgn)))
560                             ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) )
561                             ,(and p `(ncml:power ,(expr->ncml-expr (parse-expr p))))
562                             ))
563          )
564
565         (((or 'd 'D) ((and id (? symbol?))) '= expr . rest)
566          (let ((initial (lookup-def 'initial rest)))
567            `(ncml:rate (@ (id ,(->string id)) )
568                        ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))))
569                        (ncml:expr ,(expr->ncml-expr (parse-expr expr))))))
570 
571                           
572         (((and id (? symbol?)) '= expr)
573          `(ncml:asgn (@ (id ,id)) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
574                       
575         (((or 'defun 'DEFUN 'fun 'FUN 'rel 'REL) (and id (? symbol?)) 
576           (and idlist (? (lambda (x) (every symbol? x)))) expr)
577          `(ncml:defun (@ (id ,x)) 
578                       ,@(map (lambda (v) `(ncml:arg ,(->string v))) idlist)
579                       (ncml:body ,(expr->ncml-expr (parse-expr expr)))))
580         
581         (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) ((or 'name 'NAME) name) . lst)
582          `(ncml:component (@ (name ,(->string name)) (type ,(->string typ)))
583                           ,@(map (declaration->ncml parse-expr) lst)))
584         
585         (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
586          `(ncml:component (@ (type ,(->string typ)))
587                           ,@(map (declaration->ncml parse-expr) lst)))
588         
589         (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
590           (and functor-name (? symbol?)) (and args (? list?)))
591          `(ncml:component (@ (name ,(->string name)) 
592                              (functor-name ,(->string functor-name)))
593                           ,@(map (declaration->ncml parse-expr) lst)))
594         )))
595
596
597(define (make-component->ncml dis model parse-expr)
598  (lambda (x) 
599    (let ((en (hash-table-ref model x)))
600        (cond ((procedure? en)
601               (let ((fd (procedure-data en)))
602                 `(ncml:defun (@ (id ,x)) 
603                              ,@(map (lambda (v) `(ncml:arg ,v)) (lookup-def 'vars fd))
604                              (ncml:body ,(expr->ncml-expr (lookup-def 'body fd))))))
605              (else
606               (match en
607                      (($ nemo:quantity 'LABEL  v) 
608                       `(ncml:label (@ (id ,name)) ,v))
609                     
610                      (($ nemo:quantity 'EXTERNAL   local-name name namespace u)
611                       (if namespace
612                           `(ncml:input (@ (id ,name)) (as ,local-name) (from ,namespace))
613                           `(ncml:input (@ (id ,name)) (as ,local-name))))
614
615                      (($ nemo:quantity 'CONST  name value) 
616                       `(ncml:const (@ (id ,name)) (ncml:expr ,value)))
617                     
618                      (($ nemo:quantity 'ASGN name value rhs)
619                       (let ((expr (expr->ncml-expr rhs)))
620                         `(ncml:asgn (@ (id ,name)) (ncml:expr ,expr))))
621                     
622                      (($ nemo:quantity 'RATE name initial rhs power u)
623                       (let ((expr (expr->ncml-expr rhs))
624                             (initial (and initial (expr->ncml-expr initial))))
625
626                         `(ncml:rate (@ (id ,name)) 
627                                     ,(and initial `(ncml:initial ,initial))
628                                     (ncml:expr ,expr)
629                                     (ncml:power ,(or (and power (expr->ncml-expr power)) 
630                                                      (expr->ncml-expr 1.0)))
631                                     )))
632                     
633                      (($ nemo:quantity 'TRANSIENT name initial rhs asgn power u)
634                       (let ((expr (expr->ncml-expr rhs))
635                             (asgn  (expr->ncml-expr asgn))
636                             (initial (and initial (expr->ncml-expr initial))))
637
638                         `(ncml:transient (@ (id ,name)) 
639                                          ,(and initial `(ncml:initial ,initial))
640                                          (ncml:expr ,expr)
641                                          (ncml:onevent ,asgn)
642                                          (ncml:power ,(or (and power (expr->ncml-expr power)) 
643                                                           (expr->ncml-expr 1.0)))
644                                          )))
645                     
646                      (($ nemo:quantity 'REACTION name initial open trs cons p u) 
647                       (let ((sxml-trs (append-map transition->ncml-transition trs)))
648                         `(ncml:reaction (@ (id ,name))
649                                         (ncml:open ,(if (list? open) 
650                                                         (string-concatenate (intersperse (map ->string open) ",")) 
651                                                         open))
652                                         ,(and initial `(ncml:initial ,(expr->ncml-expr initial)))
653                                         ,(and cons `(ncml:conserve ,(map (conseq->ncml-conseq identity) cons)) )
654                                         (ncml:transitions ,@sxml-trs)
655                                         (ncml:power ,(expr->ncml-expr p)))))
656                     
657                      (($ nemo:quantity 'COMPONENT name type lst) 
658                       (let ((component->ncml (make-component->ncml dis model parse-expr))
659                             (component-exports ((dis 'component-exports) model x)))
660                         (case type
661                           ((toplevel) `(,@(map component->ncml lst)
662                                         ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)))
663                           (else `(ncml:component (@ (name ,name) (type ,type))
664                                                  ,@(filter-map component->ncml lst)
665                                                  ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)
666                                                  )))))
667                     
668                      (($ nemo:quantity 'FUNCTOR name args type lst) 
669                       (let ((component->ncml (make-component->ncml dis model parse-expr)))
670                         `(ncml:functor (@ (name ,name) (type ,type) 
671                                           (parameters ,(string-intersperse (map ->string args) ",")))
672                                        ,@(filter-map (declaration->ncml parse-expr) lst)
673                                        )))
674                     
675                      (else #f)))))))
676   
677
678(define (model->ncml model parse-expr)
679  (match-let ((($ nemo:quantity 'DISPATCH  dis)     
680               (hash-table-ref model (nemo-intern 'dispatch))))
681     (let ((sysname     ((dis 'sysname) model))
682           (component->ncml (make-component->ncml dis model parse-expr)))
683       `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel))))))
684           
685
686(define (transition->text-transition x)
687  (match x
688         (('-> src dst rate) 
689          `(-> ,src ,dst ,(expr->text-expr rate) ))
690         ((src '-> dst rate) 
691          `(-> ,src ,dst ,(expr->text-expr rate) ))
692         (('<-> src dst rate1 rate2) 
693          `(<-> ,src ,dst ,(expr->text-expr rate) ))
694         (('src <-> dst rate1 rate2) 
695          `(<-> ,src ,dst ,(expr->text-expr rate) ))
696         (else (error 'transition->text-transition "invalid transition " x))))
697
698
699(define (conseq->text-conseq parse-expr)
700  (lambda (x)
701    (match x 
702           (((and i (? integer?)) '= rhs)
703            `(,(->string i) =
704              ,(expr->text-expr (parse-expr rhs))))
705           (else (error 'conseq->text-conseq "invalid linear equation " x)))))
706
707
708(define (binding->text-binding bnd)
709  (match bnd
710         ((id expr)  `(,id = ,(expr->text-expr expr)))
711         (else (error 'binding->text-binding "invalid binding " bnd))))
712
713 
714(define (expr->text-expr x)
715  (match x
716         ((? number?)    x)
717         ((? symbol?)    x)
718         (('let bnds expr)
719          `(let (,(map binding->text-binding bnds))
720             ,(expr->text-expr expr)))
721         (((and op (? symbol?)) . args)
722          (let ((ncml-expr `(apply ,op ,@(map expr->text-expr args))))
723            ncml-expr))
724         (else (error 'expr->text-expr "unknown expression " x))))
725
726
727(define (make-component->text dis model parse-expr)
728  (lambda (x) 
729    (let ((en (hash-table-ref model x)))
730        (cond ((procedure? en)
731               (let ((fd (procedure-data en)))
732                 `(function ,x
733                            ,(lookup-def 'vars fd) =
734                            ,(expr->text-expr (lookup-def 'body fd)))
735                 ))
736              (else
737               (match en
738                      (($ nemo:quantity 'LABEL  v) 
739                       `(label ,name = ,v))
740                     
741                      (($ nemo:quantity 'EXTERNAL local-name name namespace u)
742                       (if namespace
743                           `(input ,name  as ,local-name from ,namespace)
744                           `(input ,name  as ,local-name)))
745
746                      (($ nemo:quantity 'CONST  name value) 
747                       `(const ,name = ,value))
748                     
749                      (($ nemo:quantity 'ASGN name value rhs)
750                       (let ((expr (expr->text-expr rhs)))
751                         `(,name = ,expr)))
752                     
753                      (($ nemo:quantity 'RATE name initial rhs power u)
754                       (let ((expr (expr->ncml-expr rhs))
755                             (initial (and initial (expr->text-expr initial)))
756                             (power (or (and power (expr->text-expr power))
757                                        (expr->text-expr 1.0))))
758
759                         `(d (,name) = (,expr)
760                             (initial: ,initial)
761                             (power: ,power))
762                         ))
763
764                     
765                      (($ nemo:quantity 'REACTION name initial open trs cons p u) 
766                       (let ((sxml-trs (append-map transition->text-transition trs)))
767                         `(reaction  ,name
768                                     (open-state: ,open) 
769                                     (initial: ,(expr->text-expr initial))
770                                     (conserve: ,(map (conseq->text-conseq identity) cons))
771                                     (transitions: ,text-trs)
772                                     (power: ,(expr->ncml-expr p))
773                                     )))
774
775                     
776                      (($ nemo:quantity 'COMPONENT name type lst) 
777                       (let ((component->text (make-component->text dis model parse-expr))
778                             (component-exports ((dis 'component-exports) model x)))
779                         (case type
780                           ((toplevel) `(,@(map component->text lst)
781                                         ,@(map (lambda (x) `(output ,x)) component-exports)))
782                           (else `(component ,name (type: ,(->string type) )
783                                                  ,@(filter-map component->text lst)
784                                                  ,@(map (lambda (x) `(output ,x)) component-exports)
785                                                  )))))
786                     
787                      (($ nemo:quantity 'FUNCTOR name args type lst) 
788                       (let ((component->ncml (make-component->ncml dis model parse-expr)))
789                         `(functor ,name (type: ,(->string type) )
790                                   (parameters: ,(string-intersperse (map ->string args) ","))
791                                   ,@(filter-map (declaration->ncml parse-expr) lst)
792                                   )))
793                     
794                      (else #f)))
795              ))
796    ))
797   
798
799(define (model->text model parse-expr)
800  (match-let ((($ nemo:quantity 'DISPATCH  dis)     
801               (hash-table-ref model (nemo-intern 'dispatch))))
802     (let ((sysname     ((dis 'sysname) model))
803           (component->text (make-component->text dis model parse-expr)))
804       `(model ,sysname ,@(component->text (nemo-intern 'toplevel)))
805       )))
806           
807
808(include "expr-parser.scm")
809(include "SXML.scm")
810(include "SXML-to-XML.scm")
811(include "stx-engine.scm")
812
813
814(define null-template 
815  `(*default* ,(lambda (node bindings root env) 
816                 (begin
817                   (warn "Unrecognized input element:" node)
818                   '()))))
819
820
821(define-syntax  sxml:make-null-ss
822   (syntax-rules  ()
823      ((stx rule ...)
824       (list
825        ; default handler
826        null-template
827        ; handler for textual nodes
828        (list '*text*  (lambda (text) text)) 
829        rule ...))))
830
831
832(define (ensure-xmlns doc)
833  (let ((doc1 (sxml:add-attr doc '(xmlns:ncml "ncml"))))
834    (sxml:add-attr doc1 '(xmlns ncml))))
835
836
837;; based on SRV:send-reply by Oleg Kiselyov
838(define (print-fragments b)
839  (let loop ((fragments b) (result #f))
840    (cond
841      ((null? fragments) result)
842      ((not (car fragments)) (loop (cdr fragments) result))
843      ((null? (car fragments)) (loop (cdr fragments) result))
844      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
845      ((pair? (car fragments))
846        (loop (cdr fragments) (loop (car fragments) result)))
847      ((procedure? (car fragments))
848        ((car fragments))
849        (loop (cdr fragments) #t))
850      (else
851       (display (car fragments))
852       (loop (cdr fragments) #t)))))
853
854
855(define (ncml->declarations ncml:model parse-expr)
856  (letrec
857       ((label-template 
858        (sxml:match 'ncml:label
859                    (lambda (node bindings root env) 
860                      (let ((id   (sxml:attr node 'id))
861                            (v    (or (sxml:attr node 'value)
862                                      (sxml:text node)))
863                            )
864                        (if (not id) (error 'output-template "label declaration requires id attribute"))
865                        `(label ,($ id) = ,($ v))))))
866       
867        (input-template 
868         (sxml:match 'ncml:input
869                     (lambda (node bindings root env) 
870                       (let ((id    (or (sxml:attr node 'id) (sxml:attr node 'name)))
871                             (from  (sxml:attr node 'from))
872                             (as    (sxml:attr node 'as))
873                             (unit  (sxml:attr node 'unit))
874                             )
875                         (if (not id) (error 'input-template "input declaration requires id attribute"))
876                         (cond ((and from as unit)
877                                `(input (,($ id) as ,($ as ) from ,($ from) (unit ,($ unit)))))
878                               ((and from as)
879                                `(input (,($ id) as ,($ as ) from ,($ from) )))
880                               ((and from unit)
881                                `(input (,($ id) from ,($ from) (unit ,($ unit)))))
882                               (from
883                                `(input (,($ id) from ,($ from))))
884                               (as             
885                                `(input (,($ id) as ,($ as))))
886                               ((and as unit)
887                                `(input (,($ id) as ,($ as) (unit ,($ unit)))))
888                               (else          
889                                `(input ,($ id))))
890                         ))
891                     ))
892       
893       (output-template 
894        (sxml:match 'ncml:output
895                    (lambda (node bindings root env) 
896                      (let ((id   (or (sxml:attr node 'id)
897                                      (sxml:attr node 'name))))
898                        (if (not id) (error 'output-template "output declaration requires id attribute"))
899                        `(output ,($ id))))))
900       
901       (const-template 
902        (sxml:match 'ncml:const
903                    (lambda (node bindings root env) 
904                      (let* ((unit (sxml:attr node 'unit))
905                             (id   (or (sxml:attr node 'id)
906                                       (sxml:attr node 'name)))
907                             (expr ((lambda (x) 
908                                      (if (not x) 
909                                          (error 'const-template "const declaration " id " requires expr element")
910                                          (parse-expr (second x) id)))
911                                   (or (sxml:kidn* 'ncml:expr node)
912                                       (let ((vattr (sxml:attr node 'value)))
913                                         (and vattr (list 'value vattr )))
914                                       (list 'value (sxml:text node))
915                                       )
916                                   )))
917                        (if (not id) (error 'const-template "const declaration requires id attribute"))
918                        (if unit
919                            `(const ,($ id) = ,expr (unit ,($ unit)))
920                            `(const ,($ id) = ,expr)
921                            )
922                        ))
923                    ))
924       
925       (reaction-transition-template 
926        (sxml:match 'ncml:transition
927                    (lambda (node bindings root env) 
928                      (let (
929                            (src  (sxml:attr node 'src))
930                            (dst  (sxml:attr node 'dst))
931                            (rate  ((lambda (x) 
932                                      (if (not x) 
933                                          (error 'reaction-transition-template 
934                                                 "reaction transition requires rate element")
935                                          (parse-expr (second x))))
936                                    (sxml:kidn* 'ncml:rate node))))
937                        (if (not src) (error 'reaction-transition-template
938                                             "reaction transition requires src attribute"))
939                        (if (not dst) (error 'reaction-transition-template
940                                             "reaction transition requires dst attribute"))
941                       
942                        `(-> ,($ src) ,($ dst) ,rate)))))
943       
944       (asgn-template 
945        (sxml:match 'ncml:asgn
946                    (lambda (node bindings root env) 
947                      (let* ((unit (sxml:attr node 'unit))
948                             (id   (or (sxml:attr node 'id) (sxml:attr node 'name)))
949                             (expr ((lambda (x) 
950                                      (if (not x) 
951                                          (error 'asgn-template "algebraic assignment requires expr element")
952                                          (parse-expr (second x) id)))
953                                    (or (sxml:kidn* 'ncml:expr node)
954                                        (list 'expr (sxml:text node))
955                                        ))
956                                   )
957                             )
958                        (if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
959                        (if unit
960                            `(,($ id) = ,expr)
961                            `(,($ id) = ,expr (unit ,($ unit))))
962                        ))
963                    ))
964       
965       (rate-template 
966        (sxml:match 'ncml:rate
967                    (lambda (node bindings root env) 
968                      (let* ((unit (sxml:attr node 'unit))
969                             (id   (or (sxml:attr node 'id) (sxml:attr node 'name)))
970                             (rhs  ((lambda (x) 
971                                      (if (not x) 
972                                          (error 'rate-template "rate equation requires expr element")
973                                          (parse-expr (second x) id)))
974                                    (sxml:kidn* 'ncml:expr node)))
975                             (initial ((lambda (x) (and x (parse-expr (second x) id)))
976                                       (sxml:kidn* 'ncml:initial node)))
977                             (power ((lambda (x) (and x (parse-expr (second x) id)))
978                                     (sxml:kidn* 'ncml:power node)))
979                             )
980                        (if (not id) (error 'rate-template "rate equation requires id attribute"))
981                        (if unit
982                            `(d (,($ id)) = ,rhs ,(and initial `(initial ,initial) )
983                                ,(and power `(power ,power) ) (unit ,($ unit)))
984                            `(d (,($ id)) = ,rhs ,(and initial `(initial ,initial) )
985                                ,(and power `(power ,power) ))
986                            )
987                        ))
988                    ))
989
990       (transient-template 
991        (sxml:match 'ncml:transient
992                    (lambda (node bindings root env) 
993                      (let* ((unit  (sxml:attr node 'unit))
994                             (id    (or (sxml:attr node 'id) (sxml:attr node 'name)))
995                             (rhs   ((lambda (x) 
996                                       (if (not x) 
997                                           (error 'rate-template "rate equation requires expr element")
998                                           (parse-expr (second x) id)))
999                                     (sxml:kidn* 'ncml:expr node)))
1000                             (initial ((lambda (x) (and x (parse-expr (second x) id)))
1001                                       (sxml:kidn* 'ncml:initial node)))
1002                             (onevent ((lambda (x) (and x (parse-expr (second x) id)))
1003                                       (sxml:kidn* 'ncml:onevent node)))
1004                             (power ((lambda (x) (and x (parse-expr (second x) id)))
1005                                     (sxml:kidn* 'ncml:power node)))
1006                             )
1007                        (if (not id) (error 'transient-template "transient equation requires id attribute"))
1008                        (if unit
1009                            `(transient (,($ id)) = ,rhs (onevent ,onevent) 
1010                                        ,(and initial `(initial ,initial) )
1011                                        ,(and power `(power ,power) ))
1012                            `(transient (,($ id)) = ,rhs (onevent ,onevent) 
1013                                        ,(and initial `(initial ,initial) )
1014                                        ,(and power `(power ,power) )
1015                                        (unit ,($ unit)))
1016                            )
1017                        ))
1018                    ))
1019
1020
1021       (conseq-template 
1022        (sxml:match 'ncml:conseq
1023                    (lambda (node bindings root env) 
1024                      (let ((val   (string->number (->string (sxml:attr node 'val))))
1025                            (rhs   ((lambda (x) 
1026                                        (if (not x) 
1027                                            (error 'conseq-template 
1028                                                   "conseq definition requires expr element")
1029                                            (parse-expr (second x))))
1030                                      (sxml:kidn* 'ncml:expr node))))
1031                        `(,val = ,rhs)))))
1032       
1033       (reaction-template 
1034        (sxml:match 'ncml:reaction
1035                    (lambda (node bindings root env) 
1036                      (let* ((unit    (sxml:attr node 'unit))
1037                             (id      ($ (or (sxml:attr node 'id) (sxml:attr node 'name))))
1038                             (initial ((lambda (x) (and x (parse-expr (second x) id)))
1039                                       (sxml:kidn* 'ncml:initial node)))
1040                             
1041                             (open    ((lambda (x) 
1042                                        (if (not x) 
1043                                            (error 'reaction-template
1044                                                   "reaction declaration requires open element")
1045                                            (let ((os (string-split (second x) ",")))
1046                                              (map $ os))))
1047                                       (sxml:kidn* 'ncml:open node)))
1048                             
1049                             (conserve ((lambda (x) 
1050                                          (and x (let ((tmpl (sxml:make-null-ss conseq-template)))
1051                                                   (stx:apply-templates (cdr x) tmpl root env))))
1052                                        (sxml:kidn* 'ncml:conserve node)))
1053                             
1054                             (power ((lambda (x) 
1055                                       (if (not x) 
1056                                           (error 'reaction-template
1057                                                  "reaction declaration requires open element")
1058                                           (parse-expr (second x) id)))
1059                                     (sxml:kidn* 'ncml:power node)))
1060                             
1061                             (transitions ((lambda (x) 
1062                                             (if (not x) 
1063                                                 (error 'reaction-template
1064                                                        "reaction declaration requires transitions element")
1065                                                 (let ((tmpl (sxml:make-null-ss reaction-transition-template)))
1066                                                   (stx:apply-templates (cdr x) tmpl root env))))
1067                                           (sxml:kidn* 'ncml:transitions node)))
1068                             
1069                            )
1070                                         
1071                        (if (not id) (error 'reaction-template "reaction declaration requires id attribute"))
1072                        (if unit
1073                            `(reaction (,id (initial ,initial) (open ,open) (power ,power) 
1074                                            ,(and conserve `(conserve ,conserve) )
1075                                            (transitions ,@transitions)
1076                                            (unit ,($ unit))))
1077                            `(reaction (,id (initial ,initial) (open ,open) (power ,power) 
1078                                            ,(and conserve `(conserve ,conserve) )
1079                                            (transitions ,@transitions)))
1080                            )
1081                        ))
1082                    ))
1083
1084
1085       (defun-template 
1086        (sxml:match 'ncml:defun
1087                    (lambda (node bindings root env) 
1088
1089                      (let* ((id    (or (sxml:attr node 'id) (sxml:attr node 'name)))
1090                             (args  ((lambda (x) 
1091                                       (if (null? x) 
1092                                           (error 'defun-template 
1093                                                  "function definition requires at least one arg element")
1094                                           (map (compose $ second) x)))
1095                                     (sxml:kidsn 'ncml:arg node)))
1096                             (body ((lambda (x) 
1097                                      (if (not x) 
1098                                          (error 'defun-template
1099                                                 "function definition requires body element")
1100                                          (parse-expr (second x) id)))
1101                                    (sxml:kidn* 'ncml:body node))))
1102                        (if (not id) (error 'defun-template "function definition requires id attribute"))
1103
1104                        `(defun ,($ id) ,args ,body)))))
1105
1106       (component-template
1107        (sxml:match 'ncml:component
1108                    (lambda (node bindings root env)
1109
1110                      (let ((name (sxml:attr node 'name))
1111                            (functor-name (or (sxml:attr node 'functor-name)
1112                                              (sxml:attr node 'functor)))
1113                            (type (sxml:attr node 'type)))
1114
1115                        (if (and (not functor-name) (not type) )
1116                            (error 'component-template "component definition requires type attribute" name))
1117                        (if (and functor-name (not name) )
1118                            (error 'component-template "component definition requires name attribute"))
1119                        (if functor-name
1120                            `(component (name ,($ name)) = ,($ functor-name) 
1121                                        ,(ncml->declarations (sxml:kids node) parse-expr))
1122                            (if name
1123                                `(component (type ,($ type)) (name ,($ name)) 
1124                                            ,@(ncml->declarations (sxml:kids node) parse-expr))
1125                                `(component (type ,($ type)) 
1126                                            ,@(ncml->declarations (sxml:kids node) parse-expr))
1127                                ))
1128                        ))
1129                    ))
1130
1131       (functor-template
1132        (sxml:match 'ncml:functor
1133                    (lambda (node bindings root env)
1134
1135                      (let ((parameters (sxml:attr node 'parameters))
1136                            (name (sxml:attr node 'name))
1137                            (type (sxml:attr node 'type)))
1138                        (if (not type) (error 'functor-template "functor definition requires type attribute"))
1139                        (if (not name) (error 'functor-template "functor definition requires name attribute"))
1140                        (if (not parameters) 
1141                            (error 'functor-template "functor definition requires parameters attribute"))
1142                        `(functor (name ,($ name)) (type ,($ type)) 
1143                                  ,(map $ (string-split parameters ","))
1144                                  = . ,(ncml->declarations (sxml:kids node) parse-expr))))))
1145
1146       (hh-template 
1147        (sxml:match 'ncml:hh_ionic_gate 
1148                    (lambda (node bindings root env)
1149                      (let* (
1150                             (id         (or (sxml:attr node 'id) (sxml:attr node 'name)))
1151                             (and-expr   (lambda (x) (and x (parse-expr (second x) id))))
1152                             (initial_m  (and-expr (sxml:kidn* 'ncml:initial_m node)))
1153                             (initial_h  (and-expr (sxml:kidn* 'ncml:initial_h node)))
1154                             (m_power    (and-expr (sxml:kidn* 'ncml:m_power node)))
1155                             (h_power    (and-expr (sxml:kidn* 'ncml:h_power node)))
1156                             (m_alpha    (and-expr (sxml:kidn* 'ncml:m_alpha node)))
1157                             (m_beta     (and-expr (sxml:kidn* 'ncml:m_beta node)))
1158                             (h_alpha    (and-expr (sxml:kidn* 'ncml:h_alpha node)))
1159                             (h_beta     (and-expr (sxml:kidn* 'ncml:h_beta node)))
1160                             (m_tau      (and-expr (sxml:kidn* 'ncml:m_tau node)))
1161                             (m_inf      (and-expr (sxml:kidn* 'ncml:m_inf node)))
1162                             (h_tau      (and-expr (sxml:kidn* 'ncml:h_tau node)))
1163                             (h_inf      (and-expr (sxml:kidn* 'ncml:h_inf node)))
1164                             )
1165
1166                        (if (not id)
1167                            (error 'hh-template "hh ionic conductance definition requires id attribute"))
1168                        `(hh-ionic-gate 
1169                          (,($ id)
1170                           ,@(if initial_m `((initial-m ,initial_m)) `())
1171                           ,@(if initial_h `((initial-h ,initial_h)) `())
1172                           ,@(if m_power `((m-power ,m_power)) '())
1173                           ,@(if h_power `((h-power ,h_power)) '())
1174                           ,@(if m_alpha `((m-alpha ,m_alpha)) '())
1175                           ,@(if h_alpha `((h-alpha ,h_alpha)) '())
1176                           ,@(if m_beta  `((m-beta ,m_beta)) '())
1177                           ,@(if h_beta  `((h-beta ,h_beta)) '())
1178                           ,@(if m_inf   `((m-inf ,m_inf)) '())
1179                           ,@(if h_inf   `((h-inf ,h_inf)) '())
1180                           ,@(if m_tau   `((m-tau ,m_tau)) '())
1181                           ,@(if h_tau   `((h-tau ,h_tau)) '())
1182                           ))))))
1183
1184       (decaying-pool-template 
1185        (sxml:match 'ncml:decaying_pool 
1186                    (lambda (node bindings root env)
1187                      (let* ((id         (sxml:attr node 'id))
1188                             (and-expr   (lambda (x) (and x (parse-expr (second x) id))))
1189                             (initial    (and-expr (sxml:kidn* 'ncml:initial node)))
1190                             (beta       (and-expr (sxml:kidn* 'ncml:beta node)))
1191                             (depth      (and-expr (sxml:kidn* 'ncml:depth node)))
1192                             (temp-adj   (and-expr (sxml:kidn* 'ncml:temp_adj node))))
1193                        (if (not id)
1194                            (error 'decaying-pool-template "decaying pool definition requires id attribute"))
1195                        (if (not initial) 
1196                            (error 'decaying-pool-template "decaying pool definition requires initial value"))
1197                        (if (not beta) 
1198                            (error 'decaying-pool-template "decaying pool definition requires beta parameter"))
1199                        (if (not depth) 
1200                            (error 'decaying-pool-template "decaying pool definition requires depth parameter"))
1201                           
1202                        `(decaying-pool 
1203                          (,($ id)
1204                           ,@(if temp_adj `((temp_adj ,temp_adj)) `())
1205                           (beta ,beta)
1206                           (depth ,depth)
1207                           (initial ,initial)))))))
1208        )
1209
1210     (stx:apply-templates ncml:model 
1211                          (sxml:make-null-ss label-template
1212                                             input-template
1213                                             output-template
1214                                             const-template
1215                                             asgn-template
1216                                             rate-template
1217                                             reaction-template
1218                                             transient-template
1219                                             defun-template
1220                                             component-template
1221                                             functor-template
1222                                             hh-template
1223                                             decaying-pool-template) 
1224                          ncml:model (list))))
1225
1226
1227(define sxslt-preamble
1228  `(
1229    (import scheme chicken)
1230    (require-extension sxml-transforms sxpath sxpath-lolevel) 
1231    (define-syntax  sxml:match
1232      (syntax-rules  ()
1233        ((match pattern handler)
1234         (list (if (symbol? pattern) pattern (sxpath pattern))
1235               handler))
1236        ))
1237    (define identity-template 
1238      `(*default* ,(lambda (node bindings root env) 
1239                     (begin
1240                       node))))
1241    (define-syntax sxml:make-ss
1242      (syntax-rules  ()
1243        ((stx rule ...)
1244         (list
1245          identity-template
1246          (list '*text*  (lambda (text) text)) 
1247          rule ...))
1248        ))
1249    (define (sxml:kid node)
1250      (let ((v ((select-first-kid
1251                 (lambda (x) (not (eq? (car x) '@)))) node)))
1252        (if (not v)
1253            (error 'sxml:kid "node does not have children" node)  v)))
1254    (define (sxml:kids node)
1255      ((select-kids (lambda (x) (not (eq? (car x) '@)))) node))
1256    (define (sxml:kidsn name node)
1257      ((select-kids (lambda (x) (eq? (car x) name))) node))
1258    (define (sxml:kidn name node)
1259      ((select-first-kid (lambda (x)  (eq? (car x) name))) node)) 
1260    ))
1261
1262
1263(define (ncml->model-decls options doc)
1264
1265  (define (load-ss in)
1266    (eval `(begin
1267             ,@sxslt-preamble
1268             (sxml:make-ss ,@(read in))
1269             )))
1270
1271  (define (make-ss-fname dirname fname) 
1272    (or (and dirname (make-pathname dirname fname)) fname))
1273
1274  (let* ((source-path   (lookup-def 'source-path options))
1275         (dirname       (pathname-directory source-path))
1276         (parse-expr    (or (lookup-def 'parse-expr options) identity))
1277         (ncml:model    ((lambda (x) 
1278                           (if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x)))
1279                         (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
1280         (model-name     ($ (or (sxml:attr ncml:model 'name) (gensym 'model))))
1281         (membraneprops  (ncml:sxpath '(// cell biophysicalProperties membraneProperties) 
1282                                      `(*TOP* . ,ncml:model)))
1283         (ncml-ss        (ncml:sxpath '(// ncml:sxslt) `(*TOP* . ,ncml:model)))
1284         (ncml-templates (ncml:sxpath '(// ncml:template) `(*TOP* . ,ncml:model)))
1285         (ncml-decls     ((lambda (doc) 
1286                            (if (null? ncml-ss) doc
1287                                (let ((ss (map
1288                                           (lambda (x)
1289                                             (let ((fn (sxml:attr x 'filename)))
1290                                               (or (and fn (call-with-input-file (make-ss-fname dirname fn) load-ss))
1291                                                   (call-with-input-string (sxml:text x) load-ss))
1292                                               ))
1293                                           ncml-ss)))
1294                                  (fold (lambda (s doc) (stx:apply-templates doc s doc (list))) doc ss))
1295                                ))
1296                          (if (null? membraneprops) 
1297                              (sxml:kids ncml:model) 
1298                              (sxml:kids membraneprops))))
1299         (dd  (if (lookup-def 'debug options)
1300                  (begin (pp ncml-decls))))
1301         (model-decls    (ncml->declarations ncml-decls parse-expr))
1302         (user-templates (map (lambda (t)
1303                                 (let ((name (or (sxml:attr t 'name) (->string (gensym 'template))))
1304                                       (args (or (let ((xs (sxml:attr t 'args)))
1305                                                   (or (and xs (string-split xs ",")) '())))))
1306                                   (list name args (ersatz:statements-from-string 
1307                                                    (ersatz:template-std-env)
1308                                                    (sxml:text t)))
1309                                   ))
1310                               ncml-templates))
1311         )
1312    (list model-name model-decls user-templates)))
1313
1314
1315(define (ncml-model-decls->model options model-name model-decls)
1316
1317    (if (or (null? model-decls)  (and (pair? model-decls) (every null? model-decls)))
1318        (error 'ncml-model-decls->model "ncml declaration elements not found in input document"))
1319
1320    (let* ((model+nemo  (nemo-constructor model-name model-decls (lambda (x . rest) (identity x))))
1321           (model       (first model+nemo))
1322           (nemo        (second model+nemo)))
1323
1324      (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) (lambda (x . rest) (identity x)))))
1325
1326        (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
1327        (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))     
1328        (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
1329        (if (assoc 'components options)
1330            (for-each (lambda (x) 
1331                        (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
1332                        (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
1333                      ((nemo 'components) model-1)))
1334        model-1)))
1335
1336
1337(define (entry->surface-xml x . rest)
1338  (let-optionals rest ((ns-prefix "ncml"))
1339
1340    (let ((ns-prefix (if (or (not ns-prefix) (string-null? ns-prefix)) ""
1341                         (string-append ns-prefix ":")))
1342          (xmlstr (lambda (x) (let recur ((x x)) 
1343                                (if (pair? x) (map recur x) 
1344                                    (let ((v (string->goodHTML (->string x))))
1345                                      (if (pair? v) (string-concatenate v) v)))
1346                                ))
1347                  ))
1348
1349      (let ((transition-str
1350             (lambda (t)
1351               (match t
1352                      (('-> src dst rate) 
1353                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1354                                ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix))
1355
1356                      ((src '-> dst rate) 
1357                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1358                                ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix))
1359
1360                      (('<-> src dst rate1 rate2) 
1361                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1362                                ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix
1363                                ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix
1364                                ))
1365
1366                      ((src '<-> dst rate1 rate2) 
1367                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1368                                ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix
1369                                ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix
1370                                ))
1371
1372                      (else (error 'transition-str "invalid transition " x))))
1373               )
1374               
1375            (ionic-gate-str
1376             (lambda (ion #!key 
1377                          (initial-m-expr #f)
1378                          (initial-h-expr #f)
1379                          (m-power #f)
1380                          (h-power #f)
1381                          (m-inf-expr #f)
1382                          (m-tau-expr #f)
1383                          (h-inf-expr #f)
1384                          (h-tau-expr #f)
1385                          (m-alpha-expr #f)
1386                          (m-beta-expr #f)
1387                          (h-alpha-expr #f)
1388                          (h-beta-expr #f))
1389
1390               (let ((initial-m-str (or (and initial-m-expr
1391                                                  (sprintf "<~Ainitial_m>~A</~Ainitial_m>~%" 
1392                                                           ns-prefix (xmlstr initial-m-expr) ns-prefix)) ""))
1393                     (initial-h-str (or (and initial-h-expr
1394                                                  (sprintf "<~Ainitial_h>~A</~Ainitial_h>~%" 
1395                                                           ns-prefix (xmlstr initial-h-expr) ns-prefix)) ""))
1396
1397                     (m-power-str  (or (and m-power
1398                                                  (sprintf "<~Am_power>~A</~Am_power>~%" 
1399                                                           ns-prefix m-power ns-prefix)) ""))
1400                     (h-power-str  (or (and h-power
1401                                                  (sprintf "<~Ah_power>~A</~Ah_power>~%" 
1402                                                           ns-prefix h-power ns-prefix)) ""))
1403
1404                     (m-inf-str (or (and m-inf-expr
1405                                         (sprintf "<~Am_inf>~A</~Am_inf>~%" 
1406                                                  ns-prefix (xmlstr m-inf-expr) ns-prefix)) ""))
1407                     (m-tau-str (or (and m-tau-expr
1408                                         (sprintf "<~Am_tau>~A</~Am_tau>~%" 
1409                                                  ns-prefix (xmlstr m-tau-expr) ns-prefix)) ""))
1410
1411                     (h-inf-str (or (and h-inf-expr
1412                                         (sprintf "<~Ah_inf>~A</~Ah_inf>~%" 
1413                                                  ns-prefix (xmlstr h-inf-expr) ns-prefix)) ""))
1414                     (h-tau-str (or (and h-tau-expr
1415                                         (sprintf "<~Ah_tau>~A</~Ah_tau>~%" 
1416                                                  ns-prefix (xmlstr h-tau-expr) ns-prefix)) ""))
1417
1418                     (m-alpha-str (or (and m-alpha-expr
1419                                           (sprintf "<~Am_alpha>~A</~Am_alpha>~%" 
1420                                                    ns-prefix (xmlstr m-alpha-expr) ns-prefix)) ""))
1421                     (m-beta-str (or (and m-beta-expr
1422                                          (sprintf "<~Am_beta>~A</~Am_beta>~%" 
1423                                                   ns-prefix (xmlstr m-beta-expr) ns-prefix)) ""))
1424
1425                     (h-alpha-str (or (and h-alpha-expr
1426                                           (sprintf "<~Ah_alpha>~A</~Ah_alpha>~%" 
1427                                                    ns-prefix (xmlstr h-alpha-expr) ns-prefix)) ""))
1428                     (h-beta-str (or (and h-beta-expr
1429                                          (sprintf "<~Ah_beta>~A</~Ah_beta>~%" 
1430                                                   ns-prefix (xmlstr h-beta-expr) ns-prefix)) ""))
1431                     )
1432                 
1433                 (sprintf "<~Ahh_ionic_gate name=\"~A\">~A</~Ahh_ionic_gate>~%"
1434                          ns-prefix ion   
1435                          (string-append initial-m-str initial-h-str
1436                                         m-power-str h-power-str m-inf-str 
1437                                         m-tau-str h-inf-str h-tau-str
1438                                         m-alpha-str m-beta-str h-alpha-str h-beta-str
1439                                         )
1440                          ns-prefix))
1441               )))
1442
1443    (match x
1444         (('nemo-model name decls)
1445          (map entry->surface-xml decls))
1446
1447         (('output . names)
1448          (string-concatenate (map (lambda (name) (sprintf "<~Aoutput name=\"~A\"/>~%" ns-prefix name)) names)))
1449
1450         (('input . names)
1451          (string-concatenate (map (lambda (name) 
1452                                     (match name
1453                                            ((and name (? symbol?)) 
1454                                             (sprintf "<~Ainput name=\"~A\"/>~%" ns-prefix name))
1455
1456                                            ((name 'from ns)
1457                                             (sprintf "<~Ainput name=\"~A\" from=\"~A\"/>~%" ns-prefix name ns))
1458                                           
1459                                            ))
1460                                   names)))
1461
1462         (('const name '= value)
1463          (if (number? value)
1464              (sprintf "<~Aconst name=\"~A\" value=\"~A\"/>~%"
1465                      ns-prefix name value)
1466              (sprintf "<~Aconst name=\"~A\">~%~A~%</~Aconst>~%"
1467                       ns-prefix name (xmlstr value) ns-prefix)
1468              ))
1469
1470         (((or 'defun 'fun) name args body)
1471          (sprintf "<~Adefun name=\"~A\">~%~A~%<~Abody>~A</~Abody>~%</~Adefun>~%"
1472                   ns-prefix
1473                   name (string-concatenate (map (lambda (x) (sprintf "<~Aarg>~A</~Aarg>" ns-prefix x ns-prefix)) args)) 
1474                   ns-prefix (xmlstr body) ns-prefix ns-prefix))
1475         
1476         ((name '= expr)
1477          (sprintf "<~Aasgn name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Aasgn>~%"
1478                  ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix))
1479         
1480         (('d ( name ) '= expr)
1481          (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Arate>~%"
1482                  ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix))
1483         
1484         (('d ( name ) '= expr ('initial initial-expr))
1485          (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Ainitial>~A</~Ainitial>~%</~Arate>~%"
1486                   ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix))
1487
1488         (((or 't 'T 'transient) ( name ) '= expr ('onevent event-expr) ('initial initial-expr))
1489          (sprintf "<~Atransient name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Aonevent>~A</~Aonevent>~%<~Ainitial>~A</~Ainitial>~%</~Atransient>~%"
1490                   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))
1491
1492         (('reaction ( name ('transitions . transitions) ('conserve conserve) ('initial . initial-expr) ('open . open) ('power power)))
1493          (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%<~Ainitial>~A</~Ainitial>~%</~Areaction>~%"
1494                   ns-prefix name 
1495                   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
1496                   ns-prefix (xmlstr power) ns-prefix
1497                   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
1498                   ns-prefix (xmlstr initial-expr) ns-prefix
1499                   ns-prefix))
1500
1501         (('reaction ( name ('transitions . transitions) ('conserve conserve) ('open . open) ('power power)))
1502          (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%"
1503                   ns-prefix name 
1504                   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
1505                   ns-prefix (xmlstr power) ns-prefix
1506                   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
1507                   ns-prefix))
1508
1509         (('reaction ( name ('transitions . transitions) ('open . open) ('power power)))
1510          (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%"
1511                   ns-prefix name 
1512                   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
1513                   ns-prefix (xmlstr power) ns-prefix
1514                   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
1515                   ns-prefix))
1516
1517         
1518         (('hh-ionic-gate 
1519           (ion
1520            ('initial-m  initial-m-expr)
1521            ('initial-h  initial-h-expr)
1522            ('m-power    m-power)
1523            ('h-power    h-power)
1524            ('m-inf      m-inf-expr)
1525            ('m-tau      m-tau-expr)
1526            ('h-inf      h-inf-expr)
1527            ('h-tau      h-tau-expr)
1528            ))
1529
1530          (ionic-gate-str ion 
1531                          initial-m-expr: initial-m-expr
1532                          initial-h-expr: initial-h-expr
1533                          m-power: m-power
1534                          h-power: h-power
1535                          m-inf-expr: m-inf-expr
1536                          m-tau-expr: m-tau-expr
1537                          h-inf-expr: h-inf-expr
1538                          h-tau-expr: h-tau-expr))
1539
1540         
1541         (('hh-ionic-gate 
1542           (ion
1543            ('initial-m  initial-m-expr)
1544            ('m-power    m-power)
1545            ('h-power    h-power)
1546            ('m-inf      m-inf-expr)
1547            ('m-tau      m-tau-expr)
1548            ))
1549
1550          (ionic-gate-str ion 
1551                          initial-m-expr: initial-m-expr
1552                          m-power: m-power
1553                          h-power: h-power
1554                          m-inf-expr: m-inf-expr
1555                          m-tau-expr: m-tau-expr))
1556         
1557         (('hh-ionic-gate 
1558           (ion
1559            ('initial-m  initial-m-expr)
1560            ('m-power    m-power)
1561            ('h-power    h-power)
1562            ('m-tau      m-tau-expr)
1563            ('m-inf      m-inf-expr)
1564            ))
1565
1566          (ionic-gate-str ion 
1567                          initial-m-expr: initial-m-expr
1568                          m-power: m-power
1569                          h-power: h-power
1570                          m-inf-expr: m-inf-expr
1571                          m-tau-expr: m-tau-expr))
1572         
1573         (('hh-ionic-gate 
1574           (ion
1575            ('initial-m  initial-m-expr)
1576            ('initial-h  initial-h-expr)
1577            ('m-power    m-power)
1578            ('h-power    h-power)
1579            ('m-alpha      m-alpha-expr)
1580            ('m-beta       m-beta-expr)
1581            ('h-alpha      h-alpha-expr)
1582            ('h-beta       h-beta-expr)
1583            ))
1584
1585          (ionic-gate-str ion 
1586                          initial-m-expr: initial-m-expr
1587                          initial-h-expr: initial-h-expr
1588                          m-power: m-power
1589                          h-power: h-power
1590                          m-alpha-expr: m-alpha-expr
1591                          m-beta-expr: m-beta-expr
1592                          h-alpha-expr: h-alpha-expr
1593                          h-beta-expr: h-beta-expr))
1594         
1595         (('hh-ionic-gate 
1596           (ion
1597            ('initial-m  initial-m-expr)
1598            ('m-power    m-power)
1599            ('h-power    h-power)
1600            ('m-alpha      m-alpha-expr)
1601            ('m-beta       m-beta-expr)
1602            ))
1603
1604          (ionic-gate-str ion 
1605                          initial-m-expr: initial-m-expr
1606                          m-power: m-power
1607                          h-power: h-power
1608                          m-alpha-expr: m-alpha-expr
1609                          m-beta-expr: m-beta-expr))
1610
1611         
1612         (('component ('type ty) ('name name) . rest) 
1613          (sprintf "<~Acomponent type=\"~A\" name=\"~A\">~%~A</~Acomponent>~%" 
1614                  ns-prefix ty name (string-concatenate (map entry->surface-xml rest)) ns-prefix ))
1615
1616         (('component ('type ty) . rest) 
1617          (sprintf "<~Acomponent type=\"~A\">~%~A</~Acomponent>~%" 
1618                   ns-prefix ty (string-concatenate (map entry->surface-xml rest)) ns-prefix ))
1619
1620
1621         (else (error 'nemo "unknown declaration" x))
1622
1623         )))
1624))
1625
1626
1627(define (partition-model opt decls)
1628  (let recur ((bkts '()) (toplevel '()) (decls decls))
1629    (if (null? decls)
1630        (list bkts (reverse toplevel))
1631        (let ((decl (car decls)))
1632          (if (opt 'debug)
1633              (begin (print "partition-model: decl = ")
1634                     (pp decl)))
1635          (match decl (((or 'component 'COMPONENT)
1636                        ((or 'type 'TYPE) typ) 
1637                        ((or 'name 'NAME) name) . lst)
1638                       (let ((bkt (alist-ref name bkts)))
1639                         (if bkt (recur (alist-update name (cons decl bkt) bkts)
1640                                        toplevel (cdr decls))
1641                             (recur (alist-update name (list decl) bkts)
1642                                    toplevel (cdr decls)))))
1643                 (else (recur bkts (cons decl toplevel) (cdr decls)))))
1644        )))
1645
1646
1647(define (process-model opt source-path in-format prefix sys model-decls iexpr? parse-expr)
1648               
1649  (match-let ((($ nemo:quantity 'DISPATCH  dis) 
1650               (hash-table-ref sys (nemo-intern 'dispatch))))
1651                                   
1652     (let* (
1653            (sysname             ((lambda (x) (or (and prefix ($ (s+ prefix "_" x))) x)) ((dis 'sysname) sys)))
1654            (dirname             (pathname-directory source-path))
1655            (plain-fname         (make-output-fname dirname sysname ".txt"  (opt 'plain) ))
1656            (sxml-fname          (make-output-fname dirname sysname  ".sxml" (opt 'sxml) ))
1657            (surface-xml-fname   (make-output-fname dirname sysname ".xml"  (opt 'surface-xml) ))
1658            (xml-fname           (make-output-fname dirname sysname ".xml"  (opt 'xml) ))
1659            (pyparams-fname      (make-output-fname dirname sysname ".py"  (opt 'pyparams) ))
1660            (mod-fname           (make-output-fname dirname sysname ".mod"  (opt 'nmodl)))
1661            (vclamp-ses-fname    (make-output-fname dirname sysname "_vclamp.hoc" (opt 'vclamp-hoc) ))
1662            (vclamp-octave-fname (make-output-fname dirname sysname "_vclamp.m" (opt 'vclamp-octave) ))
1663            (iclamp-ses-fname    (make-output-fname dirname sysname "_iclamp.hoc" (opt 'iclamp-hoc) ))
1664            (iclamp-sli-fname    (make-output-fname dirname sysname "_iclamp.sli" (opt 'iclamp-nest) ))
1665                 
1666            (pyparams       (opt 'pyparams))
1667            (nest           (and nemo-nest? (opt 'nest)))
1668            (matlab         (opt 'matlab))
1669            (octave         (opt 'octave))
1670            (vclamp-hoc     (opt 'vclamp-hoc))
1671            (vclamp-octave  (opt 'vclamp-octave))
1672            (iclamp-hoc     (opt 'iclamp-hoc))
1673            (iclamp-nest    (opt 'iclamp-nest))
1674                 
1675            (nmodl-method
1676             (let ((method  (or ($ (opt 'nmodl-method) ) (defopt 'nmodl-method))))
1677               (case method
1678                 ((adams runge euler adeuler heun adrunge gear
1679                         newton simplex simeq seidel sparse derivimplicit cnexp clsoda
1680                         after_cvode cvode_t cvode_t_v expeuler #f) method)
1681                 (else (error "unknown NMODL method " method)))))
1682                   
1683            (octave-method
1684             (let ((method  ($ (opt 'octave-method) )))
1685               (case method
1686                 ((cvode lsode odepkg ode2r ode5r odesx oders) method)
1687                 ((#f) 'lsode)
1688                 (else (error "unknown Octave method " method)))))
1689                                   
1690            (nest-method
1691             (and nemo-nest?
1692                  (let ((method  ($ (opt 'nest-method) )))
1693                    (case method
1694                      ((cvode gsl leapfrog #f) method)
1695                      (else (error "unknown NEST method " method))))))
1696                                   
1697            (parse-expr  (case in-format
1698                           ((sxml xml)    identity)
1699                           ((sexp)        identity)
1700                           ((ixml)        (lambda (x #!optional loc) 
1701                                            (let ((xs (if (string? x) x
1702                                                          (string-concatenate
1703                                                           (map (lambda (el)
1704                                                                  (if (string? el) el
1705                                                                      (if (equal? el '(divide)) " / "
1706                                                                          (->string el))))
1707                                                                x)))))
1708                                              (nemo:parse-string-expr xs loc))))
1709                           ((nemo)        (if iexpr? 
1710                                              (lambda (x #!optional loc) 
1711                                                (if (string? x) (nemo:parse-string-expr x loc)
1712                                                    (nemo:parse-sym-expr x loc)))
1713                                              nemo:parse-sym-expr))
1714                           (else    (error 'nemo "unknown input format" in-format))))
1715           
1716            )
1717       
1718       (if (and xml-fname surface-xml-fname)
1719           (error 'nemo "both --xml and --surface-xml options are not permitted"))
1720       
1721       (if plain-fname
1722           (with-output-to-file plain-fname 
1723             (lambda () (pretty-print (model->text sys parse-expr)))))
1724       
1725       (if sxml-fname
1726           (with-output-to-file sxml-fname 
1727             (lambda () (pretty-print (model->ncml sys parse-expr)))))
1728       
1729       (if xml-fname
1730           (let* ((doc  (model->ncml sys parse-expr))
1731                  (doc1 (ensure-xmlns
1732                         (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc)))
1733                               (else doc)))))
1734             (with-output-to-file xml-fname 
1735               (lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
1736       
1737       
1738       (if surface-xml-fname   
1739           (with-output-to-file surface-xml-fname 
1740             (lambda () (print-fragments (map entry->surface-xml model-decls)))))
1741       
1742       (if mod-fname
1743           (with-output-to-file
1744               mod-fname  (lambda () 
1745                            (model->nmodl `((method  . ,nmodl-method)
1746                                            (kinetic . ,(opt 'nmodl-kinetic)))
1747                                          sys))))
1748       
1749       (if octave (model->octave `((filename  . ,(or (and (string? octave) (pathname-file octave)) octave))
1750                                   (dirname   . ,(or (and (string? octave) (pathname-directory octave)) dirname))
1751                                   )
1752                                 sys))
1753       
1754       (if matlab (model->matlab `((dirname . ,(or (and (string? matlab) matlab) dirname))) sys))
1755
1756       (if pyparams
1757           (model->pyparams `((filename . ,pyparams-fname)
1758                              (mode . ,(if (opt 'partition) 'single 'multiple)))
1759                            sys))
1760
1761       
1762       (if (and nemo-nest? nest)
1763           (model->nest `((dirname . ,(or (and (string? nest) nest) dirname))
1764                          (method    . ,nest-method))
1765                        sys))
1766       
1767       (if vclamp-hoc (model->vclamp-hoc `((filename . ,vclamp-ses-fname)
1768                                           
1769                                           )
1770                                         sys))
1771       
1772       (if vclamp-octave (model->vclamp-octave `((filename . ,vclamp-octave-fname)
1773                                                 (octave-method . ,(case octave-method
1774                                                                     ((odepkg) 'ode2r)
1775                                                                     (else octave-method)))
1776                                                 )
1777                                               sys))
1778
1779       (if iclamp-hoc (model->iclamp-hoc `((filename . ,iclamp-ses-fname)
1780                                           )
1781                                         sys))
1782
1783       (if iclamp-nest (model->iclamp-nest `((filename . ,iclamp-sli-fname)
1784                                             )
1785                                           sys))
1786       ))
1787  )
1788
1789
1790(define (instantiate-template user-templates template-name template-vars)
1791  (let ((tmpl (assoc (->string template-name) user-templates string=?)))
1792    (if (not tmpl)
1793        (error 'nemo "template not found" template-name))
1794    (let ((ctx (ersatz:init-context models: template-vars )))
1795      (display
1796       (ersatz:eval-statements (caddr tmpl)
1797                               env: (ersatz:template-std-env)
1798                               models: template-vars ctx: ctx))
1799      )))
1800
1801
1802(define (process-template model-name template-name template-args template-out user-templates source-path)
1803
1804  (let (
1805        (template-vars (cons (cons 'model_name
1806                                   (ersatz:Tstr (->string model-name)) )
1807                             (map (lambda (x) 
1808                                    (let ((kv (string-split x "=")))
1809                                      (cons ($ (car kv))
1810                                            (ersatz:Tstr (cadr kv)))))
1811                                  template-args)))
1812        )
1813
1814    (let* ((dirname (pathname-directory source-path))
1815           (output-name (if (string-prefix? "." template-out)
1816                            (make-pathname dirname (s+ model-name template-out)) 
1817                            (make-pathname dirname (s+ model-name "_" template-out)) )))
1818      (with-output-to-file output-name
1819        (lambda () (instantiate-template user-templates template-name template-vars))
1820        ))
1821    ))
1822
1823
1824
1825(define (detect-xml-type doc)
1826  (let* (
1827         (ncml:model    ((lambda (x) 
1828                           (if (null? x) (error 'detect-xml-type "ncml:model element not found in input document") (car x)))
1829                         (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
1830         (membraneprops  (ncml:sxpath '(// cell biophysicalProperties membraneProperties) 
1831                                      `(*TOP* . ,ncml:model)))
1832         )
1833    (cond (membraneprops 'ixml)
1834          (else 'xml))
1835    ))
1836
1837
1838(define (model-source->model source-path in-format model-name model-decls user-templates iexpr parse-expr)
1839
1840  (case in-format
1841    ((sxml xml ixml)
1842     (SingleModel source-path in-format model-name
1843                  (ncml-model-decls->model
1844                   `((hh-markov . ,(opt 'hh-markov))
1845                     (parse-expr . ,parse-expr)) 
1846                   model-name model-decls)
1847                  model-decls user-templates iexpr parse-expr))
1848   
1849    ((sexp nemo)
1850     (SingleModel source-path in-format model-name
1851                  (sexp-model-decls->model 
1852                   `((hh-markov . ,(opt 'hh-markov)))
1853                   model-name model-decls parse-expr)
1854                  model-decls user-templates iexpr parse-expr))
1855   
1856    (else (error 'nemo "invalid input format"))
1857    ))
1858
1859
1860(define (model-source->model-parts opt source-path in-format 
1861                                   model-name model-decls 
1862                                   user-templates iexpr parse-expr)
1863  (let ((pmodels (partition-model opt model-decls)))
1864    (if (opt 'debug)
1865        (begin (print "length pmodels = " (length pmodels))
1866               (print "pmodels = " )
1867               (pp pmodels)))
1868    (let ((model-parts
1869           (match-let (((bkts toplevel) pmodels))
1870                      (map (lambda (bkt)
1871                             (let ((part-decls (append toplevel (cdr bkt)))
1872                                   (part-name (car bkt)))
1873                               
1874                               (case in-format
1875                                 ((sxml xml ixml)
1876                                  (ModelPart source-path in-format model-name part-name
1877                                             (ncml-model-decls->model
1878                                              `((hh-markov . ,(opt 'hh-markov))
1879                                                (parse-expr . ,parse-expr)) 
1880                                              ($ (s+ model-name "_" (car bkt))) part-decls)
1881                                             part-decls model-decls user-templates iexpr parse-expr)
1882                                  )
1883                                 
1884                                 ((sexp nemo)
1885                                  (ModelPart source-path in-format model-name part-name
1886                                             (sexp-model-decls->model
1887                                              `((hh-markov . ,(opt 'hh-markov)))
1888                                              ($ (s+ model-name "_" (car bkt))) part-decls parse-expr)
1889                                             part-decls model-decls user-templates iexpr parse-expr)
1890                                  )
1891                                 
1892                                 (else (error 'nemo "invalid input format" in-format))
1893                                 )))
1894                           bkts))
1895           ))
1896      model-parts
1897      )))
1898
1899
1900 
1901(define (main opt operands)
1902
1903  (if (opt 'version)
1904      (begin
1905        (print (nemo:version-string))
1906        (exit 0)))
1907
1908  (let ((v (opt 'default-units)))
1909    (if v
1910        (nemo:default-units (fold (lambda (x ax) (alist-update (car x) (cdr x) ax))
1911                                  (nemo:default-units) v))
1912        ))
1913
1914  (if (opt 'print-default-units)
1915      (begin
1916        (for-each (lambda (x)
1917                    (printf "~A: ~A~%" (nemo:quantity-name (car x)) (cdr x)))
1918                  (nemo:default-units))))
1919     
1920  (if (null? operands)
1921
1922      (nemo:usage)
1923
1924      (let* (
1925            (model-sources
1926             (map (lambda (operand)
1927                    (let* ((read-xml   (lambda (name) (call-with-input-file name
1928                                                        (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
1929                           (read-sexp  (lambda (name) (call-with-input-file name read)))
1930                           (read-iexpr (lambda (name) (call-with-input-file name 
1931                                                        (lambda (port) 
1932                                                          (let ((content
1933                                                                 (iexpr:tree->list
1934                                                                  (iexpr:parse operand port))))
1935                                                            (car content))))))
1936                           
1937                           (in-format  (cond ((opt 'input-format) =>
1938                                              (lambda (x) 
1939                                                (case ($ x)
1940                                                  ((nemo)        'nemo)
1941                                                  ((s-exp sexp)  'sexp)
1942                                                  ((xml)         'xml)
1943                                                  ((ixml)        'ixml)
1944                                                  ((sxml)        'sxml)
1945                                                  (else          (error 'nemo "unknown input format" x)))))
1946                                             (else  (case ((lambda (x) (or (not x) ($ x)))
1947                                                           (pathname-extension operand))
1948                                                      ((s-exp sexp)  'sexp)
1949                                                      ((sxml)  'sxml)
1950                                                      ((xml)   (detect-xml-type (read-xml operand)))
1951                                                      (else    'nemo)))))
1952
1953                           (doc.iexpr   (case in-format
1954                                         ((nemo) 
1955                                          (let ((content (read-sexp operand)))
1956                                            (if (eq? content 'nemo-model)
1957                                                (cons (read-iexpr operand) #t)
1958                                                (cons content #f))))
1959                                         ((sxml sexp) 
1960                                          (cons (read-sexp operand) #f))
1961                                         ((xml ixml)
1962                                          (cons (read-xml operand) #f))
1963                                         (else    (error 'nemo "unknown input format" in-format))))
1964
1965                           (dd          (if (opt 'debug)
1966                                            (pp (car doc.iexpr))))
1967                           
1968                           (parse-expr  (case in-format
1969                                          ((sxml sexp)         identity)
1970                                          ((nemo)              (if (cdr doc.iexpr) 
1971                                                                   (lambda (x #!optional loc) 
1972                                                                     (if (string? x) (nemo:parse-string-expr x loc)
1973                                                                         (nemo:parse-sym-expr x loc)))
1974                                                                   nemo:parse-sym-expr))
1975                                          ((xml)               (lambda (x #!optional loc) 
1976                                                                 (ncml-expr->expr x)))
1977                                          ((ixml)              (lambda (x #!optional loc) 
1978                                                                 (nemo:parse-string-expr x loc)))
1979                                          (else    (error 'nemo "unknown input format" in-format)))) 
1980                           
1981                           (model-name.model-decls
1982                            (case in-format
1983                              ((sxml xml ixml)     (ncml->model-decls 
1984                                                    `((parse-expr . ,parse-expr)
1985                                                      (debug . ,(opt 'debug) )
1986                                                      (source-path . ,operand)
1987                                                      )
1988                                                    (car doc.iexpr)))
1989                              ((sexp nemo)         (sexp->model-decls (car doc.iexpr)))
1990                              (else    (error 'nemo "unknown input format" in-format))))
1991
1992                           )
1993
1994                       (ModelSource  operand in-format
1995                                     (car model-name.model-decls)
1996                                     (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
1997                                     (match model-name.model-decls 
1998                                            ((_ _ user-templates)
1999                                             user-templates)
2000                                            (else '()))
2001                                     (cdr doc.iexpr) 
2002                                     parse-expr)
2003                      ))
2004                  operands))
2005
2006            (models
2007               (if (opt 'partition)
2008
2009                    (let recur ((srcs model-sources) (ax '()))
2010                      (if (null? srcs) ax
2011                          (let ((src (car srcs)))
2012                            (cases nemo:model src
2013
2014                                   (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
2015                                                (recur (cdr srcs)
2016                                                       (append (model-source->model-parts opt source-path in-format 
2017                                                                                          model-name model-decls 
2018                                                                                          user-templates iexpr parse-expr) ax)))
2019
2020                                   (else (error 'nemo "invalid model source" src)))
2021                            )))
2022                                 
2023                      (map (lambda (x) 
2024                             (cases nemo:model x
2025
2026                                    (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
2027                                                 (model-source->model source-path in-format model-name 
2028                                                                      model-decls user-templates iexpr parse-expr))
2029
2030
2031                                    (else (error 'name "invalid model source" x))))
2032                           
2033                           model-sources))
2034               )
2035            )
2036
2037       
2038        (let ((template-insts (opt 'template)))
2039
2040          (for-each
2041           
2042           (lambda (model)
2043             
2044             (cases nemo:model model
2045                   
2046                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
2047                                 
2048                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
2049                                 
2050                                 (if template-insts
2051                                     (for-each
2052                                      (lambda (template-inst)
2053                                        (match-let (((template-name . template-args)
2054                                                     (string-split template-inst ":")))
2055                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
2056                                                     (process-template model-name template-name template-args 
2057                                                                       output-file-suffix user-templates source-path))
2058                                                   ))
2059                                      template-insts))
2060                                 )
2061
2062                 
2063                    (ModelPart (source-path in-format model-name part-name sys model-decls parent-decls user-templates iexpr? parse-expr)
2064
2065                               (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
2066                               
2067                               (if template-insts
2068                                   (for-each
2069                                    (lambda (template-inst)
2070                                      (match-let (((template-name . template-args)
2071                                                   (string-split template-inst ":")))
2072                                                 (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
2073                                                   (process-template (s+ model-name "_" part-name)
2074                                                                     template-name template-args 
2075                                                                     output-file-suffix user-templates source-path))
2076                                                 ))
2077                                    template-insts))
2078                               )
2079                 
2080                  (else (error 'nemo "invalid model" model))))
2081
2082           models))
2083        )
2084      ))
2085
2086
2087(main opt (opt '@))
2088
Note: See TracBrowser for help on using the repository browser.