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

Last change on this file since 14732 was 14732, checked in by Ivan Raikov, 11 years ago

nemo ported to Chicken 4

File size: 31.0 KB
Line 
1;;
2;; NEMO
3;;
4;; Copyright 2008-2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU General Public License as
8;; published by the Free Software Foundation, either version 3 of the
9;; License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15;;
16;; A full copy of the GPL license can be found at
17;; <http://www.gnu.org/licenses/>.
18;;
19
20(import scheme chicken srfi-1)
21
22(require-extension matchable args ssax sxml-transforms sxpath sxpath-lolevel environments)
23(require-extension nemo-core nemo-macros nemo-hh)
24
25(define nemo-nmodl?   (extension-information 'nemo-nmodl)) 
26(define nemo-matlab?  (extension-information 'nemo-matlab)) 
27
28(if nemo-nmodl? (use nemo-nmodl))
29(if nemo-matlab? (use nemo-matlab))
30
31(define (lookup-def k lst . rest)
32  (let-optionals rest ((default #f))
33      (let ((kv (assoc k lst)))
34        (if (not kv) default
35            (match kv ((k v) v) (else (cdr kv)))))))
36
37(define ($ x)  (and x (string->symbol (->string x))))
38
39;;; Procedures for string concatenation and pretty-printing
40
41(define (s+ . lst)    (string-concatenate (map ->string lst)))
42(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
43(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
44(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
45(define nl "\n")
46
47
48(define (warn port message . specialising-msgs)
49  (print-error-message message (current-output-port) "Warning")
50  (print (string-concatenate (map ->string specialising-msgs))))
51
52;;; Error procedure for the XML parser
53
54(define (parser-error port message . specialising-msgs)
55  (error (string-append message (string-concatenate (map ->string specialising-msgs)))))
56
57(define ssax:warn warn)
58
59(define opts
60  `(
61    ,(args:make-option (i)       (required: "FORMAT")   
62                       (s+ "specify input format (nemo, xml, sxml, s-exp)")
63                       (string->symbol arg))
64    ,(args:make-option (xml)       (optional: "FILE")   
65                       (s+ "write XML output to file (default: <model-name>.xml)"))
66    ,(args:make-option (sxml)       (optional: "FILE")   
67                       (s+ "write SXML output to file (default: <model-name>.sxml)"))
68    ,@(if nemo-matlab? 
69          (list (args:make-option (matlab)      (optional: "FILE")   
70                                  (s+ "write MATLAB output to file (default: <model-name>.m)"))
71                (args:make-option (matlab-method)       (required: "METHOD")
72                                  (s+ "specify MATLAB/Octave integration method")
73                                  (string->symbol arg))
74                )
75          `())
76    ,@(if nemo-nmodl?
77          (list
78           (args:make-option (nmodl)      (optional: "FILE")   
79                             (s+ "write NMODL output to file (default: <model-name>.mod)"))
80           (args:make-option (nmodl-kinetic)       (optional: "STATES")
81                             (s+ "use NMODL kinetic equations for the given reactions "
82                                 "(or for all reactions)"))
83           (args:make-option (nmodl-method)       (required: "METHOD")
84                             (s+ "specify NMODL integration method")
85                             (string->symbol arg))
86           (args:make-option (nmodl-depend)       (required: "VARS")
87                             (s+ "specify DEPEND variables for NMODL interpolation tables")
88                             (map string->symbol (string-split arg ",")))
89           )
90          `())
91    ,(args:make-option (t)       #:none
92                       (s+ "use interpolation tables in generated code, if possible")
93                       #t)
94    ,(args:make-option (h help)  #:none               "Print help"
95                       (usage))
96
97    ))
98
99
100;; Use args:usage to generate a formatted list of options (from OPTS),
101;; suitable for embedding into help text.
102(define (usage)
103  (print "Usage: " (car (argv)) " [options...] <list of files to be processed> ")
104  (newline)
105  (print "The following options are recognized: ")
106  (newline)
107  (print (parameterize ((args:indent 5) (args:width 30)) (args:usage opts)))
108  (exit 1))
109
110
111;; Process arguments and collate options and arguments into OPTIONS
112;; alist, and operands (filenames) into OPERANDS. 
113(define args    (command-line-arguments))
114(set!-values (options operands)  (args:parse args opts))
115
116
117(define (ncml:sxpath query doc)
118  ((sxpath query '((ncml . "ncml"))) doc))
119
120(define (ncml:car-sxpath query doc)
121  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
122    (car lst)))
123
124(define (ncml:if-car-sxpath query doc)
125  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
126    (and (not (null? lst)) (car lst))))
127
128(define (ncml:if-sxpath query doc)
129  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
130    (and (not (null? lst)) lst)))
131
132(define (ncml-binding->binding node)
133  (match node
134    (('ncml:bnd ('@ ('id id)) ('ncml:expr expr))
135     `(,($ id) ,(ncml-expr->expr expr)))
136    (else (error 'ncml-binding->binding "invalid binding " node))))
137 
138(define (ncml-expr->expr node)
139  (match node
140         ((? number?)    node)
141         ((? string?)    (sxml:number node))
142         (('ncml:id id)  ($ id))
143         (('ncml:apply ('@ ('id id)) . args)  (cons ($ id) (map ncml-expr->expr args)))
144         (('ncml:let ('ncml:bnds . bnds) ('ncml:expr body))
145          `(let ,(map ncml-binding->binding bnds) ,(ncml-expr->expr body)))
146         (((and op (? symbol?)) . args)       
147          (cons (ncml-op->op op) (map ncml-expr->expr args)))
148         (else (error 'ncml-expr->expr "unknown expression " node))))
149 
150
151(define (ncml-op->op op)
152  (case op
153    ((ncml:sum)    '+)
154    ((ncml:sub)    '-)
155    ((ncml:mul)    '*)
156    ((ncml:div)    '/)
157    ((ncml:gt)     '>)
158    ((ncml:lt)     '<)
159    ((ncml:lte)    '<=)
160    ((ncml:gte)    '>=)
161    ((ncml:eq)     '=)
162    (else          (match (string-split (->string op) ":")
163                          ((pre op)  (string->symbol op))
164                          (else (error 'ncml-op->op "invalid operator" op))))))
165
166
167(define (nemo-constructor name declarations parse-expr)
168  (let* ((nemo   (make-nemo-core))
169         (sys    ((nemo 'system) name)))
170    (eval-nemo-system-decls nemo name sys declarations parse-expr)
171    (list sys nemo)))
172
173(define (sexp->model options doc parse-expr)
174  (match doc
175         (('nemo-model model-name model-decls)
176          (let* ((model+nemo  (nemo-constructor model-name model-decls parse-expr))
177                 (model (first model+nemo))
178                 (nemo  (second model+nemo)))
179            (let ((model-1 (nemo:hh-transformer model parse-expr))) 
180              (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
181              (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))       
182              (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
183              (if (assoc 'components options)
184                  (for-each (lambda (x) 
185                              (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
186                              (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
187                            ((nemo 'components) model-1)))
188              model-1)))
189         (else (error 'sexp->model "unknown model format"))))
190
191(define model->nmodl 
192  (if nemo-nmodl?
193      (lambda (options model)
194        (nemo:nmodl-translator model (lookup-def 'method options) (lookup-def 'table options) 
195                               -150 150 1 (lookup-def 'depend options)
196                               (lookup-def 'kinetic options) ))
197      (lambda (options model) 
198        (void))))
199
200(define model->matlab 
201  (if nemo-matlab?
202      (lambda (options model)
203        (nemo:matlab-translator model (lookup-def 'method options) (lookup-def 'table options) 
204                                -150 150 1 ))
205      (lambda (options model) 
206        (void))))
207
208
209(define (transition->ncml-transition x)
210  (match x
211         (('-> src dst rate) 
212          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
213         ((src '-> dst rate) 
214          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
215         (('<-> src dst rate1 rate2) 
216          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
217            (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
218         ((src '<-> dst rate1 rate2) 
219          `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
220            (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
221         (else (error 'transition->ncml-transition "invalid transition " x))))
222
223(define (lineq->ncml-lineq parse-expr)
224  (lambda (x)
225    (match x 
226           (((and i (? integer?)) '= rhs)
227            `(ncml:lineq (@ (val ,(->string i))) 
228                         (ncml:expr ,(expr->ncml-expr (parse-expr rhs)))))
229           (else (error 'lineq->ncml-lineq "invalid linear equation " x)))))
230
231(define builtin-fns
232  `(+ - * / pow neg abs atan asin acos sin cos exp ln
233      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
234      > < <= >= = and or round ceiling floor max min))
235
236(define (binding->ncml-binding bnd)
237  (match bnd
238         ((id expr)  `(ncml:bnd (@ (id ,id)) (ncml:expr ,(expr->ncml-expr expr))))
239         (else (error 'binding->ncml-binding "invalid binding " bnd))))
240 
241(define (expr->ncml-expr x)
242  (match x
243         ((? number?)    x)
244         ((? symbol?)    `(ncml:id ,x))
245         (('let bnds expr)
246          `(ncml:let (ncml:bnds . ,(map binding->ncml-binding bnds)) 
247                     (ncml:expr ,(expr->ncml-expr expr))))
248         (((and op (? symbol?)) . args)       
249          (let ((ncml-expr (if (member op builtin-fns)
250                               (cons (op->ncml-op op) (map expr->ncml-expr args))
251                               `(ncml:apply (@ (id ,op)) ,@(map expr->ncml-expr args)))))
252            ncml-expr))
253         (else (error 'expr->ncml-expr "unknown expression " x))))
254
255 
256
257(define (op->ncml-op op)
258  (case op
259    ((+)  'ncml:sum)
260    ((-)  'ncml:sub)
261    ((*)  'ncml:mul)
262    ((/)  'ncml:div)
263    ((>)  'ncml:gt)
264    ((<)  'ncml:lt)
265    ((<=) 'ncml:lte)
266    ((>=) 'ncml:gte)
267    ((=)  'ncml:eq)
268    (else  (string->symbol (string-append "ncml:" (->string op))))))
269
270(define (declaration->ncml parse-expr)
271  (lambda (x)
272    (match x
273         (((or 'input 'INPUT) . lst)
274          (map (lambda (x) 
275                 (match x
276                        ((? symbol?) 
277                         `(ncml:input (@ id ,(->string x))))
278                        ((id1 (or 'as 'AS) x1) 
279                         `(ncml:input (@ (id ,(->string id1)) (as ,(->string x1)))))
280                        ((id1 (or 'from 'FROM) n1)
281                         `(ncml:input (@ (id ,(->string id1)) (from ,(->string n1)))))
282                        ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1)
283                         `(ncml:input (@ (id ,(->string id1)) 
284                                         (as ,(->string x1)) (from ,(->string n1)))))))
285               lst))
286
287
288         (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
289          (map  (lambda (x) `(ncml:output (@ (id ,(->string x))))) lst))
290
291
292         (((or 'const 'CONST) (and id (? symbol?)) '= expr)
293          `(ncml:const (@ (id ,(->string id))) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
294
295
296         (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
297          (let ((trs     (lookup-def 'transitions alst))
298                (initial (lookup-def 'initial alst))
299                (open    (lookup-def 'open alst))
300                (cons    (lookup-def 'conserve alst))
301                (p       (lookup-def 'power alst)))
302            (let ((sxml-trs (append-map transition->ncml-transition trs)))
303              `(ncml:reaction (@ (id ,(->string id))) 
304                              (ncml:open ,open) 
305                              ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) )
306                              ,(and cons `(ncml:conserve ,((lineq->ncml-lineq parse-expr) cons)) )
307                              (ncml:transitions ,@sxml-trs)
308                              (ncml:power ,(expr->ncml-expr (parse-expr p)))))))
309
310
311         (((or 'd 'D) ((and id (? symbol?))) '= expr . rest)
312          (let ((initial (lookup-def 'initial rest)))
313            `(ncml:rate (@ (id ,(->string id)) )
314                        ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))))
315                        (ncml:expr ,(expr->ncml-expr (parse-expr expr))))))
316 
317                           
318         (((and id (? symbol?)) '= expr)
319          `(ncml:asgn (@ (id ,id)) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
320                       
321         (((or 'defun 'DEFUN) (and id (? symbol?)) 
322           (and idlist (? (lambda (x) (every symbol? x)))) expr)
323          `(ncml:defun (@ (id ,x)) 
324                       ,@(map (lambda (v) `(ncml:arg ,(->string v))) idlist)
325                       (ncml:body ,(expr->ncml-expr (parse-expr expr)))))
326         
327         (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) ((or 'name 'NAME) name) . lst)
328          `(ncml:component (@ (name ,(->string name)) (type ,(->string typ)))
329                           ,@(map (declaration->ncml parse-expr) lst)))
330         
331         (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
332          `(ncml:component (@ (type ,(->string typ)))
333                           ,@(map (declaration->ncml parse-expr) lst)))
334         
335         (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
336           (and functor-name (? symbol?)) (and args (? list?)))
337          `(ncml:component (@ (name ,(->string name)) 
338                              (functor-name ,(->string functor-name)))
339                           ,@(map (declaration->ncml parse-expr) lst)))
340         )))
341
342(define (make-component->ncml dis model parse-expr)
343  (lambda (x) 
344    (let ((en (environment-ref model x)))
345        (cond ((procedure? en)
346               (let ((fd (procedure-data en)))
347                 `(ncml:defun (@ (id ,x)) 
348                              ,@(map (lambda (v) `(ncml:arg ,v)) (lookup-def 'vars fd))
349                              (ncml:body ,(expr->ncml-expr (lookup-def 'body fd))))))
350              (else
351               (match en
352                     
353                      (($ nemo:quantity 'EXTERNAL   local-name name namespace)
354                       (if namespace
355                           `(ncml:input (@ (id ,name)) (as ,local-name) (from ,namespace))
356                           `(ncml:input (@ (id ,name)) (as ,local-name))))
357
358                      (($ nemo:quantity 'CONST  name value) 
359                       `(ncml:const (@ (id ,name)) (ncml:expr ,value)))
360                     
361                      (($ nemo:quantity 'ASGN name value rhs)
362                       (let ((expr (expr->ncml-expr rhs)))
363                         `(ncml:asgn (@ (id ,name)) (ncml:expr ,expr))))
364                     
365                      (($ nemo:quantity 'RATE name initial rhs)
366                       (let ((expr (expr->ncml-expr rhs))
367                             (initial (and initial (expr->ncml-expr initial))))
368                         `(ncml:rate (@ (id ,name)) 
369                                     ,(and initial `(ncml:initial ,initial))
370                                     (ncml:expr ,expr))))
371                     
372                      (($ nemo:quantity 'REACTION name initial open trs cons p) 
373                       (let ((sxml-trs (append-map transition->ncml-transition trs)))
374                         `(ncml:reaction (@ (id ,name))
375                                         (ncml:open ,open) 
376                                         ,(and initial `(ncml:initial ,(expr->ncml-expr initial)))
377                                         ,(and cons `(ncml:conserve ,(map (lineq->ncml-lineq identity) cons)) )
378                                         (ncml:transitions ,@sxml-trs)
379                                         (ncml:power ,(expr->ncml-expr p)))))
380                     
381                      (($ nemo:quantity 'COMPONENT name type lst) 
382                       (let ((component->ncml (make-component->ncml dis model parse-expr))
383                             (component-exports ((dis 'component-exports) model x)))
384                         (case type
385                           ((toplevel) `(,@(map component->ncml lst)
386                                         ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)))
387                           (else `(ncml:component (@ (name ,name) (type ,type))
388                                                  ,@(filter-map component->ncml lst)
389                                                  ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)
390                                                  )))))
391                     
392                      (($ nemo:quantity 'FUNCTOR name args type lst) 
393                       (let ((component->ncml (make-component->ncml dis model parse-expr)))
394                         `(ncml:functor (@ (name ,name) (type ,type) 
395                                           (parameters ,(string-intersperse (map ->string args) ",")))
396                                        ,@(filter-map (declaration->ncml parse-expr) lst)
397                                        )))
398                     
399                      (else #f)))))))
400   
401
402(define (model->ncml options model parse-expr)
403  (match-let ((($ nemo:quantity 'DISPATCH  dis)     
404               (environment-ref model (nemo-intern 'dispatch))))
405     (let ((sysname     ((dis 'sysname) model))
406           (component->ncml (make-component->ncml dis model parse-expr)))
407       `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel))))))
408           
409
410(include "expr-parser.scm")
411(include "SXML.scm")
412(include "SXML-to-XML.scm")
413(include "stx-engine.scm")
414
415(define null-template 
416  `(*default* ,(lambda (node bindings root env) 
417                 (begin
418                   (warn "Unrecognized input element:" node)
419                   '()))))
420
421(define-syntax  sxml:make-null-ss
422   (syntax-rules  ()
423      ((stx rule ...)
424       (list
425        ; default handler
426        null-template
427        ; handler for textual nodes
428        (list '*text*  (lambda (text) text)) 
429        rule ...))))
430
431(define (ensure-xmlns doc)
432  (let ((doc1 (sxml:add-attr doc '(xmlns:ncml "ncml"))))
433    (sxml:add-attr doc1 '(xmlns ncml))))
434
435
436;; based on SRV:send-reply by Oleg Kiselyov
437(define (print-fragments b)
438  (let loop ((fragments b) (result #f))
439    (cond
440      ((null? fragments) result)
441      ((not (car fragments)) (loop (cdr fragments) result))
442      ((null? (car fragments)) (loop (cdr fragments) result))
443      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
444      ((pair? (car fragments))
445        (loop (cdr fragments) (loop (car fragments) result)))
446      ((procedure? (car fragments))
447        ((car fragments))
448        (loop (cdr fragments) #t))
449      (else
450       (display (car fragments))
451       (loop (cdr fragments) #t)))))
452
453
454(define (ncml->declarations ncml:model)
455  (letrec
456      ((input-template 
457        (sxml:match 'ncml:input
458                    (lambda (node bindings root env) 
459                      (let ((id    (sxml:attr node 'id))
460                            (from  (sxml:kidn* 'ncml:from node))
461                            (as    (sxml:kidn* 'ncml:as node)))
462                        (if (not id) (error 'input-template "input declaration requires id attribute"))
463                        (cond ((and from as)  `(input (,($ id) as ,($ (second as) ) from ,($ (second from)) )))
464                              (from           `(input (,($ id) from ,($ (second from)))))
465                              (as             `(input (,($ id) as ,($ (second as)))))
466                              (else           `(input ,($ id))))))))
467       
468       (output-template 
469        (sxml:match 'ncml:output
470                    (lambda (node bindings root env) 
471                      (let ((id   (sxml:attr node 'id)))
472                        (if (not id) (error 'output-template "output declaration requires id attribute"))
473                        `(output ,($ id))))))
474       
475       (const-template 
476        (sxml:match 'ncml:const
477                    (lambda (node bindings root env) 
478                      (let* ((id   (sxml:attr node 'id))
479                             (expr ((lambda (x) 
480                                      (if (not x) 
481                                          (error 'const-template "const declaration " id " requires expr element")
482                                          (ncml-expr->expr (second x))))
483                                   (sxml:kidn* 'ncml:expr node))))
484                        (if (not id) (error 'const-template "const declaration requires id attribute"))
485                        `(const ,($ id) = ,expr)))))
486       
487       (reaction-transition-template 
488        (sxml:match 'ncml:transition
489                    (lambda (node bindings root env) 
490                      (let ((src  (sxml:attr node 'src))
491                            (dst  (sxml:attr node 'dst))
492                            (rate  ((lambda (x) 
493                                      (if (not x) 
494                                          (error 'reaction-transition-template 
495                                                 "reaction transition requires rate element")
496                                          (ncml-expr->expr (second x))))
497                                    (sxml:kidn* 'ncml:rate node))))
498                        (if (not src) (error 'reaction-transition-template
499                                             "reaction transition requires src attribute"))
500                        (if (not dst) (error 'reaction-transition-template
501                                             "reaction transition requires dst attribute"))
502                       
503                        `(-> ,($ src) ,($ dst) ,rate)))))
504       
505       (asgn-template 
506        (sxml:match 'ncml:asgn
507                    (lambda (node bindings root env) 
508                      (let ((id   (sxml:attr node 'id))
509                            (expr ((lambda (x) 
510                                     (if (not x) 
511                                          (error 'asgn-template "algebraic assignment requires expr element")
512                                          (ncml-expr->expr (second x))))
513                                   (sxml:kidn* 'ncml:expr node))))
514                        (if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
515                        `(,($ id) = ,expr)))))
516       
517       (rate-template 
518        (sxml:match 'ncml:rate
519                    (lambda (node bindings root env) 
520                      (let ((id   (sxml:attr node 'id))
521                            (rhs ((lambda (x) 
522                                     (if (not x) 
523                                          (error 'rate-template "rate equation requires expr element")
524                                          (ncml-expr->expr (second x))))
525                                   (sxml:kidn* 'ncml:expr node)))
526                            (initial ((lambda (x) (and x (ncml-expr->expr (second x))))
527                                      (sxml:kidn* 'ncml:initial node))))
528                        (if (not id) (error 'rate-template "rate equation requires id attribute"))
529                        `(d (,($ id)) = ,rhs ,(and initial `(initial ,initial) ))))))
530       (lineq-template 
531        (sxml:match 'ncml:lineq
532                    (lambda (node bindings root env) 
533                      (let ((val   (string->number (->string (sxml:attr node 'val))))
534                            (rhs   ((lambda (x) 
535                                        (if (not x) 
536                                            (error 'lineq-template 
537                                                   "lineq definition requires expr element")
538                                            (ncml-expr->expr (second x))))
539                                      (sxml:kidn* 'ncml:expr node))))
540                        `(,val = ,rhs)))))
541       
542       (reaction-template 
543        (sxml:match 'ncml:reaction
544                    (lambda (node bindings root env) 
545                      (let* ((id      ($ (sxml:attr node 'id)))
546                            (initial ((lambda (x) (and x (ncml-expr->expr (second x))))
547                                      (sxml:kidn* 'ncml:initial node)))
548
549                            (open    ((lambda (x) 
550                                        (if (not x) 
551                                            (error 'reaction-template
552                                                   "reaction declaration requires open element")
553                                            ($ (second x))))
554                                      (sxml:kidn* 'ncml:open node)))
555
556                            (conserve ((lambda (x) 
557                                         (and x (let ((tmpl (sxml:make-null-ss lineq-template)))
558                                                  (stx:apply-templates (second x) tmpl root env))))
559                                       (sxml:kidn* 'ncml:conserve node)))
560
561                            (power ((lambda (x) 
562                                      (if (not x) 
563                                          (error 'reaction-template
564                                                 "reaction declaration requires open element")
565                                          (sxml:number (second x))))
566                                    (sxml:kidn* 'ncml:power node)))
567
568                            (transitions ((lambda (x) 
569                                            (if (not x) 
570                                                (error 'reaction-template
571                                                       "reaction declaration requires transitions element")
572                                                (let ((tmpl (sxml:make-null-ss reaction-transition-template)))
573                                                  (stx:apply-templates (cdr x) tmpl root env))))
574                                          (sxml:kidn* 'ncml:transitions node)))
575
576                            )
577                                         
578                        (if (not id) (error 'reaction-template "reaction transition requires id attribute"))
579                        `(reaction (,id (initial ,initial) (open ,open) (power ,power) 
580                                        ,(and conserve `(conserve ,conserve) )
581                                        (transitions ,@transitions)))))))
582
583
584       (defun-template 
585        (sxml:match 'ncml:defun
586                    (lambda (node bindings root env) 
587                      (let ((id    (sxml:attr node 'id))
588                            (args  ((lambda (x) 
589                                      (if (null? x) 
590                                          (error 'defun-template 
591                                                 "function definition requires at least one arg element")
592                                          (map (compose $ second) x)))
593                                    (sxml:kidsn 'ncml:arg node)))
594                            (body ((lambda (x) 
595                                     (if (not x) 
596                                         (error 'defun-template
597                                                "function definition requires body element")
598                                         (ncml-expr->expr (second x))))
599                                   (sxml:kidn* 'ncml:body node))))
600                        (if (not id) (error 'defun-template "function definition requires id attribute"))
601                        `(defun ,($ id) ,args ,body)))))
602
603       (component-template
604        (sxml:match 'ncml:component
605                    (lambda (node bindings root env)
606                      (let ((name (sxml:attr node 'name))
607                            (functor-name (sxml:attr node 'functor-name))
608                            (type (sxml:attr node 'type)))
609                        (if (not type) (error 'component-template "component definition requires type attribute"))
610                        (if name
611                            `(component (type ,($ type)) (name ,($ name)) ,@(ncml->declarations (sxml:kids node)))
612                            (if functor-name
613                                `(component (name ,($ name)) = ,functor-name ,(ncml->declarations (sxml:kids node)))
614                                `(component (type ,($ type)) ,@(ncml->declarations (sxml:kids node)))))))))
615
616       (functor-template
617        (sxml:match 'ncml:functor
618                    (lambda (node bindings root env)
619                      (let ((parameters (sxml:attr node 'parameters))
620                            (name (sxml:attr node 'name))
621                            (type (sxml:attr node 'type)))
622                        (if (not type) (error 'functor-template "functor definition requires type attribute"))
623                        (if (not name) (error 'functor-template "functor definition requires name attribute"))
624                        (if (not parameters) 
625                            (error 'functor-template "functor definition requires parameters attribute"))
626                        `(functor (type ,($ type)) (name ,($ name)) 
627                                  (args ,(map string->symbol (string-split parameters ",")))
628                                  ,@(ncml->declarations (sxml:kids node)))))))
629
630       (hh-template 
631        (sxml:match 'ncml:hh_ionic_conductance 
632                    (lambda (node bindings root env)
633                      (let* ((or-expr   (lambda (x) (and x (ncml-expr->expr (second x)))))
634                             (id         (sxml:attr node 'id))
635                             (initial_m  (or-expr (sxml:kidn* 'ncml:initial_m node)))
636                             (initial_h  (or-expr (sxml:kidn* 'ncml:initial_h node)))
637                             (m_power    (or-expr (sxml:kidn* 'ncml:m_power node)))
638                             (h_power    (or-expr (sxml:kidn* 'ncml:h_power node)))
639                             (m_alpha    (or-expr (sxml:kidn* 'ncml:m_alpha node)))
640                             (m_beta     (or-expr (sxml:kidn* 'ncml:m_beta node)))
641                             (h_alpha    (or-expr (sxml:kidn* 'ncml:h_alpha node)))
642                             (h_beta     (or-expr (sxml:kidn* 'ncml:h_beta node)))
643                             (m_tau      (or-expr (sxml:kidn* 'ncml:m_tau node)))
644                             (m_inf      (or-expr (sxml:kidn* 'ncml:m_inf node)))
645                             (h_tau      (or-expr (sxml:kidn* 'ncml:h_tau node)))
646                             (h_inf      (or-expr (sxml:kidn* 'ncml:h_inf node))))
647                        (if (not id)
648                            (error 'hh-template "hh ionic conductance definition requires id attribute"))
649                        `(hh-ionic-gate 
650                          (,($ id)
651                           ,@(if initial_m `((initial-m ,initial_m)) `())
652                           ,@(if initial_h `((initial-h ,initial_h)) `())
653                           ,@(if m_power `((m-power ,m_power)) '())
654                           ,@(if h_power `((h-power ,h_power)) '())
655                           ,@(if m_alpha `((m-alpha ,m_alpha)) '())
656                           ,@(if h_alpha `((h-alpha ,h_alpha)) '())
657                           ,@(if m_beta  `((m-beta ,m_beta)) '())
658                           ,@(if h_beta  `((h-beta ,h_beta)) '())
659                           ,@(if m_inf   `((m-inf ,m_inf)) '())
660                           ,@(if h_inf   `((h-inf ,h_inf)) '())
661                           ,@(if m_tau   `((m-tau ,m_tau)) '())
662                           ,@(if h_tau   `((h-tau ,h_tau)) '())
663                           ))))))
664
665       (decaying-pool-template 
666        (sxml:match 'ncml:decaying_pool 
667                    (lambda (node bindings root env)
668                      (let* ((or-expr   (lambda (x) (and x (ncml-expr->expr (second x)))))
669                             (id         (sxml:attr node 'id))
670                             (initial    (or-expr (sxml:kidn* 'ncml:initial node)))
671                             (beta       (or-expr (sxml:kidn* 'ncml:beta node)))
672                             (depth      (or-expr (sxml:kidn* 'ncml:depth node)))
673                             (temp-adj   (or-expr (sxml:kidn* 'ncml:temp_adj node))))
674                        (if (not id)
675                            (error 'decaying-pool-template "decaying pool definition requires id attribute"))
676                        (if (not initial) 
677                            (error 'decaying-pool-template "decaying pool definition requires initial value"))
678                        (if (not beta) 
679                            (error 'decaying-pool-template "decaying pool definition requires beta parameter"))
680                        (if (not depth) 
681                            (error 'decaying-pool-template "decaying pool definition requires depth parameter"))
682                           
683                        `(decaying-pool 
684                          (,($ id)
685                           ,@(if temp_adj `((temp_adj ,temp_adj)) `())
686                           (beta ,beta)
687                           (depth ,depth)
688                           (initial ,initial)))))))
689        )
690
691     (stx:apply-templates ncml:model 
692                          (sxml:make-null-ss input-template
693                                             output-template
694                                             const-template
695                                             asgn-template
696                                             rate-template
697                                             reaction-template
698                                             defun-template
699                                             component-template
700                                             functor-template
701                                             hh-template
702                                             decaying-pool-template) 
703                          ncml:model (list))))
704
705
706
707(define (ncml->model options doc)
708  (let* ((ncml:model   ((lambda (x) 
709                          (if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x)))
710                        (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
711         (model-name   (sxml:attr ncml:model 'name))
712         (model-decls  (ncml->declarations (sxml:kids ncml:model))))
713    (let* ((model+nemo  (nemo-constructor model-name model-decls (lambda (x . rest) (identity x))))
714           (model       (first model+nemo))
715           (nemo        (second model+nemo)))
716      (let ((model-1 (nemo:hh-transformer model))) 
717        (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
718        (if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))     
719        (if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
720        (if (assoc 'components options)
721            (for-each (lambda (x) 
722                        (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
723                        (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
724                      ((nemo 'components) model-1)))
725        model-1))))
726
727
728 
729(define (main options operands)
730  (if (null? operands)
731      (usage)
732      (for-each
733       (lambda (operand)
734         (let* ((read-xml   (lambda (name) (call-with-input-file name
735                                            (lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
736                (read-sexp  (lambda (name) (call-with-input-file name read)))
737                (in-format  (cond ((lookup-def 'i options) =>
738                                   (lambda (x) 
739                                     (case ($ x)
740                                       ((nemo)        'nemo)
741                                       ((s-exp sexp)  'sexp)
742                                       ((sxml)  'sxml)
743                                       ((xml)   'xml)
744                                       (else    (error 'nemo "unknown input format" x)))))
745                                  (else  (case ((lambda (x) (or (not x) ($ x)))
746                                                (pathname-extension operand))
747                                           ((s-exp sexp)  'sexp)
748                                           ((sxml)  'sxml)
749                                           ((xml)   'xml)
750                                           (else    'nemo)))))
751                (doc        (case in-format
752                              ((nemo sxml s-exp sexp)  (read-sexp operand))
753                              ((xml)   (read-xml operand))
754                              (else    (error 'nemo "unknown input format" in-format))))
755
756                (parse-expr  (case in-format
757                               ((sxml xml)          identity)
758                               ((s-exp sexp)        identity)
759                               ((nemo)              nemo:parse-sym-expr)
760                               (else    (error 'nemo "unknown input format" in-format)))) 
761
762                (model       (case in-format
763                               ((sxml xml)          (ncml->model options doc))
764                               ((s-exp sexp)        (sexp->model options doc parse-expr))
765                               ((nemo)              (sexp->model options doc parse-expr))
766                               (else    (error 'nemo "unknown input format" in-format))))
767
768                (sxml-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
769                                                     (s+ (pathname-strip-extension (cdr x)) ".sxml")
770                                                     (s+  (pathname-strip-extension operand) ".sxml"))))
771                              (assoc 'sxml options)))
772                (xml-fname  ((lambda (x)  (and x (if (and (cdr x) (string? (cdr x)))
773                                                     (s+ (pathname-strip-extension (cdr x)) ".xml")
774                                                     (s+  (pathname-strip-extension operand) ".xml"))))
775                              (assoc 'xml options)))
776                (mod-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
777                                                    (s+ (pathname-strip-extension (cdr x)) ".mod")
778                                                    (s+  (pathname-strip-extension operand) ".mod"))))
779                             (assoc 'nmodl options)))
780                (mat-fname  ((lambda (x) (and x (if (and (cdr x) (string? (cdr x)))
781                                                    (s+ (pathname-strip-extension (cdr x)) ".m")
782                                                    (s+  (pathname-strip-extension operand) ".m"))))
783                             (assoc 'matlab options)))
784                (nmodl-depend  (lookup-def 'nmodl-depend options))
785                                 
786                (nmodl-method
787                 (let ((method  ($ (lookup-def 'nmodl-method options) )))
788                   (case method
789
790                     ((adams runge euler adeuler heun adrunge gear
791                             newton simplex simeq seidel sparse derivimplicit cnexp clsoda
792                             after_cvode cvode_t cvode_t_v expeuler #f) method)
793                     (else (error "unknown nmodl-method " method)))))
794
795                (matlab-method
796                 (let ((method  ($ (lookup-def 'matlab-method options) )))
797                   (case method
798                     ((lsode odepkg #f) method)
799                     (else (error "unknown matlab-method " method)))))
800                )
801           (if sxml-fname (with-output-to-file sxml-fname 
802                            (lambda () (pretty-print (model->ncml options model parse-expr)))))
803           (if xml-fname  (let* ((doc  (model->ncml options model parse-expr))
804                                 (doc1 (ensure-xmlns
805                                       (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc)))
806                                             (else doc)))))
807                            (with-output-to-file xml-fname 
808                              (lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
809           (if mod-fname
810               (with-output-to-file
811                   mod-fname  (lambda () 
812                                (model->nmodl `((depend  . ,nmodl-depend)
813                                                (method  . ,nmodl-method)
814                                                (table   . ,(assoc 't options))
815                                                (kinetic 
816                                                 ,(let ((opt (assoc 'nmodl-kinetic options)))
817                                                    (and opt
818                                                         (if (string? (cdr opt))
819                                                             (map string->symbol (string-split (cdr opt) ","))
820                                                             'all)))))
821                                              model))))
822           (if mat-fname
823               (with-output-to-file
824                   mat-fname  (lambda () 
825                                (model->matlab `((method  . ,matlab-method)
826                                                 (table   . ,(assoc 't options))
827                                                 )
828                                               model))))
829           ))
830       operands)))
831
832(main options operands)
833
Note: See TracBrowser for help on using the repository browser.