;;
;; NEMO
;;
;; Copyright 2008-2013 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;

(import files setup-api srfi-1 srfi-4 srfi-13 srfi-69)


(require-extension nemo-core nemo-macros nemo-hh nemo-vclamp nemo-iclamp nemo-utils)
(require-library iexpr ersatz-lib)
(require-extension datatype matchable lalr-driver
		   ssax sxml-transforms sxpath sxpath-lolevel 
		   getopt-long)
(import (prefix iexpr iexpr: )
	(prefix ersatz-lib ersatz: )
	)

(define user-template-list?
  (lambda (ts) 
    (every (lambda (x) (and (string? (car x))
			    (every string? (cadr x))
			    (every ersatz:tstmt? (caddr x)))) ts)))


(define-datatype nemo:model nemo:model?
  (ModelSource (source-path string?) (in-format symbol?) (name symbol?) 
	       (decls list?) 
	       (user-templates user-template-list?)
	       (iexpr boolean?) (parse-expr procedure?))
  (SingleModel (source-path string?) (in-format symbol?) (name symbol?) 
	       (sys hash-table?) (decls list?) (user-templates user-template-list?)
	       (iexpr boolean?) (parse-expr procedure?))
  (ModelPart   (source-path string?) (in-format symbol?) (name symbol?) (part-name symbol?) 
	       (sys hash-table?) (decls list?) (parent-decls list?)
               (user-templates user-template-list?)
	       (iexpr boolean?) (parse-expr procedure?))
  )
 

