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

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

nemo: eliminated dependency on environments

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