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

Last change on this file since 25870 was 25870, checked in by Ivan Raikov, 9 years ago

nemo: updated copyright year

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