(define nemo-nmodl?       (extension-information 'nemo-nmodl))  
(define nemo-matlab?      (extension-information 'nemo-matlab)) 
(define nemo-nest?        (extension-information 'nemo-nest)) 
(define nemo-pyparams?    (extension-information 'nemo-pyparams)) 

(if nemo-nmodl?   (use nemo-nmodl))
(if nemo-matlab?  (use nemo-matlab))
(if nemo-nest?    (use nemo-nest))
(if nemo-pyparams?    (use nemo-pyparams))

(define (lookup-def k lst . rest)
  (let-optionals rest ((default #f))
      (let ((kv (assoc k lst)))
	(if (not kv) default
	    (match kv ((k v) v) (else (cdr kv)))))))

(define ($ x)  (and x (string->symbol (->string x))))

;;; Procedures for string concatenation and pretty-printing

(define (s+ . lst)    (string-concatenate (map ->string lst)))
(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
(define (sl\ p lst)   (string-intersperse (map ->string lst) p))
(define nl "\n")


(define (warn port message . specialising-msgs)
  (print-error-message message (current-output-port) "Warning")
  (print (string-concatenate (map ->string specialising-msgs))))

;;; Error procedure for the XML parser

(define (parser-error port message . specialising-msgs)
  (error (string-append message (string-concatenate (map ->string specialising-msgs)))))

(define ssax:warn warn)

(define opt-defaults
  `(
    (nmodl-kinetic . all)
    (nmodl-method . cnexp)
    ))

(define (defopt x)
  (lookup-def x opt-defaults))

(define opt-grammar
  `(
    (input-format
     "specify input format (nemo, xml, ixml, sxml, s-exp)"
     (single-char #\i)
     (value (required FORMAT)
	    (transformer ,string->symbol)))

    (partition
     "partition model source into individual parts for each current"
     (single-char #\p))

    (surface-xml
     "write surface XML translation of input to file (default: <model-name>.xml)"
     (value (optional DIRNAME)
	    ))

    (plain
     "write plain text output to file (default: <model-name>.txt)"
     (value (optional DIRNAME)
	    ))

    (xml
     "write XML output to file (default: <model-name>.xml)"
     (value (optional DIRNAME)
	    ))

    (sxml
     "write SXML output to file (default: <model-name>.sxml)"
     (value (optional DIRNAME)
	    ))

    (hh-markov
     "convert HH rate equations to Markov chain form")

    ,@(if nemo-nest? 
	  `(
	    (nest
	     "write NEST output files <model-name>.cpp and <model-name>.h in the given directory (default: .)" 
	     (value (optional DIRNAME)))

	    (nest-method
	     "specify NEST integration method (gsl, cvode, leapfrog)"
	     (value (required METHOD)
		    (transformer ,string->symbol)))
	    )
	  `())

    ,@(if nemo-pyparams? 
	  `(
	    (pyparams
	     "write Python representation of parameters to given file (default: <model-name>.py)"
	     (value (optional DIRNAME)))
	    )
	  `())

    ,@(if nemo-matlab? 
	  `((matlab
	     "write MATLAB output in the given directory (default: .)"
	     (value (optional DIRNAME)))

	    (octave
	     "write Octave output to given file (default: <model-name>.m)"
	     (value (optional DIRNAME)))
		     
	    (octave-method
	     "specify Octave integration method (lsode, odepkg, or cvode)"
	     (value (required METHOD)
		    (transformer ,string->symbol)))
	    )
	  `())

    ,@(if nemo-nmodl?
	  `(
	     (nmodl      "write NMODL output to file (default: <model-name>.mod)"
			 (value (optional DIRNAME)))

	     (nmodl-kinetic  ,(s+ "use NMODL kinetic equations for the given reactions "
				  "(or for all reactions)")
			     (value (optional STATES)
				    (default  ,(defopt 'nmodl-kinetic))
				    (transformer 
				     ,(lambda (x) 
					(if (string=? x "all") 'all
					    (map string->symbol (string-split x ",")))))))
	     
	     (nmodl-method   "specify NMODL integration method"
			     (value (required METHOD)
				    (transformer ,string->symbol)))
	     )
	    `())

    (vclamp-hoc
     "write voltage clamp scripts to HOC file (default: <model-name>.hoc)"
     (value (optional DIRNAME)
	    ))

    (vclamp-octave
     "write voltage clamp script to Octave file (default: <model-name>_vclamp.m)"
     (value (optional DIRNAME)
	    ))

    (iclamp-hoc
     "write current pulse injection scripts to HOC file (default: <model-name>.hoc)"
     (value (optional DIRNAME)
	    ))

    (iclamp-nest
     "write current pulse injection script to NEST SLI file (default: <model-name>.sli)"
     (value (optional DIRNAME)
	    ))

    (template
     "instantiate the given template from the model file by setting the given variables to the respective values"
     (value (required "NAME[:VAR=VAL...]"))
     (multiple #t)
     )

    (template-prefix 
     "output instantiated templates to <PREFIX><template_name> (default is <model-name>_<template_name>)"
     (value (required PREFIX)
	    ))

    (debug "print additional debugging information")

    (version "print the current version and exit")

    (help         (single-char #\h))


    ))


;; Use args:usage to generate a formatted list of options (from OPTS),
;; suitable for embedding into help text.
(define (nemo:usage)
  (print "Usage: " (car (argv)) "  <list of files to be processed> [options...] ")
  (newline)
  (print "The following options are recognized: ")
  (newline)
  (print (parameterize ((indent 5) (width 30)) (usage opt-grammar)))
  (exit 1))


;; Process arguments and collate options and arguments into OPTIONS
;; alist, and operands (filenames) into OPERANDS.  You can handle
;; options as they are processed, or afterwards.

(define opts    (getopt-long (command-line-arguments) opt-grammar))
(define opt     (make-option-dispatch opts opt-grammar))


(define (ncml:sxpath query doc)
  ((sxpath query '((ncml . "ncml"))) doc))

(define (ncml:car-sxpath query doc)
  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
    (car lst)))

(define (ncml:if-car-sxpath query doc)
  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
    (and (not (null? lst)) (car lst))))

(define (ncml:if-sxpath query doc)
  (let ((lst ((sxpath query '((ncml . "ncml") )) doc)))
    (and (not (null? lst)) lst)))

(define (ncml-binding->binding node)
  (match node
    (('ncml:bnd ('@ ('id id)) ('ncml:expr expr))
     `(,($ id) ,(ncml-expr->expr expr)))
    (else (error 'ncml-binding->binding "invalid binding " node))))
  
(define (ncml-expr->expr node)
  (match node
	 ((? number?)    node)
	 ((? string?)    (sxml:number node))
	 (('ncml:id id)  ($ id))
	 (('ncml:apply ('@ ('id id)) . args)  (cons ($ id) (map ncml-expr->expr args)))
	 (('ncml:let ('ncml:bnds . bnds) ('ncml:expr body))
	  `(let ,(map ncml-binding->binding bnds) ,(ncml-expr->expr body)))
	 (((and op (? symbol?)) . args)
	  (cons (ncml-op->op op) (map ncml-expr->expr args)))
	 (else (error 'ncml-expr->expr "unknown expression " node))))
  

(define (ncml-op->op op)
  (case op
    ((ncml:sum)    '+)
    ((ncml:sub)    '-)
    ((ncml:mul)    '*)
    ((ncml:div)    '/)
    ((ncml:gt)     '>)
    ((ncml:lt)     '<)
    ((ncml:lte)    '<=)
    ((ncml:gte)    '>=)
    ((ncml:eq)     '=)
    (else          (match (string-split (->string op) ":")
			  ((pre op)  ($ op))
			  (else (error 'ncml-op->op "invalid operator" op))))))


(define (nemo-constructor name declarations parse-expr)
  (let* ((nemo   (make-nemo-core))
	 (sys    ((nemo 'system) name))
	 (qs     (eval-nemo-system-decls nemo name sys declarations parse-expr)))
    (list sys nemo qs)))


(define (sexp->model-decls doc)
  (match doc
	 ((or ('nemo-model model-name model-decls)
	      ('nemo-model (model-name . model-decls)))
	  (list model-name model-decls))
	 ((or ('nemo-model model-name model-decls user-templates)
	      ('nemo-model (model-name . model-decls) user-templates))
	  (list model-name model-decls 
		(map (lambda (x) (list (->string (car x)) 
				       (map ->string (cadr x))
				       (ersatz:statements-from-string
					(ersatz:template-std-env) 
					(caddr x))))
			     user-templates)))
	 (else (error 'sexp->model "unknown model format"))
	 ))


(define (sexp-model-decls->model options model-name model-decls parse-expr)
  (let* ((model+nemo  (nemo-constructor model-name model-decls parse-expr))
	 (model (first model+nemo))
	 (nemo  (second model+nemo)))
    (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) parse-expr))) 
      (if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
      (if (assoc 'exports options)  (print "exports: " ((nemo 'exports) model-1)))	
      (if (assoc 'imports options)  (print "imports: " ((nemo 'imports) model-1)))
      (if (assoc 'components options)
	  (for-each (lambda (x) 
		      (print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
		      (print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
		    ((nemo 'components) model-1)))
      model-1)))
	 

(define model->nmodl 
  (if nemo-nmodl?
      (lambda (options model)
	(nemo:nmodl-translator model
                               (lookup-def 'method options) 
			       (lookup-def 'kinetic options) ))
      (lambda (options model) 
	(void))))


(define model->nest 
  (if nemo-nest?
      (lambda (options model)
	(nemo:nest-translator model (lookup-def 'dirname options) (lookup-def 'method options)))
      (lambda (options model) 
	(void))))

(define model->pyparams 
  (if nemo-pyparams?
      (lambda (options model)
	(nemo:pyparams-translator (list model) 
                                  (lookup-def 'mode options) 
                                  (lookup-def 'filename options)))
      (lambda (options model) 
	(void))))


(define model->matlab 
  (if nemo-matlab?
      (lambda (options model)
	(nemo:matlab-translator model #f (lookup-def 'dirname options)))
      (lambda (options model) 
	(void))))


(define model->vclamp-hoc 
  (lambda (options model)
    (nemo:vclamp-translator model 'hoc (lookup-def 'filename options))))


(define model->vclamp-octave 
  (lambda (options model)
    (nemo:vclamp-translator model 'matlab 
                            (lookup-def 'filename options)
                            (lookup-def 'octave-method options))))


(define model->iclamp-hoc 
  (lambda (options model)
    (nemo:iclamp-translator model 'hoc (lookup-def 'filename options))))

(define model->iclamp-nest 
  (lambda (options model)
    (nemo:iclamp-translator model 'nest (lookup-def 'filename options))))


(define model->octave 
  (if nemo-matlab?
      (lambda (options model)
	(nemo:octave-translator model 
				(lookup-def 'filename options)
				(lookup-def 'dirname options)))
      (lambda (options model) 
	(void))))


(define (transition->ncml-transition x)
  (match x
	 (('-> src dst rate) 
	  `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
	 ((src '-> dst rate) 
	  `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate)))))
	 (('<-> src dst rate1 rate2) 
	  `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
	    (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
	 ((src '<-> dst rate1 rate2) 
	  `((ncml:transition (@ (src ,src) (dst ,dst))  (ncml:rate ,(expr->ncml-expr rate1)))
	    (ncml:transition (@ (src ,dst) (dst ,src))  (ncml:rate ,(expr->ncml-expr rate2)))))
	 (else (error 'transition->ncml-transition "invalid transition " x))))


(define (conseq->ncml-conseq parse-expr)
  (lambda (x)
    (match x 
	   (((and i (? integer?)) '= rhs)
	    `(ncml:conseq (@ (val ,(->string i))) 
			 (ncml:expr ,(expr->ncml-expr (parse-expr rhs)))))
	   (else (error 'conseq->ncml-conseq "invalid linear equation " x)))))


(define builtin-fns
  `(+ - * / pow neg abs atan asin acos sin cos exp ln
      sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
      > < <= >= = and or round ceiling floor max min))


(define (binding->ncml-binding bnd)
  (match bnd
	 ((id expr)  `(ncml:bnd (@ (id ,id)) (ncml:expr ,(expr->ncml-expr expr))))
	 (else (error 'binding->ncml-binding "invalid binding " bnd))))

  
(define (expr->ncml-expr x)
  (match x
	 ((? number?)    x)
	 ((? symbol?)    `(ncml:id ,x))
	 (('let bnds expr)
	  `(ncml:let (ncml:bnds . ,(map binding->ncml-binding bnds)) 
		     (ncml:expr ,(expr->ncml-expr expr))))
	 (((and op (? symbol?)) . args)
	  (let ((ncml-expr (if (member op builtin-fns)
			       (cons (op->ncml-op op) (map expr->ncml-expr args))
			       `(ncml:apply (@ (id ,op)) ,@(map expr->ncml-expr args)))))
	    ncml-expr))
	 (else (error 'expr->ncml-expr "unknown expression " x))))

  

(define (op->ncml-op op)
  (case op
    ((+)  'ncml:sum)
    ((-)  'ncml:sub)
    ((*)  'ncml:mul)
    ((/)  'ncml:div)
    ((>)  'ncml:gt)
    ((<)  'ncml:lt)
    ((<=) 'ncml:lte)
    ((>=) 'ncml:gte)
    ((=)  'ncml:eq)
    (else  ($ (string-append "ncml:" (->string op))))))



(define (declaration->ncml parse-expr)
  (lambda (x)
    (match x
	 (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
	  `(ncml:label (@ (id ,(->string id))) ,v))

	 (((or 'input 'INPUT) . lst)
	  (map (lambda (x) 
		 (match x
			((? symbol?) 
			 `(ncml:input (@ id ,(->string x))))
			((id1 (or 'as 'AS) x1) 
			 `(ncml:input (@ (id ,(->string id1)) (as ,(->string x1)))))
			((id1 (or 'from 'FROM) n1)
			 `(ncml:input (@ (id ,(->string id1)) (from ,(->string n1)))))
			((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1)
			 `(ncml:input (@ (id ,(->string id1)) 
					 (as ,(->string x1)) (from ,(->string n1)))))))
	       lst))


	 (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
	  (map  (lambda (x) `(ncml:output (@ (id ,(->string x))))) lst))


	 (((or 'const 'CONST) (and id (? symbol?)) '= expr)
	  `(ncml:const (@ (id ,(->string id))) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))


	 (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
	  (let ((trs     (lookup-def 'transitions alst))
		(initial (lookup-def 'initial alst))
		(open    (lookup-def 'open alst))
		(cons    (lookup-def 'conserve alst))
		(p       (lookup-def 'power alst)))
	    (let ((sxml-trs (append-map transition->ncml-transition trs)))
	      `(ncml:reaction (@ (id ,(->string id))) 
			      (ncml:open ,(if (list? open) 
					      (string-concatenate (intersperse (map ->string open) ",")) 
					      open))
			      ,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))) )
			      ,(and cons `(ncml:conserve ,((conseq->ncml-conseq parse-expr) cons)) )
			      (ncml:transitions ,@sxml-trs)
			      (ncml:power ,(expr->ncml-expr (parse-expr p)))))))


	 (((or 'd 'D) ((and id (? symbol?))) '= expr . rest)
	  (let ((initial (lookup-def 'initial rest)))
	    `(ncml:rate (@ (id ,(->string id)) )
			,(and initial `(ncml:initial ,(expr->ncml-expr (parse-expr initial))))
			(ncml:expr ,(expr->ncml-expr (parse-expr expr))))))
  
			    
	 (((and id (? symbol?)) '= expr)
	  `(ncml:asgn (@ (id ,id)) (ncml:expr ,(expr->ncml-expr (parse-expr expr)))))
		       
	 (((or 'defun 'DEFUN 'fun 'FUN 'rel 'REL) (and id (? symbol?)) 
	   (and idlist (? (lambda (x) (every symbol? x)))) expr)
	  `(ncml:defun (@ (id ,x)) 
		       ,@(map (lambda (v) `(ncml:arg ,(->string v))) idlist)
		       (ncml:body ,(expr->ncml-expr (parse-expr expr)))))
	 
	 (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ) ((or 'name 'NAME) name) . lst)
	  `(ncml:component (@ (name ,(->string name)) (type ,(->string typ)))
			   ,@(map (declaration->ncml parse-expr) lst)))
	 
	 (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst)  
	  `(ncml:component (@ (type ,(->string typ)))
			   ,@(map (declaration->ncml parse-expr) lst)))
	 
	 (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
	   (and functor-name (? symbol?)) (and args (? list?)))
	  `(ncml:component (@ (name ,(->string name)) 
			      (functor-name ,(->string functor-name)))
			   ,@(map (declaration->ncml parse-expr) lst)))
	 )))


(define (make-component->ncml dis model parse-expr)
  (lambda (x) 
    (let ((en (hash-table-ref model x)))
	(cond ((procedure? en)
	       (let ((fd (procedure-data en)))
		 `(ncml:defun (@ (id ,x)) 
			      ,@(map (lambda (v) `(ncml:arg ,v)) (lookup-def 'vars fd))
			      (ncml:body ,(expr->ncml-expr (lookup-def 'body fd))))))
	      (else
	       (match en
		      (($ nemo:quantity 'LABEL  v) 
		       `(ncml:label (@ (id ,name)) ,v))
		      
		      (($ nemo:quantity 'EXTERNAL   local-name name namespace)
		       (if namespace
			   `(ncml:input (@ (id ,name)) (as ,local-name) (from ,namespace))
			   `(ncml:input (@ (id ,name)) (as ,local-name))))

		      (($ nemo:quantity 'CONST  name value) 
		       `(ncml:const (@ (id ,name)) (ncml:expr ,value)))
		      
		      (($ nemo:quantity 'ASGN name value rhs)
		       (let ((expr (expr->ncml-expr rhs)))
			 `(ncml:asgn (@ (id ,name)) (ncml:expr ,expr))))
		      
		      (($ nemo:quantity 'RATE name initial rhs power)
		       (let ((expr (expr->ncml-expr rhs))
			     (initial (and initial (expr->ncml-expr initial))))

			 `(ncml:rate (@ (id ,name)) 
				     ,(and initial `(ncml:initial ,initial))
				     (ncml:expr ,expr)
				     (ncml:power ,(or (and power (expr->ncml-expr power)) 
						      (expr->ncml-expr 1.0)))
				     )))
		      
		      (($ nemo:quantity 'REACTION name initial open trs cons p) 
		       (let ((sxml-trs (append-map transition->ncml-transition trs)))
			 `(ncml:reaction (@ (id ,name))
					 (ncml:open ,(if (list? open) 
							 (string-concatenate (intersperse (map ->string open) ",")) 
							 open))
					 ,(and initial `(ncml:initial ,(expr->ncml-expr initial)))
					 ,(and cons `(ncml:conserve ,(map (conseq->ncml-conseq identity) cons)) )
					 (ncml:transitions ,@sxml-trs)
					 (ncml:power ,(expr->ncml-expr p)))))
		      
		      (($ nemo:quantity 'COMPONENT name type lst) 
		       (let ((component->ncml (make-component->ncml dis model parse-expr))
			     (component-exports ((dis 'component-exports) model x)))
			 (case type
			   ((toplevel) `(,@(map component->ncml lst)
					 ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)))
			   (else `(ncml:component (@ (name ,name) (type ,type))
						  ,@(filter-map component->ncml lst)
						  ,@(map (lambda (x) `(ncml:output (@ (id ,x)))) component-exports)
						  )))))
		      
		      (($ nemo:quantity 'FUNCTOR name args type lst) 
		       (let ((component->ncml (make-component->ncml dis model parse-expr)))
			 `(ncml:functor (@ (name ,name) (type ,type) 
					   (parameters ,(string-intersperse (map ->string args) ",")))
					,@(filter-map (declaration->ncml parse-expr) lst)
					)))
		      
		      (else #f)))))))
    

(define (model->ncml model parse-expr)
  (match-let ((($ nemo:quantity 'DISPATCH  dis)     
	       (hash-table-ref model (nemo-intern 'dispatch))))
     (let ((sysname     ((dis 'sysname) model))
	   (component->ncml (make-component->ncml dis model parse-expr)))
       `(ncml:model (@ (name ,sysname)) ,@(component->ncml (nemo-intern 'toplevel))))))
	   

(define (transition->text-transition x)
  (match x
	 (('-> src dst rate) 
	  `(-> ,src ,dst ,(expr->text-expr rate) ))
	 ((src '-> dst rate) 
	  `(-> ,src ,dst ,(expr->text-expr rate) ))
	 (('<-> src dst rate1 rate2) 
	  `(<-> ,src ,dst ,(expr->text-expr rate) ))
	 (('src <-> dst rate1 rate2) 
	  `(<-> ,src ,dst ,(expr->text-expr rate) ))
	 (else (error 'transition->text-transition "invalid transition " x))))


(define (conseq->text-conseq parse-expr)
  (lambda (x)
    (match x 
	   (((and i (? integer?)) '= rhs)
	    `(,(->string i) =
	      ,(expr->text-expr (parse-expr rhs))))
	   (else (error 'conseq->text-conseq "invalid linear equation " x)))))


(define (binding->text-binding bnd)
  (match bnd
	 ((id expr)  `(,id = ,(expr->text-expr expr)))
	 (else (error 'binding->text-binding "invalid binding " bnd))))

  
(define (expr->text-expr x)
  (match x
	 ((? number?)    x)
	 ((? symbol?)    x)
	 (('let bnds expr)
	  `(let (,(map binding->text-binding bnds))
	     ,(expr->text-expr expr)))
	 (((and op (? symbol?)) . args)
	  (let ((ncml-expr `(apply ,op ,@(map expr->text-expr args))))
	    ncml-expr))
	 (else (error 'expr->text-expr "unknown expression " x))))


(define (make-component->text dis model parse-expr)
  (lambda (x) 
    (let ((en (hash-table-ref model x)))
	(cond ((procedure? en)
	       (let ((fd (procedure-data en)))
		 `(function ,x
			    ,(lookup-def 'vars fd) =
			    ,(expr->text-expr (lookup-def 'body fd)))
		 ))
	      (else
	       (match en
		      (($ nemo:quantity 'LABEL  v) 
		       `(label ,name = ,v))
		      
		      (($ nemo:quantity 'EXTERNAL local-name name namespace)
		       (if namespace
			   `(input ,name  as ,local-name from ,namespace)
			   `(input ,name  as ,local-name)))

		      (($ nemo:quantity 'CONST  name value) 
		       `(const ,name = ,value))
		      
		      (($ nemo:quantity 'ASGN name value rhs)
		       (let ((expr (expr->text-expr rhs)))
			 `(,name = ,expr)))
		      
		      (($ nemo:quantity 'RATE name initial rhs power)
		       (let ((expr (expr->ncml-expr rhs))
			     (initial (and initial (expr->text-expr initial)))
			     (power (or (and power (expr->text-expr power))
					(expr->text-expr 1.0))))

			 `(d (,name) = (,expr)
			     (initial: ,initial)
			     (power: ,power))
			 ))

		      
		      (($ nemo:quantity 'REACTION name initial open trs cons p) 
		       (let ((sxml-trs (append-map transition->text-transition trs)))
			 `(reaction  ,name
				     (open-state: ,open) 
				     (initial: ,(expr->text-expr initial))
				     (conserve: ,(map (conseq->text-conseq identity) cons))
				     (transitions: ,text-trs)
				     (power: ,(expr->ncml-expr p))
				     )))

		      
		      (($ nemo:quantity 'COMPONENT name type lst) 
		       (let ((component->text (make-component->text dis model parse-expr))
			     (component-exports ((dis 'component-exports) model x)))
			 (case type
			   ((toplevel) `(,@(map component->text lst)
					 ,@(map (lambda (x) `(output ,x)) component-exports)))
			   (else `(component ,name (type: ,(->string type) )
						  ,@(filter-map component->text lst)
						  ,@(map (lambda (x) `(output ,x)) component-exports)
						  )))))
		      
		      (($ nemo:quantity 'FUNCTOR name args type lst) 
		       (let ((component->ncml (make-component->ncml dis model parse-expr)))
			 `(functor ,name (type: ,(->string type) )
				   (parameters: ,(string-intersperse (map ->string args) ","))
				   ,@(filter-map (declaration->ncml parse-expr) lst)
				   )))
		      
		      (else #f)))
	      ))
    ))
    

(define (model->text model parse-expr)
  (match-let ((($ nemo:quantity 'DISPATCH  dis)     
	       (hash-table-ref model (nemo-intern 'dispatch))))
     (let ((sysname     ((dis 'sysname) model))
	   (component->text (make-component->text dis model parse-expr)))
       `(model ,sysname ,@(component->text (nemo-intern 'toplevel)))
       )))
	   

(include "expr-parser.scm")
(include "SXML.scm")
(include "SXML-to-XML.scm")
(include "stx-engine.scm")


(define null-template 
  `(*default* ,(lambda (node bindings root env) 
		 (begin 
		   (warn "Unrecognized input element:" node)
		   '()))))


(define-syntax  sxml:make-null-ss
   (syntax-rules  ()
      ((stx rule ...)
       (list 
	; default handler
	null-template
	; handler for textual nodes
	(list '*text*  (lambda (text) text)) 
	rule ...))))


(define (ensure-xmlns doc)
  (let ((doc1 (sxml:add-attr doc '(xmlns:ncml "ncml"))))
    (sxml:add-attr doc1 '(xmlns ncml))))


;; based on SRV:send-reply by Oleg Kiselyov
(define (print-fragments b)
  (let loop ((fragments b) (result #f))
    (cond
      ((null? fragments) result)
      ((not (car fragments)) (loop (cdr fragments) result))
      ((null? (car fragments)) (loop (cdr fragments) result))
      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
      ((pair? (car fragments))
        (loop (cdr fragments) (loop (car fragments) result)))
      ((procedure? (car fragments))
        ((car fragments))
        (loop (cdr fragments) #t))
      (else
       (display (car fragments))
       (loop (cdr fragments) #t)))))


(define (ncml->declarations ncml:model parse-expr)
  (letrec
       ((label-template 
	(sxml:match 'ncml:label
		    (lambda (node bindings root env) 
		      (let ((id   (sxml:attr node 'id))
			    (v    (or (sxml:attr node 'value)
				      (sxml:text node))))
			(if (not id) (error 'output-template "label declaration requires id attribute"))
			`(label ,($ id) = ,($ v))))))
       
	(input-template 
	(sxml:match 'ncml:input
		    (lambda (node bindings root env) 
		      (let ((id    (or (sxml:attr node 'id) (sxml:attr node 'name)))
			    (from  (sxml:attr node 'from))
			    (as    (sxml:attr node 'as)))
			(if (not id) (error 'input-template "input declaration requires id attribute"))
			(cond ((and from as)  `(input (,($ id) as ,($ as ) from ,($ from) )))
			      (from           `(input (,($ id) from ,($ from))))
			      (as             `(input (,($ id) as ,($ as))))
			      (else           `(input ,($ id))))))))
       
       (output-template 
	(sxml:match 'ncml:output
		    (lambda (node bindings root env) 
		      (let ((id   (or (sxml:attr node 'id)
				      (sxml:attr node 'name))))
			(if (not id) (error 'output-template "output declaration requires id attribute"))
			`(output ,($ id))))))
       
       (const-template 
	(sxml:match 'ncml:const
		    (lambda (node bindings root env) 
		      (let* ((id   (or (sxml:attr node 'id)
				       (sxml:attr node 'name)))
			     (expr ((lambda (x) 
				      (if (not x)  
					  (error 'const-template "const declaration " id " requires expr element")
					  (parse-expr (second x) id)))
				   (or (sxml:kidn* 'ncml:expr node)
				       (let ((vattr (sxml:attr node 'value)))
					 (and vattr (list 'value vattr )))
				       (list 'value (sxml:text node))
				       )
				   )))
			(if (not id) (error 'const-template "const declaration requires id attribute"))
			`(const ,($ id) = ,expr)))))
       
       (reaction-transition-template 
	(sxml:match 'ncml:transition
		    (lambda (node bindings root env) 
		      (let ((src  (sxml:attr node 'src))
			    (dst  (sxml:attr node 'dst))
			    (rate  ((lambda (x) 
				      (if (not x)  
					  (error 'reaction-transition-template 
						 "reaction transition requires rate element")
					  (parse-expr (second x))))
				    (sxml:kidn* 'ncml:rate node))))
			(if (not src) (error 'reaction-transition-template
					     "reaction transition requires src attribute"))
			(if (not dst) (error 'reaction-transition-template
					     "reaction transition requires dst attribute"))
			
			`(-> ,($ src) ,($ dst) ,rate)))))
       
       (asgn-template 
	(sxml:match 'ncml:asgn
		    (lambda (node bindings root env) 
		      (let* ((id  (or (sxml:attr node 'id) (sxml:attr node 'name)))
			     (expr ((lambda (x) 
				      (if (not x)  
					  (error 'asgn-template "algebraic assignment requires expr element")
					  (parse-expr (second x) id)))
				    (or (sxml:kidn* 'ncml:expr node)
					(list 'expr (sxml:text node))
					))
				   ))
			(if (not id) (error 'asgn-template "algebraic assignment requires id attribute"))
			`(,($ id) = ,expr)))))
       
       (rate-template 
	(sxml:match 'ncml:rate
		    (lambda (node bindings root env) 
		      (let* ((id  (or (sxml:attr node 'id) (sxml:attr node 'name)))
			     (rhs ((lambda (x) 
				     (if (not x)  
					 (error 'rate-template "rate equation requires expr element")
					  (parse-expr (second x) id)))
				   (sxml:kidn* 'ncml:expr node)))
			     (initial ((lambda (x) (and x (parse-expr (second x) id)))
				       (sxml:kidn* 'ncml:initial node)))
			     (power ((lambda (x) (and x (parse-expr (second x) id)))
				     (sxml:kidn* 'ncml:power node)))
			     )
			(if (not id) (error 'rate-template "rate equation requires id attribute"))
			`(d (,($ id)) = ,rhs ,(and initial `(initial ,initial) )
			    ,(and power `(power ,power) ))))))

       (transient-template 
	(sxml:match 'ncml:transient
		    (lambda (node bindings root env) 
		      (let* ((id  (or (sxml:attr node 'id) (sxml:attr node 'name)))
			     (rhs ((lambda (x) 
				     (if (not x)  
					 (error 'rate-template "rate equation requires expr element")
					  (parse-expr (second x) id)))
				   (sxml:kidn* 'ncml:expr node)))
			     (initial ((lambda (x) (and x (parse-expr (second x) id)))
				       (sxml:kidn* 'ncml:initial node)))
			     (onevent ((lambda (x) (and x (parse-expr (second x) id)))
				       (sxml:kidn* 'ncml:onevent node)))
			     (power ((lambda (x) (and x (parse-expr (second x) id)))
				     (sxml:kidn* 'ncml:power node)))
			     )
			(if (not id) (error 'transient-template "transient equation requires id attribute"))
			`(transient (,($ id)) = ,rhs (onevent ,onevent) ,(and initial `(initial ,initial) )
                                    ,(and power `(power ,power) ))))))


       (conseq-template 
	(sxml:match 'ncml:conseq
		    (lambda (node bindings root env) 
		      (let ((val   (string->number (->string (sxml:attr node 'val))))
			    (rhs   ((lambda (x) 
					(if (not x)  
					    (error 'conseq-template 
						   "conseq definition requires expr element")
					    (parse-expr (second x))))
				      (sxml:kidn* 'ncml:expr node))))
			`(,val = ,rhs)))))
       
       (reaction-template 
	(sxml:match 'ncml:reaction
		    (lambda (node bindings root env) 
		      (let* ((id      ($ (or (sxml:attr node 'id) (sxml:attr node 'name))))
			    (initial ((lambda (x) (and x (parse-expr (second x) id)))
				      (sxml:kidn* 'ncml:initial node)))

			    (open    ((lambda (x) 
					(if (not x)  
					    (error 'reaction-template
						   "reaction declaration requires open element")
					    (let ((os (string-split (second x) ",")))
					      (map $ os))))
				      (sxml:kidn* 'ncml:open node)))

			    (conserve ((lambda (x) 
					 (and x (let ((tmpl (sxml:make-null-ss conseq-template)))
						  (stx:apply-templates (cdr x) tmpl root env))))
				       (sxml:kidn* 'ncml:conserve node)))

			    (power ((lambda (x) 
				      (if (not x)  
					  (error 'reaction-template
						 "reaction declaration requires open element")
					  (parse-expr (second x) id)))
				    (sxml:kidn* 'ncml:power node)))

			    (transitions ((lambda (x) 
					    (if (not x)  
						(error 'reaction-template
						       "reaction declaration requires transitions element")
						(let ((tmpl (sxml:make-null-ss reaction-transition-template)))
						  (stx:apply-templates (cdr x) tmpl root env))))
					  (sxml:kidn* 'ncml:transitions node)))

			    )
					  
			(if (not id) (error 'reaction-template "reaction declaration requires id attribute"))
			`(reaction (,id (initial ,initial) (open ,open) (power ,power) 
					,(and conserve `(conserve ,conserve) )
					(transitions ,@transitions)))))))


       (defun-template 
	(sxml:match 'ncml:defun
		    (lambda (node bindings root env) 

		      (let* ((id    (or (sxml:attr node 'id) (sxml:attr node 'name)))
			     (args  ((lambda (x) 
				       (if (null? x)  
					   (error 'defun-template 
						  "function definition requires at least one arg element")
					   (map (compose $ second) x)))
				     (sxml:kidsn 'ncml:arg node)))
			     (body ((lambda (x) 
				      (if (not x)  
					  (error 'defun-template
						 "function definition requires body element")
					  (parse-expr (second x) id)))
				    (sxml:kidn* 'ncml:body node))))
			(if (not id) (error 'defun-template "function definition requires id attribute"))

			`(defun ,($ id) ,args ,body)))))

       (component-template
	(sxml:match 'ncml:component
		    (lambda (node bindings root env)

		      (let ((name (sxml:attr node 'name))
			    (functor-name (or (sxml:attr node 'functor-name)
					      (sxml:attr node 'functor)))
			    (type (sxml:attr node 'type)))

			(if (and (not functor-name) (not type) )
			    (error 'component-template "component definition requires type attribute" name))
			(if (and functor-name (not name) )
			    (error 'component-template "component definition requires name attribute"))
			(if functor-name
			    `(component (name ,($ name)) = ,($ functor-name) 
					,(ncml->declarations (sxml:kids node) parse-expr))
			    (if name
				`(component (type ,($ type)) (name ,($ name)) 
					    ,@(ncml->declarations (sxml:kids node) parse-expr))
				`(component (type ,($ type)) 
					    ,@(ncml->declarations (sxml:kids node) parse-expr))
				))
			))
		    ))

       (functor-template
	(sxml:match 'ncml:functor
		    (lambda (node bindings root env)

		      (let ((parameters (sxml:attr node 'parameters))
			    (name (sxml:attr node 'name))
			    (type (sxml:attr node 'type)))
			(if (not type) (error 'functor-template "functor definition requires type attribute"))
			(if (not name) (error 'functor-template "functor definition requires name attribute"))
			(if (not parameters) 
			    (error 'functor-template "functor definition requires parameters attribute"))
			`(functor (name ,($ name)) (type ,($ type)) 
				  ,(map $ (string-split parameters ","))
				  = . ,(ncml->declarations (sxml:kids node) parse-expr))))))

       (hh-template 
	(sxml:match 'ncml:hh_ionic_gate 
		    (lambda (node bindings root env)
		      (let* (
			     (id         (or (sxml:attr node 'id) (sxml:attr node 'name)))
			     (and-expr   (lambda (x) (and x (parse-expr (second x) id))))
			     (initial_m  (and-expr (sxml:kidn* 'ncml:initial_m node)))
			     (initial_h  (and-expr (sxml:kidn* 'ncml:initial_h node)))
			     (m_power    (and-expr (sxml:kidn* 'ncml:m_power node)))
			     (h_power    (and-expr (sxml:kidn* 'ncml:h_power node)))
			     (m_alpha    (and-expr (sxml:kidn* 'ncml:m_alpha node)))
			     (m_beta     (and-expr (sxml:kidn* 'ncml:m_beta node)))
			     (h_alpha    (and-expr (sxml:kidn* 'ncml:h_alpha node)))
			     (h_beta     (and-expr (sxml:kidn* 'ncml:h_beta node)))
			     (m_tau      (and-expr (sxml:kidn* 'ncml:m_tau node)))
			     (m_inf      (and-expr (sxml:kidn* 'ncml:m_inf node)))
			     (h_tau      (and-expr (sxml:kidn* 'ncml:h_tau node)))
			     (h_inf      (and-expr (sxml:kidn* 'ncml:h_inf node)))
			     )

			(if (not id)
			    (error 'hh-template "hh ionic conductance definition requires id attribute"))
			`(hh-ionic-gate 
			  (,($ id)
			   ,@(if initial_m `((initial-m ,initial_m)) `())
			   ,@(if initial_h `((initial-h ,initial_h)) `())
			   ,@(if m_power `((m-power ,m_power)) '())
			   ,@(if h_power `((h-power ,h_power)) '())
			   ,@(if m_alpha `((m-alpha ,m_alpha)) '())
			   ,@(if h_alpha `((h-alpha ,h_alpha)) '())
			   ,@(if m_beta  `((m-beta ,m_beta)) '())
			   ,@(if h_beta  `((h-beta ,h_beta)) '())
			   ,@(if m_inf   `((m-inf ,m_inf)) '())
			   ,@(if h_inf   `((h-inf ,h_inf)) '())
			   ,@(if m_tau   `((m-tau ,m_tau)) '())
			   ,@(if h_tau   `((h-tau ,h_tau)) '())
			   ))))))

       (decaying-pool-template 
	(sxml:match 'ncml:decaying_pool 
		    (lambda (node bindings root env)
		      (let* ((id         (sxml:attr node 'id))
			     (and-expr   (lambda (x) (and x (parse-expr (second x) id))))
			     (initial    (and-expr (sxml:kidn* 'ncml:initial node)))
			     (beta       (and-expr (sxml:kidn* 'ncml:beta node)))
			     (depth      (and-expr (sxml:kidn* 'ncml:depth node)))
			     (temp-adj   (and-expr (sxml:kidn* 'ncml:temp_adj node))))
			(if (not id)
			    (error 'decaying-pool-template "decaying pool definition requires id attribute"))
			(if (not initial) 
			    (error 'decaying-pool-template "decaying pool definition requires initial value"))
			(if (not beta) 
			    (error 'decaying-pool-template "decaying pool definition requires beta parameter"))
			(if (not depth) 
			    (error 'decaying-pool-template "decaying pool definition requires depth parameter"))
			    
			`(decaying-pool 
			  (,($ id)
			   ,@(if temp_adj `((temp_adj ,temp_adj)) `())
			   (beta ,beta)
			   (depth ,depth)
			   (initial ,initial)))))))
	)

     (stx:apply-templates ncml:model 
			  (sxml:make-null-ss label-template
					     input-template
					     output-template
					     const-template
					     asgn-template
					     rate-template
					     reaction-template
					     transient-template
					     defun-template
					     component-template
					     functor-template
					     hh-template
					     decaying-pool-template) 
			  ncml:model (list))))


(define sxslt-preamble
  `(
    (import scheme chicken)
    (require-extension sxml-transforms sxpath sxpath-lolevel) 
    (define-syntax  sxml:match
      (syntax-rules  ()
	((match pattern handler)
	 (list (if (symbol? pattern) pattern (sxpath pattern))
	       handler))
	))
    (define identity-template 
      `(*default* ,(lambda (node bindings root env) 
		     (begin 
		       node))))
    (define-syntax sxml:make-ss
      (syntax-rules  ()
	((stx rule ...)
	 (list 
	  identity-template
	  (list '*text*  (lambda (text) text)) 
	  rule ...))
	))
    (define (sxml:kid node)
      (let ((v ((select-first-kid
		 (lambda (x) (not (eq? (car x) '@)))) node)))
	(if (not v)
	    (error 'sxml:kid "node does not have children" node)  v)))
    (define (sxml:kids node)
      ((select-kids (lambda (x) (not (eq? (car x) '@)))) node))
    (define (sxml:kidsn name node)
      ((select-kids (lambda (x) (eq? (car x) name))) node))
    (define (sxml:kidn name node)
      ((select-first-kid (lambda (x)  (eq? (car x) name))) node))  
    ))


(define (ncml->model-decls options doc)
  (let* ((parse-expr    (or (lookup-def 'parse-expr options) identity))
	 (ncml:model    ((lambda (x) 
			   (if (null? x) (error 'ncml->model "ncml:model element not found in input document") (car x)))
			 (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
	 (model-name     ($ (or (sxml:attr ncml:model 'name) (gensym 'model))))
	 (membraneprops  (ncml:sxpath '(// cell biophysicalProperties membraneProperties) 
				      `(*TOP* . ,ncml:model)))
	 (ncml-ss        (ncml:sxpath '(// ncml:sxslt) `(*TOP* . ,ncml:model)))
	 (ncml-templates (ncml:sxpath '(// ncml:template) `(*TOP* . ,ncml:model)))
	 (ncml-decls     ((lambda (doc) 
			    (if (null? ncml-ss) doc
				(let ((ss (map 
					   (lambda (x)
                                             (call-with-input-string (sxml:text x)
                                               (lambda (in) (eval `(begin
                                                                     ,@sxslt-preamble
                                                                     (sxml:make-ss ,@(read in))
                                                                     ))
                                                       )))
					   ncml-ss)))
				  (fold (lambda (s doc) (stx:apply-templates doc s doc (list))) doc ss))
				))
			  (if (null? membraneprops) 
			      (sxml:kids ncml:model) 
			      (sxml:kids membraneprops))))
	 (dd  (if (lookup-def 'debug options)
		  (begin (pp ncml-decls))))
	 (model-decls    (ncml->declarations ncml-decls parse-expr))
	 (user-templates (map (lambda (t)
				 (let ((name (or (sxml:attr t 'name) (->string (gensym 'template))))
				       (args (or (let ((xs (sxml:attr t 'args)))
						   (or (and xs (string-split xs ",")) '())))))
				   (list name args (ersatz:statements-from-string 
						    (ersatz:template-std-env)
						    (sxml:text t)))
				   ))
			       ncml-templates))
	 )
    (list model-name model-decls user-templates)))


(define (ncml-model-decls->model options model-name model-decls)

    (if (or (null? model-decls)  (and (pair? model-decls) (every null? model-decls)))
	(error 'ncml-model-decls->model "ncml declaration elements not found in input document"))

    (let* ((model+nemo  (nemo-constructor model-name model-decls (lambda (x . rest) (identity x))))
	   (model       (first model+nemo))
	   (nemo        (second model+nemo)))

      (let ((model-1 (nemo:hh-transformer model (alist-ref 'hh-markov options) (lambda (x . rest) (identity x)))))

	(if (assoc 'depgraph options) (print "dependency graph: " ((nemo 'depgraph*) model-1)))
	(if (assoc 'exports options) (print "exports: " ((nemo 'exports) model-1)))	
	(if (assoc 'imports options) (print "imports: " ((nemo 'imports) model-1)))
	(if (assoc 'components options)
	    (for-each (lambda (x) 
			(print "component " x ": " ((nemo 'component-exports) model-1 (second x)))
			(print "component " x " subcomponents: " ((nemo 'component-subcomps) model-1 (second x))))
		      ((nemo 'components) model-1)))
	model-1)))


(define (entry->surface-xml x . rest)
  (let-optionals rest ((ns-prefix "ncml"))

    (let ((ns-prefix (if (or (not ns-prefix) (string-null? ns-prefix)) ""
			 (string-append ns-prefix ":")))
	  (xmlstr (lambda (x) (let recur ((x x)) 
				(if (pair? x) (map recur x) 
				    (let ((v (string->goodHTML (->string x))))
				      (if (pair? v) (string-concatenate v) v)))
				))
		  ))

      (let ((transition-str
	     (lambda (t)
	       (match t
		      (('-> src dst rate) 
		       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
				ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix))

		      ((src '-> dst rate) 
		       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
				ns-prefix src dst ns-prefix (xmlstr rate) ns-prefix ns-prefix))

		      (('<-> src dst rate1 rate2) 
		       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
				ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix
				ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix
				))

		      ((src '<-> dst rate1 rate2) 
		       (sprintf "<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%<~Atransition src=\"~A\" dst=\"~A\">~%<~Arate>~A </~Arate>~% </~Atransition>~%"
				ns-prefix src dst ns-prefix (xmlstr rate1) ns-prefix ns-prefix
				ns-prefix dst src ns-prefix (xmlstr rate2) ns-prefix ns-prefix
				))

		      (else (error 'transition-str "invalid transition " x))))
	       )
	       
	    (ionic-gate-str
	     (lambda (ion #!key 
			  (initial-m-expr #f)
			  (initial-h-expr #f)
			  (m-power #f)
			  (h-power #f)
			  (m-inf-expr #f)
			  (m-tau-expr #f)
			  (h-inf-expr #f)
			  (h-tau-expr #f)
			  (m-alpha-expr #f)
			  (m-beta-expr #f)
			  (h-alpha-expr #f)
			  (h-beta-expr #f))

	       (let ((initial-m-str (or (and initial-m-expr
						  (sprintf "<~Ainitial_m>~A</~Ainitial_m>~%" 
							   ns-prefix (xmlstr initial-m-expr) ns-prefix)) ""))
		     (initial-h-str (or (and initial-h-expr
						  (sprintf "<~Ainitial_h>~A</~Ainitial_h>~%" 
							   ns-prefix (xmlstr initial-h-expr) ns-prefix)) ""))

		     (m-power-str  (or (and m-power
						  (sprintf "<~Am_power>~A</~Am_power>~%" 
							   ns-prefix m-power ns-prefix)) ""))
		     (h-power-str  (or (and h-power
						  (sprintf "<~Ah_power>~A</~Ah_power>~%" 
							   ns-prefix h-power ns-prefix)) ""))

		     (m-inf-str (or (and m-inf-expr
					 (sprintf "<~Am_inf>~A</~Am_inf>~%" 
						  ns-prefix (xmlstr m-inf-expr) ns-prefix)) ""))
		     (m-tau-str (or (and m-tau-expr
					 (sprintf "<~Am_tau>~A</~Am_tau>~%" 
						  ns-prefix (xmlstr m-tau-expr) ns-prefix)) ""))

		     (h-inf-str (or (and h-inf-expr
					 (sprintf "<~Ah_inf>~A</~Ah_inf>~%" 
						  ns-prefix (xmlstr h-inf-expr) ns-prefix)) ""))
		     (h-tau-str (or (and h-tau-expr
					 (sprintf "<~Ah_tau>~A</~Ah_tau>~%" 
						  ns-prefix (xmlstr h-tau-expr) ns-prefix)) ""))

		     (m-alpha-str (or (and m-alpha-expr
					   (sprintf "<~Am_alpha>~A</~Am_alpha>~%" 
						    ns-prefix (xmlstr m-alpha-expr) ns-prefix)) ""))
		     (m-beta-str (or (and m-beta-expr
					  (sprintf "<~Am_beta>~A</~Am_beta>~%" 
						   ns-prefix (xmlstr m-beta-expr) ns-prefix)) ""))

		     (h-alpha-str (or (and h-alpha-expr
					   (sprintf "<~Ah_alpha>~A</~Ah_alpha>~%" 
						    ns-prefix (xmlstr h-alpha-expr) ns-prefix)) ""))
		     (h-beta-str (or (and h-beta-expr
					  (sprintf "<~Ah_beta>~A</~Ah_beta>~%" 
						   ns-prefix (xmlstr h-beta-expr) ns-prefix)) ""))
		     )
		 
		 (sprintf "<~Ahh_ionic_gate name=\"~A\">~A</~Ahh_ionic_gate>~%"
			  ns-prefix ion   
			  (string-append initial-m-str initial-h-str
					 m-power-str h-power-str m-inf-str 
					 m-tau-str h-inf-str h-tau-str
					 m-alpha-str m-beta-str h-alpha-str h-beta-str
					 )
			  ns-prefix))
	       )))

    (match x
	 (('nemo-model name decls)
	  (map entry->surface-xml decls))

	 (('output . names)
	  (string-concatenate (map (lambda (name) (sprintf "<~Aoutput name=\"~A\"/>~%" ns-prefix name)) names)))

	 (('input . names)
	  (string-concatenate (map (lambda (name) 
				     (match name
					    ((and name (? symbol?)) 
					     (sprintf "<~Ainput name=\"~A\"/>~%" ns-prefix name))

					    ((name 'from ns)
					     (sprintf "<~Ainput name=\"~A\" from=\"~A\"/>~%" ns-prefix name ns))
					    
					    ))
				   names)))

	 (('const name '= value)
	  (if (number? value)
	      (sprintf "<~Aconst name=\"~A\" value=\"~A\"/>~%"
		      ns-prefix name value)
	      (sprintf "<~Aconst name=\"~A\">~%~A~%</~Aconst>~%"
		       ns-prefix name (xmlstr value) ns-prefix)
	      ))

	 (((or 'defun 'fun) name args body)
	  (sprintf "<~Adefun name=\"~A\">~%~A~%<~Abody>~A</~Abody>~%</~Adefun>~%"
		   ns-prefix
		   name (string-concatenate (map (lambda (x) (sprintf "<~Aarg>~A</~Aarg>" ns-prefix x ns-prefix)) args)) 
		   ns-prefix (xmlstr body) ns-prefix ns-prefix))
	 
	 ((name '= expr)
	  (sprintf "<~Aasgn name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Aasgn>~%"
		  ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix))
	 
	 (('d ( name ) '= expr)
	  (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%</~Arate>~%"
		  ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix))
	 
	 (('d ( name ) '= expr ('initial initial-expr))
	  (sprintf "<~Arate name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Ainitial>~A</~Ainitial>~%</~Arate>~%"
		   ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix))

	 (((or 't 'T 'transient) ( name ) '= expr ('onevent event-expr) ('initial initial-expr))
	  (sprintf "<~Atransient name=\"~A\"><~Aexpr>~A</~Aexpr>~%<~Aonevent>~A</~Aonevent>~%<~Ainitial>~A</~Ainitial>~%</~Atransient>~%"
		   ns-prefix name ns-prefix (xmlstr expr) ns-prefix ns-prefix (xmlstr event-expr) ns-prefix ns-prefix (xmlstr initial-expr) ns-prefix ns-prefix))

	 (('reaction ( name ('transitions . transitions) ('conserve conserve) ('initial . initial-expr) ('open . open) ('power power)))
	  (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%<~Ainitial>~A</~Ainitial>~%</~Areaction>~%"
		   ns-prefix name 
		   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
		   ns-prefix (xmlstr power) ns-prefix
		   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
                   ns-prefix (xmlstr initial-expr) ns-prefix
		   ns-prefix))

	 (('reaction ( name ('transitions . transitions) ('conserve conserve) ('open . open) ('power power)))
	  (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%"
		   ns-prefix name 
		   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
		   ns-prefix (xmlstr power) ns-prefix
		   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
		   ns-prefix))

	 (('reaction ( name ('transitions . transitions) ('open . open) ('power power)))
	  (sprintf "<~Areaction name=\"~A\"><~Aopen>~A</~Aopen>~%<~Apower>~A</~Apower>~%<~Atransitions>~A</~Atransitions>~%</~Areaction>~%"
		   ns-prefix name 
		   ns-prefix (string-concatenate (intersperse (map ->string open) ",")) ns-prefix 
		   ns-prefix (xmlstr power) ns-prefix
		   ns-prefix (string-concatenate (map transition-str transitions)) ns-prefix
		   ns-prefix))

	 
	 (('hh-ionic-gate 
	   (ion
	    ('initial-m  initial-m-expr)
	    ('initial-h  initial-h-expr)
	    ('m-power    m-power)
	    ('h-power    h-power)
	    ('m-inf      m-inf-expr)
	    ('m-tau      m-tau-expr)
	    ('h-inf      h-inf-expr)
	    ('h-tau      h-tau-expr)
	    ))

	  (ionic-gate-str ion 
			  initial-m-expr: initial-m-expr
			  initial-h-expr: initial-h-expr
			  m-power: m-power
			  h-power: h-power
			  m-inf-expr: m-inf-expr
			  m-tau-expr: m-tau-expr
			  h-inf-expr: h-inf-expr
			  h-tau-expr: h-tau-expr))

	 
	 (('hh-ionic-gate 
	   (ion
	    ('initial-m  initial-m-expr)
	    ('m-power    m-power)
	    ('h-power    h-power)
	    ('m-inf      m-inf-expr)
	    ('m-tau      m-tau-expr)
	    ))

	  (ionic-gate-str ion 
			  initial-m-expr: initial-m-expr
			  m-power: m-power
			  h-power: h-power
			  m-inf-expr: m-inf-expr
			  m-tau-expr: m-tau-expr))
	 
	 (('hh-ionic-gate 
	   (ion
	    ('initial-m  initial-m-expr)
	    ('m-power    m-power)
	    ('h-power    h-power)
	    ('m-tau      m-tau-expr)
	    ('m-inf      m-inf-expr)
	    ))

	  (ionic-gate-str ion 
			  initial-m-expr: initial-m-expr
			  m-power: m-power
			  h-power: h-power
			  m-inf-expr: m-inf-expr
			  m-tau-expr: m-tau-expr))
	 
	 (('hh-ionic-gate 
	   (ion
	    ('initial-m  initial-m-expr)
	    ('initial-h  initial-h-expr)
	    ('m-power    m-power)
	    ('h-power    h-power)
	    ('m-alpha      m-alpha-expr)
	    ('m-beta       m-beta-expr)
	    ('h-alpha      h-alpha-expr)
	    ('h-beta       h-beta-expr)
	    ))

	  (ionic-gate-str ion 
			  initial-m-expr: initial-m-expr
			  initial-h-expr: initial-h-expr
			  m-power: m-power
			  h-power: h-power
			  m-alpha-expr: m-alpha-expr
			  m-beta-expr: m-beta-expr
			  h-alpha-expr: h-alpha-expr
			  h-beta-expr: h-beta-expr))
	 
	 (('hh-ionic-gate 
	   (ion
	    ('initial-m  initial-m-expr)
	    ('m-power    m-power)
	    ('h-power    h-power)
	    ('m-alpha      m-alpha-expr)
	    ('m-beta       m-beta-expr)
	    ))

	  (ionic-gate-str ion 
			  initial-m-expr: initial-m-expr
			  m-power: m-power
			  h-power: h-power
			  m-alpha-expr: m-alpha-expr
			  m-beta-expr: m-beta-expr))

	 
	 (('component ('type ty) ('name name) . rest) 
	  (sprintf "<~Acomponent type=\"~A\" name=\"~A\">~%~A</~Acomponent>~%" 
		  ns-prefix ty name (string-concatenate (map entry->surface-xml rest)) ns-prefix ))

	 (('component ('type ty) . rest) 
	  (sprintf "<~Acomponent type=\"~A\">~%~A</~Acomponent>~%" 
		   ns-prefix ty (string-concatenate (map entry->surface-xml rest)) ns-prefix ))


	 (else (error 'nemo "unknown declaration" x))

	 )))
))


(define (partition-model opt decls)
  (let recur ((bkts '()) (toplevel '()) (decls decls))
    (if (null? decls)
	(list bkts (reverse toplevel))
	(let ((decl (car decls)))
	  (if (opt 'debug)
	      (begin (print "partition-model: decl = ")
		     (pp decl)))
	  (match decl (((or 'component 'COMPONENT)
			((or 'type 'TYPE) typ) 
			((or 'name 'NAME) name) . lst)
		       (let ((bkt (alist-ref name bkts)))
			 (if bkt (recur (alist-update name (cons decl bkt) bkts)
					toplevel (cdr decls))
			     (recur (alist-update name (list decl) bkts)
				    toplevel (cdr decls)))))
		 (else (recur bkts (cons decl toplevel) (cdr decls)))))
	)))


(define (process-model opt source-path in-format prefix sys model-decls iexpr? parse-expr)
		
  (match-let ((($ nemo:quantity 'DISPATCH  dis) 
	       (hash-table-ref sys (nemo-intern 'dispatch))))
				    
     (let* (
	    (sysname             ((lambda (x) (or (and prefix ($ (s+ prefix "_" x))) x)) ((dis 'sysname) sys)))
	    (dirname             (pathname-directory source-path))
	    (plain-fname         (make-output-fname dirname sysname ".txt"  (opt 'plain) ))
	    (sxml-fname          (make-output-fname dirname sysname  ".sxml" (opt 'sxml) ))
	    (surface-xml-fname   (make-output-fname dirname sysname ".xml"  (opt 'surface-xml) ))
	    (xml-fname           (make-output-fname dirname sysname ".xml"  (opt 'xml) ))
	    (pyparams-fname      (make-output-fname dirname sysname ".py"  (opt 'pyparams) ))
	    (mod-fname           (make-output-fname dirname sysname ".mod"  (opt 'nmodl)))
	    (vclamp-ses-fname    (make-output-fname dirname sysname "_vclamp.hoc" (opt 'vclamp-hoc) ))
	    (vclamp-octave-fname (make-output-fname dirname sysname "_vclamp.m" (opt 'vclamp-octave) ))
	    (iclamp-ses-fname    (make-output-fname dirname sysname "_iclamp.hoc" (opt 'iclamp-hoc) ))
	    (iclamp-sli-fname    (make-output-fname dirname sysname "_iclamp.sli" (opt 'iclamp-nest) ))
		  
	    (pyparams       (opt 'pyparams))
	    (nest           (and nemo-nest? (opt 'nest)))
	    (matlab         (opt 'matlab))
	    (octave         (opt 'octave))
	    (vclamp-hoc     (opt 'vclamp-hoc))
	    (vclamp-octave  (opt 'vclamp-octave))
	    (iclamp-hoc     (opt 'iclamp-hoc))
	    (iclamp-nest    (opt 'iclamp-nest))
		  
	    (nmodl-method
	     (let ((method  (or ($ (opt 'nmodl-method) ) (defopt 'nmodl-method))))
	       (case method
		 ((adams runge euler adeuler heun adrunge gear
			 newton simplex simeq seidel sparse derivimplicit cnexp clsoda
			 after_cvode cvode_t cvode_t_v expeuler #f) method)
		 (else (error "unknown NMODL method " method)))))
		   
	    (octave-method
	     (let ((method  ($ (opt 'octave-method) )))
	       (case method
		 ((cvode lsode odepkg ode2r ode5r odesx oders) method)
		 ((#f) 'lsode)
		 (else (error "unknown Octave method " method)))))
				   
	    (nest-method
	     (and nemo-nest?
		  (let ((method  ($ (opt 'nest-method) )))
		    (case method
		      ((cvode gsl leapfrog #f) method)
		      (else (error "unknown NEST method " method))))))
				   
	    (parse-expr  (case in-format
			   ((sxml xml)    identity)
			   ((sexp)        identity)
			   ((ixml)        (lambda (x #!optional loc) 
					    (let ((xs (if (string? x) x
							  (string-concatenate
							   (map (lambda (el)
								  (if (string? el) el
								      (if (equal? el '(divide)) " / "
									  (->string el))))
								x)))))
					      (nemo:parse-string-expr xs loc))))
			   ((nemo)        (if iexpr? 
					      (lambda (x #!optional loc) 
						(if (string? x) (nemo:parse-string-expr x loc)
						    (nemo:parse-sym-expr x loc)))
					      nemo:parse-sym-expr))
			   (else    (error 'nemo "unknown input format" in-format))))
	    
	    )
       
       (if (and xml-fname surface-xml-fname)
	   (error 'nemo "both --xml and --surface-xml options are not permitted"))
       
       (if plain-fname
	   (with-output-to-file plain-fname 
	     (lambda () (pretty-print (model->text sys parse-expr)))))
       
       (if sxml-fname
	   (with-output-to-file sxml-fname 
	     (lambda () (pretty-print (model->ncml sys parse-expr)))))
       
       (if xml-fname
	   (let* ((doc  (model->ncml sys parse-expr))
		  (doc1 (ensure-xmlns
			 (cond ((eq? (car doc) '*TOP*) (assoc 'ncml:model (cdr doc)))
			       (else doc)))))
	     (with-output-to-file xml-fname 
	       (lambda () (print-fragments (generate-XML `(begin ,doc1)))))))
       
       
       (if surface-xml-fname   
	   (with-output-to-file surface-xml-fname 
	     (lambda () (print-fragments (map entry->surface-xml model-decls)))))
       
       (if mod-fname
	   (with-output-to-file 
	       mod-fname  (lambda () 
			    (model->nmodl `((method  . ,nmodl-method)
					    (kinetic . ,(opt 'nmodl-kinetic)))
					  sys))))
       
       (if octave (model->octave `((filename  . ,(or (and (string? octave) (pathname-file octave)) octave))
				   (dirname   . ,(or (and (string? octave) (pathname-directory octave)) dirname))
                                   )
				 sys))
       
       (if matlab (model->matlab `((dirname . ,(or (and (string? matlab) matlab) dirname))) sys))

       (if pyparams
	   (model->pyparams `((filename . ,pyparams-fname)
                              (mode . ,(if (opt 'partition) 'single 'multiple)))
                            sys))

       
       (if (and nemo-nest? nest)
	   (model->nest `((dirname . ,(or (and (string? nest) nest) dirname))
			  (method    . ,nest-method))
			sys))
       
       (if vclamp-hoc (model->vclamp-hoc `((filename . ,vclamp-ses-fname)
                                           
					   )
					 sys))
       
       (if vclamp-octave (model->vclamp-octave `((filename . ,vclamp-octave-fname)
                                                 (octave-method . ,(case octave-method
                                                                     ((odepkg) 'ode2r)
                                                                     (else octave-method)))
						 )
					       sys))

       (if iclamp-hoc (model->iclamp-hoc `((filename . ,iclamp-ses-fname)
					   )
					 sys))

       (if iclamp-nest (model->iclamp-nest `((filename . ,iclamp-sli-fname)
					     )
					   sys))
       ))
  )


(define (instantiate-template user-templates template-name template-vars)
  (let ((tmpl (assoc (->string template-name) user-templates string=?)))
    (if (not tmpl)
	(error 'nemo "template not found" template-name))
    (let ((ctx (ersatz:init-context models: template-vars )))
      (display
       (ersatz:eval-statements (caddr tmpl)
			       env: (ersatz:template-std-env)
			       models: template-vars ctx: ctx))
      )))


(define (process-template model-name template-name template-args template-out user-templates source-path)

  (let (
	(template-vars (cons (cons 'model_name
				   (ersatz:Tstr (->string model-name)) )
			     (map (lambda (x) 
				    (let ((kv (string-split x "=")))
				      (cons ($ (car kv))
					    (ersatz:Tstr (cadr kv)))))
				  template-args)))
	)

    (let* ((dirname (pathname-directory source-path))
	   (output-name (if (string-prefix? "." template-out)
			    (make-pathname dirname (s+ model-name template-out)) 
			    (make-pathname dirname (s+ model-name "_" template-out)) )))
      (with-output-to-file output-name
	(lambda () (instantiate-template user-templates template-name template-vars))
	))
    ))



(define (detect-xml-type doc)
  (let* (
	 (ncml:model    ((lambda (x) 
			   (if (null? x) (error 'detect-xml-type "ncml:model element not found in input document") (car x)))
			 (ncml:sxpath '(// ncml:model) `(*TOP* . ,doc))))
	 (membraneprops  (ncml:sxpath '(// cell biophysicalProperties membraneProperties) 
				      `(*TOP* . ,ncml:model)))
	 )
    (cond (membraneprops 'ixml)
	  (else 'xml))
    ))


(define (model-source->model source-path in-format model-name model-decls user-templates iexpr parse-expr)

  (case in-format
    ((sxml xml ixml)
     (SingleModel source-path in-format model-name
                  (ncml-model-decls->model
                   `((hh-markov . ,(opt 'hh-markov))
                     (parse-expr . ,parse-expr)) 
                   model-name model-decls)
                  model-decls user-templates iexpr parse-expr))
    
    ((sexp nemo)
     (SingleModel source-path in-format model-name
                  (sexp-model-decls->model 
                   `((hh-markov . ,(opt 'hh-markov)))
                   model-name model-decls parse-expr)
                  model-decls user-templates iexpr parse-expr))
    
    (else (error 'nemo "invalid input format"))
    ))


(define (model-source->model-parts opt source-path in-format 
                                   model-name model-decls 
                                   user-templates iexpr parse-expr)
  (let ((pmodels (partition-model opt model-decls)))
    (if (opt 'debug)
        (begin (print "length pmodels = " (length pmodels))
               (print "pmodels = " )
               (pp pmodels)))
    (let ((model-parts
           (match-let (((bkts toplevel) pmodels))
                      (map (lambda (bkt)
                             (let ((part-decls (append toplevel (cdr bkt)))
                                   (part-name (car bkt)))
                               
                               (case in-format
                                 ((sxml xml ixml)
                                  (ModelPart source-path in-format model-name part-name
                                             (ncml-model-decls->model
                                              `((hh-markov . ,(opt 'hh-markov))
                                                (parse-expr . ,parse-expr)) 
                                              ($ (s+ model-name "_" (car bkt))) part-decls)
                                             part-decls model-decls user-templates iexpr parse-expr)
                                  )
                                 
                                 ((sexp nemo)
                                  (ModelPart source-path in-format model-name part-name
                                             (sexp-model-decls->model
                                              `((hh-markov . ,(opt 'hh-markov)))
                                              ($ (s+ model-name "_" (car bkt))) part-decls parse-expr)
                                             part-decls model-decls user-templates iexpr parse-expr)
                                  )
                                 
                                 (else (error 'nemo "invalid input format" in-format))
                                 )))
                           bkts))
           ))
      model-parts
      )))


  
(define (main opt operands)

  (if (opt 'version)
      (begin
	(print (nemo:version-string))
	(exit 0)))

  (if (null? operands)

      (nemo:usage)

      (let* (
	    (model-sources
	     (map (lambda (operand)
		    (let* ((read-xml   (lambda (name) (call-with-input-file name
							(lambda (port) (ssax:xml->sxml port '((ncml . "ncml")))) )))
			   (read-sexp  (lambda (name) (call-with-input-file name read)))
			   (read-iexpr (lambda (name) (call-with-input-file name 
							(lambda (port) 
							  (let ((content
								 (iexpr:tree->list
								  (iexpr:parse operand port))))
							    (car content))))))
			   
			   (in-format  (cond ((opt 'input-format) => 
					      (lambda (x) 
						(case ($ x)
						  ((nemo)        'nemo)
						  ((s-exp sexp)  'sexp)
						  ((xml)         'xml)
						  ((ixml)        'ixml)
						  ((sxml)        'sxml)
						  (else          (error 'nemo "unknown input format" x)))))
					     (else  (case ((lambda (x) (or (not x) ($ x)))
							   (pathname-extension operand))
						      ((s-exp sexp)  'sexp)
						      ((sxml)  'sxml)
						      ((xml)   (detect-xml-type (read-xml operand)))
						      (else    'nemo)))))

			   (doc.iexpr   (case in-format
					 ((nemo)  
					  (let ((content (read-sexp operand)))
					    (if (eq? content 'nemo-model)
						(cons (read-iexpr operand) #t)
						(cons content #f))))
					 ((sxml sexp)  
					  (cons (read-sexp operand) #f))
					 ((xml ixml)
					  (cons (read-xml operand) #f))
					 (else    (error 'nemo "unknown input format" in-format))))

			   (dd          (if (opt 'debug)
					    (pp (car doc.iexpr))))
			   
			   (parse-expr  (case in-format
					  ((sxml sexp)         identity)
					  ((nemo)              (if (cdr doc.iexpr) 
								   (lambda (x #!optional loc) 
								     (if (string? x) (nemo:parse-string-expr x loc)
									 (nemo:parse-sym-expr x loc)))
								   nemo:parse-sym-expr))
					  ((xml)               (lambda (x #!optional loc) 
								 (ncml-expr->expr x)))
					  ((ixml)              (lambda (x #!optional loc) 
								 (nemo:parse-string-expr x loc)))
					  (else    (error 'nemo "unknown input format" in-format))))  
			   
			   (model-name.model-decls
			    (case in-format
			      ((sxml xml ixml)     (ncml->model-decls 
						    `((parse-expr . ,parse-expr)
						      (debug . ,(opt 'debug) ))
						    (car doc.iexpr)))
			      ((sexp nemo)         (sexp->model-decls (car doc.iexpr)))
			      (else    (error 'nemo "unknown input format" in-format))))

			   )

		       (ModelSource  operand in-format
				     (car model-name.model-decls)
				     (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
				     (match model-name.model-decls 
					    ((_ _ user-templates)
					     user-templates)
					    (else '()))
				     (cdr doc.iexpr) 
				     parse-expr)
		      ))
		  operands))

	    (models
	       (if (opt 'partition)

		    (let recur ((srcs model-sources) (ax '()))
		      (if (null? srcs) ax
			  (let ((src (car srcs)))
			    (cases nemo:model src

				   (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
                                                (recur (cdr srcs)
                                                       (append (model-source->model-parts opt source-path in-format 
                                                                                          model-name model-decls 
                                                                                          user-templates iexpr parse-expr) ax)))

                                   (else (error 'nemo "invalid model source" src)))
			    )))
				 
		      (map (lambda (x) 
			     (cases nemo:model x

				    (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
                                                 (model-source->model source-path in-format model-name 
                                                                      model-decls user-templates iexpr parse-expr))


				    (else (error 'name "invalid model source" x))))
			   
			   model-sources))
	       )
	    )

	
	(let ((template-insts (opt 'template)))

          (for-each
           
           (lambda (model)
             
             (cases nemo:model model
                    
                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
				 
                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
                                 
                                 (if template-insts
                                     (for-each
                                      (lambda (template-inst)
                                        (match-let (((template-name . template-args)
                                                     (string-split template-inst ":")))
                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
                                                     (process-template model-name template-name template-args 
                                                                       output-file-suffix user-templates source-path))
                                                   ))
                                      template-insts))
                                 )

		  
		    (ModelPart (source-path in-format model-name part-name sys model-decls parent-decls user-templates iexpr? parse-expr)

			       (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
			       
			       (if template-insts
                                   (for-each
                                    (lambda (template-inst)
                                      (match-let (((template-name . template-args)
                                                   (string-split template-inst ":")))
                                                 (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
                                                   (process-template (s+ model-name "_" part-name)
                                                                     template-name template-args 
                                                                     output-file-suffix user-templates source-path))
                                                 ))
                                    template-insts))
                               )
		  
		  (else (error 'nemo "invalid model" model))))

           models))
        )
      ))


(main opt (opt '@))