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

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

nemo: support for units in XML parser

File size: 75.5 KB
Line 
1;;
2;; NEMO
3;;
4;; Copyright 2008-2013 Ivan Raikov and the Okinawa Institute of
5;; Science and Technology.
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;; General Public License for more details.
16;;
17;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20
21(import files setup-api srfi-1 srfi-4 srfi-13 srfi-69)
22
23
24(require-extension nemo-core nemo-macros nemo-hh nemo-vclamp nemo-iclamp 
25                   nemo-utils nemo-units)
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  (let* ((parse-expr    (or (lookup-def 'parse-expr options) identity))
1265         (ncml:model    ((lambda (x) 
1266                           (if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x)))
1267                         (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
1268         (model-name     ($ (or (sxml:attr ncml:model 'name) (gensym 'model))))
1269         (membraneprops  (ncml:sxpath '(// cell biophysicalProperties membraneProperties) 
1270                                      `(*TOP* . ,ncml:model)))
1271         (ncml-ss        (ncml:sxpath '(// ncml:sxslt) `(*TOP* . ,ncml:model)))
1272         (ncml-templates (ncml:sxpath '(// ncml:template) `(*TOP* . ,ncml:model)))
1273         (ncml-decls     ((lambda (doc) 
1274                            (if (null? ncml-ss) doc
1275                                (let ((ss (map
1276                                           (lambda (x)
1277                                             (call-with-input-string (sxml:text x)
1278                                               (lambda (in) (eval `(begin
1279                                                                     ,@sxslt-preamble
1280                                                                     (sxml:make-ss ,@(read in))
1281                                                                     ))
1282                                                       )))
1283                                           ncml-ss)))
1284                                  (fold (lambda (s doc) (stx:apply-templates doc s doc (list))) doc ss))
1285                                ))
1286                          (if (null? membraneprops) 
1287                              (sxml:kids ncml:model) 
1288                              (sxml:kids membraneprops))))
1289         (dd  (if (lookup-def 'debug options)
1290                  (begin (pp ncml-decls))))
1291         (model-decls    (ncml->declarations ncml-decls parse-expr))
1292         (user-templates (map (lambda (t)
1293                                 (let ((name (or (sxml:attr t 'name) (->string (gensym 'template))))
1294                                       (args (or (let ((xs (sxml:attr t 'args)))
1295                                                   (or (and xs (string-split xs ",")) '())))))
1296                                   (list name args (ersatz:statements-from-string 
1297                                                    (ersatz:template-std-env)
1298                                                    (sxml:text t)))
1299                                   ))
1300                               ncml-templates))
1301         )
1302    (list model-name model-decls user-templates)))
1303
1304
1305(define (ncml-model-decls->model options model-name model-decls)
1306
1307    (if (or (null? model-decls)  (and (pair? model-decls) (every null? model-decls)))
1308        (error 'ncml-model-decls->model "ncml declaration elements not found in input document"))
1309
1310    (let* ((model+nemo  (nemo-constructor model-name model-decls (lambda (x . rest) (identity x))))
1311           (model       (first model+nemo))
1312           (nemo        (second model+nemo)))
1313
1314      (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) (lambda (x . rest) (identity x)))))
1315
1316        (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
1317        (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))     
1318        (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
1319        (if (assoc 'components options)
1320            (for-each (lambda (x) 
1321                        (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
1322                        (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
1323                      ((nemo 'components) model-1)))
1324        model-1)))
1325
1326
1327(define (entry->surface-xml x . rest)
1328  (let-optionals rest ((ns-prefix "ncml"))
1329
1330    (let ((ns-prefix (if (or (not ns-prefix) (string-null? ns-prefix)) ""
1331                         (string-append ns-prefix ":")))
1332          (xmlstr (lambda (x) (let recur ((x x)) 
1333                                (if (pair? x) (map recur x) 
1334                                    (let ((v (string->goodHTML (->string x))))
1335                                      (if (pair? v) (string-concatenate v) v)))
1336                                ))
1337                  ))
1338
1339      (let ((transition-str
1340             (lambda (t)
1341               (match t
1342                      (('-> src dst rate) 
1343                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1344                                ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix))
1345
1346                      ((src '-> dst rate) 
1347                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1348                                ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix))
1349
1350                      (('<-> src dst rate1 rate2) 
1351                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1352                                ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix
1353                                ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix
1354                                ))
1355
1356                      ((src '<-> dst rate1 rate2) 
1357                       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
1358                                ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix
1359                                ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix
1360                                ))
1361
1362                      (else (error 'transition-str "invalid transition " x))))
1363               )
1364               
1365            (ionic-gate-str
1366             (lambda (ion #!key 
1367                          (initial-m-expr #f)
1368                          (initial-h-expr #f)
1369                          (m-power #f)
1370                          (h-power #f)
1371                          (m-inf-expr #f)
1372                          (m-tau-expr #f)
1373                          (h-inf-expr #f)
1374                          (h-tau-expr #f)
1375                          (m-alpha-expr #f)
1376                          (m-beta-expr #f)
1377                          (h-alpha-expr #f)
1378                          (h-beta-expr #f))
1379
1380               (let ((initial-m-str (or (and initial-m-expr
1381                                                  (sprintf "<~Ainitial_m>~A</~Ainitial_m>~%" 
1382                                                           ns-prefix (xmlstr initial-m-expr) ns-prefix)) ""))
1383                     (initial-h-str (or (and initial-h-expr
1384                                                  (sprintf "<~Ainitial_h>~A</~Ainitial_h>~%" 
1385                                                           ns-prefix (xmlstr initial-h-expr) ns-prefix)) ""))
1386
1387                     (m-power-str  (or (and m-power
1388                                                  (sprintf "<~Am_power>~A</~Am_power>~%" 
1389                                                           ns-prefix m-power ns-prefix)) ""))
1390                     (h-power-str  (or (and h-power
1391                                                  (sprintf "<~Ah_power>~A</~Ah_power>~%" 
1392                                                           ns-prefix h-power ns-prefix)) ""))
1393
1394                     (m-inf-str (or (and m-inf-expr
1395                                         (sprintf "<~Am_inf>~A</~Am_inf>~%" 
1396                                                  ns-prefix (xmlstr m-inf-expr) ns-prefix)) ""))
1397                     (m-tau-str (or (and m-tau-expr
1398                                         (sprintf "<~Am_tau>~A</~Am_tau>~%" 
1399                                                  ns-prefix (xmlstr m-tau-expr) ns-prefix)) ""))
1400
1401                     (h-inf-str (or (and h-inf-expr
1402                                         (sprintf "<~Ah_inf>~A</~Ah_inf>~%" 
1403                                                  ns-prefix (xmlstr h-inf-expr) ns-prefix)) ""))
1404                     (h-tau-str (or (and h-tau-expr
1405                                         (sprintf "<~Ah_tau>~A</~Ah_tau>~%" 
1406                                                  ns-prefix (xmlstr h-tau-expr) ns-prefix)) ""))
1407
1408                     (m-alpha-str (or (and m-alpha-expr
1409                                           (sprintf "<~Am_alpha>~A</~Am_alpha>~%" 
1410                                                    ns-prefix (xmlstr m-alpha-expr) ns-prefix)) ""))
1411                     (m-beta-str (or (and m-beta-expr
1412                                          (sprintf "<~Am_beta>~A</~Am_beta>~%" 
1413                                                   ns-prefix (xmlstr m-beta-expr) ns-prefix)) ""))
1414
1415                     (h-alpha-str (or (and h-alpha-expr
1416                                           (sprintf "<~Ah_alpha>~A</~Ah_alpha>~%" 
1417                                                    ns-prefix (xmlstr h-alpha-expr) ns-prefix)) ""))
1418                     (h-beta-str (or (and h-beta-expr
1419                                          (sprintf "<~Ah_beta>~A</~Ah_beta>~%" 
1420                                                   ns-prefix (xmlstr h-beta-expr) ns-prefix)) ""))
1421                     )
1422                 
1423                 (sprintf "<~Ahh_ionic_gate name=\"~A\">~A</~Ahh_ionic_gate>~%"
1424                          ns-prefix ion   
1425                          (string-append initial-m-str initial-h-str
1426                                         m-power-str h-power-str m-inf-str 
1427                                         m-tau-str h-inf-str h-tau-str
1428                                         m-alpha-str m-beta-str h-alpha-str h-beta-str
1429                                         )
1430                          ns-prefix))
1431               )))
1432
1433    (match x
1434         (('nemo-model name decls)
1435          (map entry->surface-xml decls))
1436
1437         (('output . names)
1438          (string-concatenate (map (lambda (name) (sprintf "<~Aoutput name=\"~A\"/>~%" ns-prefix name)) names)))
1439
1440         (('input . names)
1441          (string-concatenate (map (lambda (name) 
1442                                     (match name
1443                                            ((and name (? symbol?)) 
1444                                             (sprintf "<~Ainput name=\"~A\"/>~%" ns-prefix name))
1445
1446                                            ((name 'from ns)
1447                                             (sprintf "<~Ainput name=\"~A\" from=\"~A\"/>~%" ns-prefix name ns))
1448                                           
1449                                            ))
1450                                   names)))
1451
1452         (('const name '= value)
1453          (if (number? value)
1454              (sprintf "<~Aconst name=\"~A\" value=\"~A\"/>~%"
1455                      ns-prefix name value)
1456              (sprintf "<~Aconst name=\"~A\">~%~A~%</~Aconst>~%"
1457                       ns-prefix name (xmlstr value) ns-prefix)
1458              ))
1459
1460         (((or 'defun 'fun) name args body)
1461          (sprintf "<~Adefun name=\"~A\">~%~A~%<~Abody>~A</~Abody>~%</~Adefun>~%"
1462                   ns-prefix
1463                   name (string-concatenate (map (lambda (x) (sprintf "<~Aarg>~A</~Aarg>" ns-prefix x ns-prefix)) args)) 
1464                   ns-prefix (xmlstr body) ns-prefix ns-prefix))
1465         
1466         ((name '= expr)
1467          (sprintf "<~Aasgn name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Aasgn>~%"
1468                  ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix))
1469         
1470         (('d ( name ) '= expr)
1471          (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Arate>~%"
1472                  ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix))
1473         
1474         (('d ( name ) '= expr ('initial initial-expr))
1475          (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Ainitial>~A</~Ainitial>~%</~Arate>~%"
1476                   ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix))
1477
1478         (((or 't 'T 'transient) ( name ) '= expr ('onevent event-expr) ('initial initial-expr))
1479          (sprintf "<~Atransient name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Aonevent>~A</~Aonevent>~%<~Ainitial>~A</~Ainitial>~%</~Atransient>~%"
1480                   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))
1481
1482         (('reaction ( name ('transitions . transitions) ('conserve conserve) ('initial . initial-expr) ('open . open) ('power power)))
1483          (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%<~Ainitial>~A</~Ainitial>~%</~Areaction>~%"
1484                   ns-prefix name 
1485                   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
1486                   ns-prefix (xmlstr power) ns-prefix
1487                   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
1488                   ns-prefix (xmlstr initial-expr) ns-prefix
1489                   ns-prefix))
1490
1491         (('reaction ( name ('transitions . transitions) ('conserve conserve) ('open . open) ('power power)))
1492          (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%"
1493                   ns-prefix name 
1494                   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
1495                   ns-prefix (xmlstr power) ns-prefix
1496                   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
1497                   ns-prefix))
1498
1499         (('reaction ( name ('transitions . transitions) ('open . open) ('power power)))
1500          (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%"
1501                   ns-prefix name 
1502                   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
1503                   ns-prefix (xmlstr power) ns-prefix
1504                   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
1505                   ns-prefix))
1506
1507         
1508         (('hh-ionic-gate 
1509           (ion
1510            ('initial-m  initial-m-expr)
1511            ('initial-h  initial-h-expr)
1512            ('m-power    m-power)
1513            ('h-power    h-power)
1514            ('m-inf      m-inf-expr)
1515            ('m-tau      m-tau-expr)
1516            ('h-inf      h-inf-expr)
1517            ('h-tau      h-tau-expr)
1518            ))
1519
1520          (ionic-gate-str ion 
1521                          initial-m-expr: initial-m-expr
1522                          initial-h-expr: initial-h-expr
1523                          m-power: m-power
1524                          h-power: h-power
1525                          m-inf-expr: m-inf-expr
1526                          m-tau-expr: m-tau-expr
1527                          h-inf-expr: h-inf-expr
1528                          h-tau-expr: h-tau-expr))
1529
1530         
1531         (('hh-ionic-gate 
1532           (ion
1533            ('initial-m  initial-m-expr)
1534            ('m-power    m-power)
1535            ('h-power    h-power)
1536            ('m-inf      m-inf-expr)
1537            ('m-tau      m-tau-expr)
1538            ))
1539
1540          (ionic-gate-str ion 
1541                          initial-m-expr: initial-m-expr
1542                          m-power: m-power
1543                          h-power: h-power
1544                          m-inf-expr: m-inf-expr
1545                          m-tau-expr: m-tau-expr))
1546         
1547         (('hh-ionic-gate 
1548           (ion
1549            ('initial-m  initial-m-expr)
1550            ('m-power    m-power)
1551            ('h-power    h-power)
1552            ('m-tau      m-tau-expr)
1553            ('m-inf      m-inf-expr)
1554            ))
1555
1556          (ionic-gate-str ion 
1557                          initial-m-expr: initial-m-expr
1558                          m-power: m-power
1559                          h-power: h-power
1560                          m-inf-expr: m-inf-expr
1561                          m-tau-expr: m-tau-expr))
1562         
1563         (('hh-ionic-gate 
1564           (ion
1565            ('initial-m  initial-m-expr)
1566            ('initial-h  initial-h-expr)
1567            ('m-power    m-power)
1568            ('h-power    h-power)
1569            ('m-alpha      m-alpha-expr)
1570            ('m-beta       m-beta-expr)
1571            ('h-alpha      h-alpha-expr)
1572            ('h-beta       h-beta-expr)
1573            ))
1574
1575          (ionic-gate-str ion 
1576                          initial-m-expr: initial-m-expr
1577                          initial-h-expr: initial-h-expr
1578                          m-power: m-power
1579                          h-power: h-power
1580                          m-alpha-expr: m-alpha-expr
1581                          m-beta-expr: m-beta-expr
1582                          h-alpha-expr: h-alpha-expr
1583                          h-beta-expr: h-beta-expr))
1584         
1585         (('hh-ionic-gate 
1586           (ion
1587            ('initial-m  initial-m-expr)
1588            ('m-power    m-power)
1589            ('h-power    h-power)
1590            ('m-alpha      m-alpha-expr)
1591            ('m-beta       m-beta-expr)
1592            ))
1593
1594          (ionic-gate-str ion 
1595                          initial-m-expr: initial-m-expr
1596                          m-power: m-power
1597                          h-power: h-power
1598                          m-alpha-expr: m-alpha-expr
1599                          m-beta-expr: m-beta-expr))
1600
1601         
1602         (('component ('type ty) ('name name) . rest) 
1603          (sprintf "<~Acomponent type=\"~A\" name=\"~A\">~%~A</~Acomponent>~%" 
1604                  ns-prefix ty name (string-concatenate (map entry->surface-xml rest)) ns-prefix ))
1605
1606         (('component ('type ty) . rest) 
1607          (sprintf "<~Acomponent type=\"~A\">~%~A</~Acomponent>~%" 
1608                   ns-prefix ty (string-concatenate (map entry->surface-xml rest)) ns-prefix ))
1609
1610
1611         (else (error 'nemo "unknown declaration" x))
1612
1613         )))
1614))
1615
1616
1617(define (partition-model opt decls)
1618  (let recur ((bkts '()) (toplevel '()) (decls decls))
1619    (if (null? decls)
1620        (list bkts (reverse toplevel))
1621        (let ((decl (car decls)))
1622          (if (opt 'debug)
1623              (begin (print "partition-model: decl = ")
1624                     (pp decl)))
1625          (match decl (((or 'component 'COMPONENT)
1626                        ((or 'type 'TYPE) typ) 
1627                        ((or 'name 'NAME) name) . lst)
1628                       (let ((bkt (alist-ref name bkts)))
1629                         (if bkt (recur (alist-update name (cons decl bkt) bkts)
1630                                        toplevel (cdr decls))
1631                             (recur (alist-update name (list decl) bkts)
1632                                    toplevel (cdr decls)))))
1633                 (else (recur bkts (cons decl toplevel) (cdr decls)))))
1634        )))
1635
1636
1637(define (process-model opt source-path in-format prefix sys model-decls iexpr? parse-expr)
1638               
1639  (match-let ((($ nemo:quantity 'DISPATCH  dis) 
1640               (hash-table-ref sys (nemo-intern 'dispatch))))
1641                                   
1642     (let* (
1643            (sysname             ((lambda (x) (or (and prefix ($ (s+ prefix "_" x))) x)) ((dis 'sysname) sys)))
1644            (dirname             (pathname-directory source-path))
1645            (plain-fname         (make-output-fname dirname sysname ".txt"  (opt 'plain) ))
1646            (sxml-fname          (make-output-fname dirname sysname  ".sxml" (opt 'sxml) ))
1647            (surface-xml-fname   (make-output-fname dirname sysname ".xml"  (opt 'surface-xml) ))
1648            (xml-fname           (make-output-fname dirname sysname ".xml"  (opt 'xml) ))
1649            (pyparams-fname      (make-output-fname dirname sysname ".py"  (opt 'pyparams) ))
1650            (mod-fname           (make-output-fname dirname sysname ".mod"  (opt 'nmodl)))
1651            (vclamp-ses-fname    (make-output-fname dirname sysname "_vclamp.hoc" (opt 'vclamp-hoc) ))
1652            (vclamp-octave-fname (make-output-fname dirname sysname "_vclamp.m" (opt 'vclamp-octave) ))
1653            (iclamp-ses-fname    (make-output-fname dirname sysname "_iclamp.hoc" (opt 'iclamp-hoc) ))
1654            (iclamp-sli-fname    (make-output-fname dirname sysname "_iclamp.sli" (opt 'iclamp-nest) ))
1655                 
1656            (pyparams       (opt 'pyparams))
1657            (nest           (and nemo-nest? (opt 'nest)))
1658            (matlab         (opt 'matlab))
1659            (octave         (opt 'octave))
1660            (vclamp-hoc     (opt 'vclamp-hoc))
1661            (vclamp-octave  (opt 'vclamp-octave))
1662            (iclamp-hoc     (opt 'iclamp-hoc))
1663            (iclamp-nest    (opt 'iclamp-nest))
1664                 
1665            (nmodl-method
1666             (let ((method  (or ($ (opt 'nmodl-method) ) (defopt 'nmodl-method))))
1667               (case method
1668                 ((adams runge euler adeuler heun adrunge gear
1669                         newton simplex simeq seidel sparse derivimplicit cnexp clsoda
1670                         after_cvode cvode_t cvode_t_v expeuler #f) method)
1671                 (else (error "unknown NMODL method " method)))))
1672                   
1673            (octave-method
1674             (let ((method  ($ (opt 'octave-method) )))
1675               (case method
1676                 ((cvode lsode odepkg ode2r ode5r odesx oders) method)
1677                 ((#f) 'lsode)
1678                 (else (error "unknown Octave method " method)))))
1679                                   
1680            (nest-method
1681             (and nemo-nest?
1682                  (let ((method  ($ (opt 'nest-method) )))
1683                    (case method
1684                      ((cvode gsl leapfrog #f) method)
1685                      (else (error "unknown NEST method " method))))))
1686                                   
1687            (parse-expr  (case in-format
1688                           ((sxml xml)    identity)
1689                           ((sexp)        identity)
1690                           ((ixml)        (lambda (x #!optional loc) 
1691                                            (let ((xs (if (string? x) x
1692                                                          (string-concatenate
1693                                                           (map (lambda (el)
1694                                                                  (if (string? el) el
1695                                                                      (if (equal? el '(divide)) " / "
1696                                                                          (->string el))))
1697                                                                x)))))
1698                                              (nemo:parse-string-expr xs loc))))
1699                           ((nemo)        (if iexpr? 
1700                                              (lambda (x #!optional loc) 
1701                                                (if (string? x) (nemo:parse-string-expr x loc)
1702                                                    (nemo:parse-sym-expr x loc)))
1703                                              nemo:parse-sym-expr))
1704                           (else    (error 'nemo "unknown input format" in-format))))
1705           
1706            )
1707       
1708       (if (and xml-fname surface-xml-fname)
1709           (error 'nemo "both --xml and --surface-xml options are not permitted"))
1710       
1711       (if plain-fname
1712           (with-output-to-file plain-fname 
1713             (lambda () (pretty-print (model->text sys parse-expr)))))
1714       
1715       (if sxml-fname
1716           (with-output-to-file sxml-fname 
1717             (lambda () (pretty-print (model->ncml sys parse-expr)))))
1718       
1719       (if xml-fname
1720           (let* ((doc  (model->ncml sys parse-expr))
1721                  (doc1 (ensure-xmlns
1722                         (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc)))
1723                               (else doc)))))
1724             (with-output-to-file xml-fname 
1725               (lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
1726       
1727       
1728       (if surface-xml-fname   
1729           (with-output-to-file surface-xml-fname 
1730             (lambda () (print-fragments (map entry->surface-xml model-decls)))))
1731       
1732       (if mod-fname
1733           (with-output-to-file
1734               mod-fname  (lambda () 
1735                            (model->nmodl `((method  . ,nmodl-method)
1736                                            (kinetic . ,(opt 'nmodl-kinetic)))
1737                                          sys))))
1738       
1739       (if octave (model->octave `((filename  . ,(or (and (string? octave) (pathname-file octave)) octave))
1740                                   (dirname   . ,(or (and (string? octave) (pathname-directory octave)) dirname))
1741                                   )
1742                                 sys))
1743       
1744       (if matlab (model->matlab `((dirname . ,(or (and (string? matlab) matlab) dirname))) sys))
1745
1746       (if pyparams
1747           (model->pyparams `((filename . ,pyparams-fname)
1748                              (mode . ,(if (opt 'partition) 'single 'multiple)))
1749                            sys))
1750
1751       
1752       (if (and nemo-nest? nest)
1753           (model->nest `((dirname . ,(or (and (string? nest) nest) dirname))
1754                          (method    . ,nest-method))
1755                        sys))
1756       
1757       (if vclamp-hoc (model->vclamp-hoc `((filename . ,vclamp-ses-fname)
1758                                           
1759                                           )
1760                                         sys))
1761       
1762       (if vclamp-octave (model->vclamp-octave `((filename . ,vclamp-octave-fname)
1763                                                 (octave-method . ,(case octave-method
1764                                                                     ((odepkg) 'ode2r)
1765                                                                     (else octave-method)))
1766                                                 )
1767                                               sys))
1768
1769       (if iclamp-hoc (model->iclamp-hoc `((filename . ,iclamp-ses-fname)
1770                                           )
1771                                         sys))
1772
1773       (if iclamp-nest (model->iclamp-nest `((filename . ,iclamp-sli-fname)
1774                                             )
1775                                           sys))
1776       ))
1777  )
1778
1779
1780(define (instantiate-template user-templates template-name template-vars)
1781  (let ((tmpl (assoc (->string template-name) user-templates string=?)))
1782    (if (not tmpl)
1783        (error 'nemo "template not found" template-name))
1784    (let ((ctx (ersatz:init-context models: template-vars )))
1785      (display
1786       (ersatz:eval-statements (caddr tmpl)
1787                               env: (ersatz:template-std-env)
1788                               models: template-vars ctx: ctx))
1789      )))
1790
1791
1792(define (process-template model-name template-name template-args template-out user-templates source-path)
1793
1794  (let (
1795        (template-vars (cons (cons 'model_name
1796                                   (ersatz:Tstr (->string model-name)) )
1797                             (map (lambda (x) 
1798                                    (let ((kv (string-split x "=")))
1799                                      (cons ($ (car kv))
1800                                            (ersatz:Tstr (cadr kv)))))
1801                                  template-args)))
1802        )
1803
1804    (let* ((dirname (pathname-directory source-path))
1805           (output-name (if (string-prefix? "." template-out)
1806                            (make-pathname dirname (s+ model-name template-out)) 
1807                            (make-pathname dirname (s+ model-name "_" template-out)) )))
1808      (with-output-to-file output-name
1809        (lambda () (instantiate-template user-templates template-name template-vars))
1810        ))
1811    ))
1812
1813
1814
1815(define (detect-xml-type doc)
1816  (let* (
1817         (ncml:model    ((lambda (x) 
1818                           (if (null? x) (error 'detect-xml-type "ncml:model element not found in input document") (car x)))
1819                         (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
1820         (membraneprops  (ncml:sxpath '(// cell biophysicalProperties membraneProperties) 
1821                                      `(*TOP* . ,ncml:model)))
1822         )
1823    (cond (membraneprops 'ixml)
1824          (else 'xml))
1825    ))
1826
1827
1828(define (model-source->model source-path in-format model-name model-decls user-templates iexpr parse-expr)
1829
1830  (case in-format
1831    ((sxml xml ixml)
1832     (SingleModel source-path in-format model-name
1833                  (ncml-model-decls->model
1834                   `((hh-markov . ,(opt 'hh-markov))
1835                     (parse-expr . ,parse-expr)) 
1836                   model-name model-decls)
1837                  model-decls user-templates iexpr parse-expr))
1838   
1839    ((sexp nemo)
1840     (SingleModel source-path in-format model-name
1841                  (sexp-model-decls->model 
1842                   `((hh-markov . ,(opt 'hh-markov)))
1843                   model-name model-decls parse-expr)
1844                  model-decls user-templates iexpr parse-expr))
1845   
1846    (else (error 'nemo "invalid input format"))
1847    ))
1848
1849
1850(define (model-source->model-parts opt source-path in-format 
1851                                   model-name model-decls 
1852                                   user-templates iexpr parse-expr)
1853  (let ((pmodels (partition-model opt model-decls)))
1854    (if (opt 'debug)
1855        (begin (print "length pmodels = " (length pmodels))
1856               (print "pmodels = " )
1857               (pp pmodels)))
1858    (let ((model-parts
1859           (match-let (((bkts toplevel) pmodels))
1860                      (map (lambda (bkt)
1861                             (let ((part-decls (append toplevel (cdr bkt)))
1862                                   (part-name (car bkt)))
1863                               
1864                               (case in-format
1865                                 ((sxml xml ixml)
1866                                  (ModelPart source-path in-format model-name part-name
1867                                             (ncml-model-decls->model
1868                                              `((hh-markov . ,(opt 'hh-markov))
1869                                                (parse-expr . ,parse-expr)) 
1870                                              ($ (s+ model-name "_" (car bkt))) part-decls)
1871                                             part-decls model-decls user-templates iexpr parse-expr)
1872                                  )
1873                                 
1874                                 ((sexp nemo)
1875                                  (ModelPart source-path in-format model-name part-name
1876                                             (sexp-model-decls->model
1877                                              `((hh-markov . ,(opt 'hh-markov)))
1878                                              ($ (s+ model-name "_" (car bkt))) part-decls parse-expr)
1879                                             part-decls model-decls user-templates iexpr parse-expr)
1880                                  )
1881                                 
1882                                 (else (error 'nemo "invalid input format" in-format))
1883                                 )))
1884                           bkts))
1885           ))
1886      model-parts
1887      )))
1888
1889
1890 
1891(define (main opt operands)
1892
1893  (if (opt 'version)
1894      (begin
1895        (print (nemo:version-string))
1896        (exit 0)))
1897
1898  (let ((v (opt 'default-units)))
1899    (if v
1900        (nemo:default-units (fold (lambda (x ax) (alist-update (car x) (cdr x) ax))
1901                                  (nemo:default-units) v))
1902        ))
1903
1904  (if (opt 'print-default-units)
1905      (begin
1906        (for-each (lambda (x)
1907                    (printf "~A: ~A~%" (nemo:quantity-name (car x)) (cdr x)))
1908                  (nemo:default-units))))
1909     
1910  (if (null? operands)
1911
1912      (nemo:usage)
1913
1914      (let* (
1915            (model-sources
1916             (map (lambda (operand)
1917                    (let* ((read-xml   (lambda (name) (call-with-input-file name
1918                                                        (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
1919                           (read-sexp  (lambda (name) (call-with-input-file name read)))
1920                           (read-iexpr (lambda (name) (call-with-input-file name 
1921                                                        (lambda (port) 
1922                                                          (let ((content
1923                                                                 (iexpr:tree->list
1924                                                                  (iexpr:parse operand port))))
1925                                                            (car content))))))
1926                           
1927                           (in-format  (cond ((opt 'input-format) =>
1928                                              (lambda (x) 
1929                                                (case ($ x)
1930                                                  ((nemo)        'nemo)
1931                                                  ((s-exp sexp)  'sexp)
1932                                                  ((xml)         'xml)
1933                                                  ((ixml)        'ixml)
1934                                                  ((sxml)        'sxml)
1935                                                  (else          (error 'nemo "unknown input format" x)))))
1936                                             (else  (case ((lambda (x) (or (not x) ($ x)))
1937                                                           (pathname-extension operand))
1938                                                      ((s-exp sexp)  'sexp)
1939                                                      ((sxml)  'sxml)
1940                                                      ((xml)   (detect-xml-type (read-xml operand)))
1941                                                      (else    'nemo)))))
1942
1943                           (doc.iexpr   (case in-format
1944                                         ((nemo) 
1945                                          (let ((content (read-sexp operand)))
1946                                            (if (eq? content 'nemo-model)
1947                                                (cons (read-iexpr operand) #t)
1948                                                (cons content #f))))
1949                                         ((sxml sexp) 
1950                                          (cons (read-sexp operand) #f))
1951                                         ((xml ixml)
1952                                          (cons (read-xml operand) #f))
1953                                         (else    (error 'nemo "unknown input format" in-format))))
1954
1955                           (dd          (if (opt 'debug)
1956                                            (pp (car doc.iexpr))))
1957                           
1958                           (parse-expr  (case in-format
1959                                          ((sxml sexp)         identity)
1960                                          ((nemo)              (if (cdr doc.iexpr) 
1961                                                                   (lambda (x #!optional loc) 
1962                                                                     (if (string? x) (nemo:parse-string-expr x loc)
1963                                                                         (nemo:parse-sym-expr x loc)))
1964                                                                   nemo:parse-sym-expr))
1965                                          ((xml)               (lambda (x #!optional loc) 
1966                                                                 (ncml-expr->expr x)))
1967                                          ((ixml)              (lambda (x #!optional loc) 
1968                                                                 (nemo:parse-string-expr x loc)))
1969                                          (else    (error 'nemo "unknown input format" in-format)))) 
1970                           
1971                           (model-name.model-decls
1972                            (case in-format
1973                              ((sxml xml ixml)     (ncml->model-decls 
1974                                                    `((parse-expr . ,parse-expr)
1975                                                      (debug . ,(opt 'debug) ))
1976                                                    (car doc.iexpr)))
1977                              ((sexp nemo)         (sexp->model-decls (car doc.iexpr)))
1978                              (else    (error 'nemo "unknown input format" in-format))))
1979
1980                           )
1981
1982                       (ModelSource  operand in-format
1983                                     (car model-name.model-decls)
1984                                     (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
1985                                     (match model-name.model-decls 
1986                                            ((_ _ user-templates)
1987                                             user-templates)
1988                                            (else '()))
1989                                     (cdr doc.iexpr) 
1990                                     parse-expr)
1991                      ))
1992                  operands))
1993
1994            (models
1995               (if (opt 'partition)
1996
1997                    (let recur ((srcs model-sources) (ax '()))
1998                      (if (null? srcs) ax
1999                          (let ((src (car srcs)))
2000                            (cases nemo:model src
2001
2002                                   (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
2003                                                (recur (cdr srcs)
2004                                                       (append (model-source->model-parts opt source-path in-format 
2005                                                                                          model-name model-decls 
2006                                                                                          user-templates iexpr parse-expr) ax)))
2007
2008                                   (else (error 'nemo "invalid model source" src)))
2009                            )))
2010                                 
2011                      (map (lambda (x) 
2012                             (cases nemo:model x
2013
2014                                    (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
2015                                                 (model-source->model source-path in-format model-name 
2016                                                                      model-decls user-templates iexpr parse-expr))
2017
2018
2019                                    (else (error 'name "invalid model source" x))))
2020                           
2021                           model-sources))
2022               )
2023            )
2024
2025       
2026        (let ((template-insts (opt 'template)))
2027
2028          (for-each
2029           
2030           (lambda (model)
2031             
2032             (cases nemo:model model
2033                   
2034                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
2035                                 
2036                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
2037                                 
2038                                 (if template-insts
2039                                     (for-each
2040                                      (lambda (template-inst)
2041                                        (match-let (((template-name . template-args)
2042                                                     (string-split template-inst ":")))
2043                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
2044                                                     (process-template model-name template-name template-args 
2045                                                                       output-file-suffix user-templates source-path))
2046                                                   ))
2047                                      template-insts))
2048                                 )
2049
2050                 
2051                    (ModelPart (source-path in-format model-name part-name sys model-decls parent-decls user-templates iexpr? parse-expr)
2052
2053                               (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
2054                               
2055                               (if template-insts
2056                                   (for-each
2057                                    (lambda (template-inst)
2058                                      (match-let (((template-name . template-args)
2059                                                   (string-split template-inst ":")))
2060                                                 (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
2061                                                   (process-template (s+ model-name "_" part-name)
2062                                                                     template-name template-args 
2063                                                                     output-file-suffix user-templates source-path))
2064                                                 ))
2065                                    template-insts))
2066                               )
2067                 
2068                  (else (error 'nemo "invalid model" model))))
2069
2070           models))
2071        )
2072      ))
2073
2074
2075(main opt (opt '@))
2076
Note: See TracBrowser for help on using the repository browser.