source: project/release/3/nemo/trunk/nmodl.scm @ 11996

;; TODO: * uniquify state names in state complexes
;;       * check that open states are valid
;;
;; 
;; An extension for translating NeuroML models to NMODL descriptions.
;;
;; Copyright 2008 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/>.
;;

(require-extension syntax-case)
(require-extension matchable)
(require-extension strictly-pretty)
(require-extension environments)
(require-extension nemo-core)
(require-extension srfi-1)
(require-extension srfi-4)
(require-extension srfi-13)
(require-extension srfi-14)
(require-extension runcmd)
(require-extension utils)
(require-extension lolevel)
(require-extension varsubst)
(require-extension digraph)
(require-extension datatype)

(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 (nmodl-name s)
  (let ((cs (string->list (->string s))))
    (let loop ((lst (list)) (cs cs))
      (if (null? cs) (string->symbol (list->string (reverse lst)))
          (let* ((c (car cs))
                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)) c)
                           (else #\_))))
            (loop (cons c1 lst) (cdr cs)))))))
                            
                  

(define (enumprocs expr ax)
  (match expr 
         (('if . es)  (fold enumprocs ax es))
         (('let bnds body)  (fold enumprocs (fold enumprocs ax (map cadr bnds)) body))
         ((s . es)    (if (symbol? s)  (cons s (fold enumprocs ax es)) ax))
         (else ax)))

(define (enumbnds expr ax)
  (match expr 
         (('if . es)        (fold enumbnds ax es))
         (('let bnds body)  (enumbnds body (append (map car bnds) (fold enumbnds ax (map cadr bnds)))))
         ((s . es)          (if (symbol? s)  (fold enumbnds ax es) ax))
         (else ax)))


(define (enum-freevars expr bnds ax)
  (match expr 
         (('if . es)  
          (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
         (('let bnds body)  
          (let ((bnds1 (append (map first bnds) bnds)))
            (enum-freevars body bnds1 (fold (lambda (x ax) (enum-freevars x bnds ax)) ax (map second bnds)))))
         ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
         (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))

(define (rhsvars rhs)
  (enum-freevars rhs (list) (list)))

(define (rhsexpr expr)
  (match expr 
         (('if . es)  `(if . ,(map (lambda (x) (rhsexpr x)) es)))
         (('pow x y)  (if (and (integer? y)  (positive? y))
                          (if (> y 1)  (let ((tmp (gensym "x")))
                                         `(let ((,tmp ,x)) (* . ,(list-tabulate (inexact->exact y) (lambda (i) tmp)))))
                              x)
                            expr))
         ((s . es)    (if (symbol? s)  (cons s (map (lambda (x) (rhsexpr x)) es)) expr))
         (id          id)))


;;; 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 (spaces n)  (list->string (list-tabulate n (lambda (x) #\space))))

(define (ppf indent . lst)
  (let ((sp (spaces indent)))
    (for-each (lambda (x)
                (and x (match x 
                              ((i . x1) (if (and (number? i) (positive? i))
                                            (for-each (lambda (x) (ppf (+ indent i) x)) x1)
                                            (print sp (sw+ x))))
                              (else   (print sp (if (list? x) (sw+ x) x))))))
              lst)))


(define-syntax pp
  (syntax-rules ()
    ((pp indent val ...) (ppf indent (quasiquote val) ...))))

(define ifthen/NMODL  (doc:ifthen 0 (doc:text "if") (doc:text "") (doc:text "else")))
(define letblk/NMODL  (doc:letblk 2 (doc:empty) (doc:break) (doc:empty)))
(define group/NMODL   (doc:block 2 (doc:text "(") (doc:text ")")))
(define block/NMODL   (doc:block 2 (doc:text "{") (doc:text "}")))
(define binop/NMODL   (doc:binop 2))

(define (format-op/NMODL indent op args)
  (let ((op1 (doc:text (->string op))))
    (if (null? args) op1
        (match args
               ((x)           (doc:connect op1 x))
               ((x y)         (binop/NMODL x op1 y))
               ((x y z)       (binop/NMODL x op1 (binop/NMODL y op1 z)))
               (lst           (let* ((n   (length lst))
                                     (n/2 (inexact->exact (round (/ n 2)))))
                                (binop/NMODL (format-op/NMODL indent op (take lst n/2 )) op1 
                                         (format-op/NMODL indent op (drop lst n/2 )))))))))

(define (format-fncall/NMODL indent op args)
  (let ((op1 (doc:text (->string op))))
    (doc:cons op1 (group/NMODL ((doc:list indent identity (lambda () (doc:text ", "))) args)))))

(define nmodl-builtin-consts
  `(celsius diam))

(define nmodl-ops
  `(+ - * / > < <= >= = ^))

(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
      fpvector-ref))

(define (sum lst)
  (if (null? lst) lst
      (match lst
             ((x)   x)
             ((x y) `(+ ,x ,y))
             ((x y . rest) `(+ (+ ,x ,y) ,(sum rest)))
             ((x . rest) `(+ ,x ,(sum rest))))))


(define (subst-term t subst k)
  (match t
         (('if c t e)
          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
         (('let bs e)
          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
         ((f . es)
          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
         ((? symbol? )  (lookup-def t subst t))
         ((? atom? ) t)))

(define (binding? t) (and (list? t) (eq? 'let (car t)) (cdr t)))

(define (bind ks vs e) `(let ,(zip ks vs) ,e))

(define (name-normalize expr)
  (match expr 
         (('if c t e)  `(if ,(name-normalize c) ,(name-normalize t) ,(name-normalize e)))
         (('let bs e)
          `(let ,(map (lambda (b) `(,(car b) ,(name-normalize (cadr b)))) bs) ,(name-normalize e)))
         ((f . es) 
          (cons f (map name-normalize es)))
         ((? symbol? ) (nmodl-name expr))
         ((? atom? ) expr)))

(define (if-convert expr)
  (match expr 
         (('if c t e) 
          (let ((r (gensym "if")))
            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e))))  
               ,r)))
         (('let bs e)
          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
         ((f . es)
          (cons f (map if-convert es)))
         ((? atom? ) expr)))

         
(define (let-enum expr ax)
  (match expr
         (('let ((x ('if c t e))) y)
          (let ((ax (fold let-enum ax (list c ))))
            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))

         (('let bnds body)  (let-enum body (append ax bnds)))

         (('if c t e)  (let-enum ax c))

         ((f . es)  (fold let-enum ax es))

         (else ax)))


(define (let-elim expr)
  (match expr
         (('let ((x ('if c t e))) y)
          (if (eq? x y)  y expr))

         (('let bnds body) (let-elim body))

         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))

         ((f . es)  `(,f . ,(map let-elim es)))

         (else expr)))
  

(define (let-lift expr)
  (let ((bnds (let-enum expr (list))))
    (if (null? bnds) expr
        `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds) ,(let-elim expr)))))

(define (canonicalize-expr/NMODL expr)
  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
    (let* ((expr1 (if-convert expr))
           (expr2 (subst-convert expr1 subst-empty))
           (expr3 (let-lift expr2))
           (expr4 (name-normalize expr3)))
      expr4)))

(define (format-expr/NMODL indent expr . rest)  
  (let-optionals rest ((rv #f))
   (let ((indent+ (+ 2 indent)))
    (match expr
       (('let bindings body)
        (letblk/NMODL
         (fold-right 
           (lambda (x ax)
             (letblk/NMODL
              (match (second x)
                     (('if c t e)
                      (ifthen/NMODL
                       (group/NMODL (format-expr/NMODL indent c))
                       (block/NMODL (format-expr/NMODL indent t (first x)))
                       (block/NMODL (format-expr/NMODL indent e (first x)))))
                     (else 
                      (format-op/NMODL indent+ " = "
                                       (list (format-expr/NMODL indent (first x) )
                                             (format-expr/NMODL indent (second x))))))
              ax))
           (doc:empty) bindings)
         (let ((body1 (doc:nest indent (format-expr/NMODL indent body))))
           (if rv  (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) body1))
               body1))))
       
       (('if . rest) (error 'format-expr/NMODL "invalid if statement " expr))

       ((op . rest)  
       (let ((op (case op ((pow)  '^) ((abs) 'fabs) (else op))))
         (let ((fe
                (if (member op nmodl-ops)
                    (let ((mdiv?  (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest))
                          (mul?   (any (lambda (x) (match x (('* . _) #t) (else #f))) rest))
                          (plmin? (any (lambda (x) (match x (('+ . _) #t) (('- . _) #t) (else #f))) rest)))
                      (case op
                        ((/)  
                         (format-op/NMODL indent op 
                                          (map (lambda (x) 
                                                 (let ((fx (format-expr/NMODL indent+ x)))
                                                   (if (or (symbol? x) (number? x)) fx
                                                       (if (or mul? plmin?) (group/NMODL fx) fx)))) rest)))
                        ((*)  
                         (format-op/NMODL indent op 
                                          (map (lambda (x) 
                                                 (let ((fx (format-expr/NMODL indent+ x)))
                                                   (if (or (symbol? x) (number? x)) fx
                                                       (if plmin? (group/NMODL fx) fx)))) rest)))
                        
                        ((^)  
                         (format-op/NMODL indent op 
                                          (map (lambda (x) 
                                                 (let ((fx (format-expr/NMODL indent+ x)))
                                                   (if (or (symbol? x)  (number? x)) fx
                                                       (if (or mdiv? plmin?) (group/NMODL fx) fx)))) rest)))
                        
                        (else
                         (format-op/NMODL indent op 
                                          (map (lambda (x) 
                                                 (let ((fx (format-expr/NMODL indent+ x))) fx)) rest)))))
                    
                    (let ((op (case op ((neg) '-) (else op))))
                      (format-fncall/NMODL indent op (map (lambda (x) (format-expr/NMODL indent+ x)) rest))))))
           (if rv 
               (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
               fe))))
      
      (else  (let ((fe (doc:text (->string expr))))
               (if rv 
                   (format-op/NMODL indent " = " (list (format-expr/NMODL indent+ rv ) fe))
                   fe)))))))
               

          
(define (expr->string/NMODL x . rest)
  (let-optionals rest ((rv #f) (width 72))
    (sdoc->string (doc:format width (format-expr/NMODL 2 x rv)))))
  

(define (make-define-fn table? min-v max-v with depend)
  (lambda (indent n proc)
    (let ((lst (procedure-data proc))
          (indent+ (+ 2 indent)))
      (let ((rt       (lookup-def 'rt lst))
            (formals  (lookup-def 'formals lst))
            (vars     (lookup-def 'vars lst))
            (body     (lookup-def 'body lst)))
        (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" ))
        (let* ((body1 (canonicalize-expr/NMODL (rhsexpr body)))
               (lbs   (enumbnds body1 (list))))
          (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " lbs))))
          (if (and table? min-v max-v with)
              (match vars
                     (('v)  (pp indent+ (TABLE ,@(if depend `(DEPEND ,depend) `(""))
                                               FROM ,min-v TO ,max-v WITH ,with)))
                     (else  (void))))
          (pp indent+ ,(expr->string/NMODL body1 n)))
        (pp indent "}")))  
    ))

(define (define-state indent n)
  (pp indent (,n)))


(define (state-eqs n initial open transitions power)
  (let* ((g (make-digraph n (string-append (->string n) " transitions graph")))
         (add-node!  (g 'add-node!))
         (add-edge!  (g 'add-edge!))
         (out-edges  (g 'out-edges))
         (in-edges   (g 'in-edges))
         (node-info  (g 'node-info))
         (node-list  (let loop ((lst (list)) (tlst transitions))
                       (if (null? tlst)  (delete-duplicates lst eq?)
                           (match (car tlst) 
                                  (('-> s0 s1 rate-expr)
                                   (loop (cons s0 (cons s1 lst)) (cdr tlst)))
                                  (('-> _)
                                   (nemo:error 'nemo:nmodl-state-eqs ": invalid transition equation " 
                                                  (car tlst) " in state complex " n))
                                  (else (loop lst (cdr tlst)))))))
         (node-ids      (list-tabulate (length node-list) identity))
         (name->id-map  (zip node-list node-ids)))
    ;; insert state nodes in the dependency graph
    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
    (let* ((nodes  ((g 'nodes)))
           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes)))))
      ;; create rate edges in the graph
      (for-each (lambda (e) 
                  (match e (('-> s0 s1 rate-expr)
                            (let ((i  (car (alist-ref s0 name->id-map)))
                                  (j  (car (alist-ref s1 name->id-map)))
                                  (x  (if (eq? s0 (second snode)) snex s0)))
                            (add-edge! (list i j `(* ,x ,rate-expr)))))
                         (else (void))))
                transitions)
      ;; generate differential equations for each state in the transitions system
      (let ((eqs    (fold (lambda (s ax) 
                            (if (= (first snode) (first s) ) ax
                                (let* ((out   (out-edges (first s)))
                                       (in    (in-edges (first s)))
                                       (open? (eq? (second s) open))
                                       (name  (second s)))
                                  (let* ((rhs1  (cond ((and (not (null? out)) (not (null? in)))
                                                       `(+ (neg ,(sum (map third out)))
                                                           ,(sum (map third in))))
                                                      ((and (not (null? out)) (null? in))
                                                       `(neg ,(sum (map third out))))
                                                      ((and (null? out) (not (null? in)))
                                                       (sum (map third in)))))
                                         (fbody  (rhsexpr rhs1))
                                         (fbody1 (canonicalize-expr/NMODL fbody)))
                                    (cons (list (s+ name "'") fbody1) ax)))))
                          (list) nodes)))
        eqs))))
            
        


(define (state-init n init)
  (let* ((init  (rhsexpr init))
         (init1 (canonicalize-expr/NMODL init)))
    (list  n init1)))

(define (asgn-eq n rhs)
  (let* ((fbody   (rhsexpr rhs))
         (fbody1  (canonicalize-expr/NMODL fbody)))
    (list n fbody1)))


(define (stcomp-eq n open transitions)
  (list n open))


(define (poset->asgn-eq-defs poset sys)
  (fold-right
   (lambda (lst ax)
     (fold  (lambda (x ax) 
              (match-let (((i . n)  x))
                         (let ((en (environment-ref sys n)))
                           (if (nemo:quantity? en)
                               (cases nemo:quantity en
                                      (ASGN  (name value rhs) (cons (asgn-eq name rhs) ax))
                                      (else  ax))
                               ax))))
            ax lst))
   (list) poset))


(define (poset->state-eq-defs poset sys)
  (fold-right
   (lambda (lst ax)
     (fold  (lambda (x ax) 
              (match-let (((i . n)  x))
                         (let ((en (environment-ref sys n)))
                           (if (nemo:quantity? en)
                               (cases nemo:quantity en
                                      (TSCOMP  (name initial open transitions power) 
                                               (append (state-eqs name initial open transitions power) ax))
                                      (else  ax))
                               ax))))
            ax lst))
   (list) poset))


(define (poset->stcomp-eq-defs poset sys)
  (fold-right
   (lambda (lst ax)
     (fold  (lambda (x ax) 
              (match-let (((i . n)  x))
                         (let ((en (environment-ref sys n)))
                           (if (nemo:quantity? en)
                               (cases nemo:quantity en
                                      (TSCOMP  (name initial open transitions power) 
                                               (cons (stcomp-eq name open transitions) ax))
                                      (else  ax))
                               ax))))
            ax lst))
   (list) poset))

(define (poset->state-init-defs poset sys)
  (fold-right
   (lambda (lst ax)
     (fold  (lambda (x ax) 
              (match-let (((i . n)  x))
                         (let ((en (environment-ref sys n)))
                           (if (nemo:quantity? en)
                               (cases nemo:quantity en
                                      (TSCOMP  (name initial open transitions power) 
                                               (cons* (state-init name initial) (state-init open name) ax))
                                      (else  ax))
                               ax))))
            ax lst))
   (list) poset))

(define (find-locals defs)
  (concatenate 
   (map (lambda (def) (match (second def) (('let bnds _) (map first bnds)) (else (list))))
        defs)))


(define (state-power sys n)
  (let ((en (environment-ref sys n)))
    (if (nemo:quantity? en)
        (cases nemo:quantity en
               (TSCOMP  (name initial open transitions power)  power)
               (else  #f))  #f)))

(define (bucket-partition p lst)
  (let loop ((lst lst) (ax (list)))
    (if (null? lst) ax
        (let ((x (car lst)))
          (let bkt-loop ((old-bkts ax) (new-bkts (list)))
            (if (null? old-bkts) (loop (cdr lst) (cons (list x) new-bkts))
                (if (p x (caar old-bkts ))
                    (loop (cdr lst) (append (cdr old-bkts) (cons (cons x (car old-bkts)) new-bkts)))
                    (bkt-loop (cdr old-bkts) (cons (car old-bkts) new-bkts)))))))))


(define (nemo:nmodl-translator sys . rest)
  (define (cid x) (second x))
  (define (cn x) (first x))
  (let-optionals rest ((method 'cnexp) (table? #f) (min-v -100) (max-v 100) (step 0.5) (depend #f) )
  (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref sys (nemo-intern 'dispatch))))
    (let ((imports  ((dis 'imports)  sys))
          (exports  ((dis 'exports)  sys)))
      (let* ((indent  0)
             (indent+ (+ 2 indent ))
             (sysname (nmodl-name ((dis 'sysname) sys)))
             (deps*   ((dis 'depgraph*) sys))
             (consts  ((dis 'consts) sys))
             (asgns   ((dis 'asgns) sys))
             (states  ((dis 'states) sys))
             (stcomps ((dis 'stcomps) sys))
             (defuns  ((dis 'defuns) sys))
             (components ((dis 'components) sys))
             (ionchs  (filter-map (match-lambda ((name 'ion-channel id) (list name id)) (else #f)) components))) 
        (match-let (((state-list asgn-list g) deps*))
         (let* ((poset          (vector->list ((dis 'depgraph->bfs-dist-poset) g)))
                (asgn-eq-defs   (poset->asgn-eq-defs poset sys))
                (perm-ions (delete-duplicates
                            (fold (lambda (ionch ax) 
                                    (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
                                           (perm      (lookup-def 'permeating-substance subcomps)))
                                      (if perm 
                                          (case (cn perm)
                                            ((non-specific)   
                                             (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
                                                    (i    (nmodl-name 'i))
                                                    (e    (nmodl-name 'e)))
                                               (cons `(,(cn perm) ,i ,e ,erev) ax)))
                                            (else (let* ((erev (car ((dis 'component-exports) sys (cid perm))))
                                                         (i    (nmodl-name (s+ 'i (cn perm))))
                                                         (e    (nmodl-name (s+ 'e (cn perm)))))
                                                    (cons `(,(cn perm) ,i ,e ,erev) ax))))
                                          ax)))
                                  (list) ionchs)
                            (lambda (x y) (eq? (car x) (car y)))))
               (acc-ions (delete-duplicates
                           (fold (lambda (ionch ax) 
                                  (let* ((subcomps ((dis 'component-subcomps) sys (cid ionch)))
                                         (acc   (lookup-def 'accumulating-substance subcomps))
                                         (i     (and acc (nmodl-name (s+ 'i (cn acc)))))
                                         (in    (and acc (nmodl-name (s+ (cn acc) 'i))))
                                         (out   (and acc (nmodl-name (s+ (cn acc) 'o)))))
                                    (if acc  (cons `(,(cn acc) ,i ,in ,out) ax) ax)))
                                (list) ionchs)
                           (lambda (x y) (eq? (car x) (car y)))))
               )

           (pp indent ,nl (TITLE ,sysname))
           
           (pp indent ,nl (NEURON "{"))
           (if (not (null? exports)) (pp indent+ (RANGE ,(sl\ ", " exports))))
           (for-each (lambda (x)
                       (case (first x)
                         ((non-specific) 
                          (pp indent+ (RANGE ,(third x))
                              (NONSPECIFIC_CURRENT ,(second x))))
                         (else 
                          (pp indent+ (RANGE ,(second x))
                              (USEION ,(first x) READ ,(third x) WRITE ,(second x))))))
                     perm-ions)
           (for-each (lambda (x)
                       (pp indent+ (RANGE ,(second x))
                           (USEION ,(first x) READ ,(third x) ", " ,(fourth x) WRITE ,(second x))))
                     acc-ions)
           (let* ((const-names   (map first consts))
                  (is-const?     (lambda (x) (member x const-names)))
                  (range-consts  (delete-duplicates 
                                  (fold (lambda (def ax) 
                                          (let* ((rhs   (second def))
                                                 (vars  (rhsvars rhs)))
                                            (append (filter is-const? vars) ax)))
                                        (list) asgn-eq-defs ))))
             (if (not (null? range-consts)) (pp indent+ (RANGE ,(sl\ ", " range-consts)))))
           
           
           (pp indent "}")
           
           
           (pp indent ,nl (PARAMETER "{"))
           (let* ((const-defs (filter-map
                               (lambda (nv)
                                 (and (not (member (first nv) nmodl-builtin-consts))
                                      (let ((v1 (canonicalize-expr/NMODL (second nv))))
                                        (list (first nv) v1))))
                                   consts))
                  (locals  (find-locals const-defs)))
             (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
             (for-each (lambda (def)
                         (let ((n (first def)) (b (second def)))
                           (pp indent+ ,(expr->string/NMODL b n)))) const-defs))
           (pp indent "}")
           
           (let* ((with      (inexact->exact (round (/ (abs (- max-v min-v)) step))))
                  (define-fn (make-define-fn table? min-v max-v with depend)))
             (for-each (lambda (fndef) 
                         (if (not (member (car fndef) builtin-fns))
                             (apply define-fn (cons indent fndef)))) 
                       defuns))
           
           
           (pp indent ,nl (STATE "{"))
           (for-each (lambda (st) (apply define-state (list indent+ st)))
                     states)
           (for-each (lambda (st) (apply define-state (list indent+ st)))
                     stcomps)
           (pp indent "}")
           
           (pp indent ,nl (ASSIGNED "{"))
           (let* ((asgns0 (append asgns (map first imports) 
                                  (map second perm-ions) (map third perm-ions)
                                  (map second acc-ions) (map fourth acc-ions)))
                  (asgns1 (delete-duplicates asgns0)))
             (for-each (lambda (x) (pp indent+ ,(nmodl-name x))) asgns1)
             (pp indent "}")
             
             (if (not (null? asgns))
                 (begin
                   (pp indent ,nl (PROCEDURE rates () "{"))
                   (let ((locals    (find-locals asgn-eq-defs))) 
                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))))
                   (for-each (lambda (def)
                               (let ((n (nmodl-name (first def)) )
                                     (b (second def)))
                                 (pp indent+ ,(expr->string/NMODL b n)))) asgn-eq-defs)
                   (pp indent "}")))
             
             (if (not (null? stcomps))
                 (begin
                   (pp indent ,nl (PROCEDURE stcomps () "{"))
                   (let* ((eq-defs   (poset->stcomp-eq-defs poset sys)) 
                          (locals    (find-locals eq-defs))) 
                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
                     (for-each (lambda (def)
                                 (let ((n (first def)) (b (second def)))
                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
                   
                   (pp indent "}")))
             
             (pp indent ,nl (BREAKPOINT "{"))
             (let* ((i-eqs (filter-map
                            (lambda (ionch) 
                              (let* ((n     (second ionch))
                                     (subcomps ((dis 'component-subcomps) sys n))
                                     (acc   (lookup-def 'accumulating-substance subcomps))
                                     (perm  (lookup-def 'permeating-substance subcomps))
                                     (pore  (lookup-def 'pore subcomps))
                                     (gate  (lookup-def 'gate subcomps))
                                     (sts   (and gate ((dis 'component-exports) sys (cid gate)))))
                                (cond ((and perm pore gate)
                                       (case (cn perm)
                                         ((non-specific)
                                          (let* ((i     (nmodl-name 'i))
                                                 (e     (nmodl-name 'e))
                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
                                            (list i e gion)))
                                         (else
                                          (let* ((i     (nmodl-name (s+ 'i (cn perm))))
                                                 (e     (nmodl-name (s+ 'e (cn perm))))
                                                 (gmax  (car ((dis 'component-exports) sys (cid pore))))
                                                 (pwrs  (map (lambda (n) (state-power sys n)) sts))
                                                 (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
                                            (list i e gion)))))
                                      ((and acc pore gate)
                                       (let* ((i     (nmodl-name (s+ 'i (cn acc))))
                                              (gmax  (car ((dis 'component-exports) sys (cid pore))))
                                              (pwrs  (map (lambda (n) (state-power sys n)) sts))
                                              (gion  `(* ,gmax . ,(map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs))))
                                         (list i #f gion)))
                                      (else (nemo:error 'nemo:nmodl-translator ": invalid ion channel definition " n))
                                      )))
                            ionchs))
                    (i-bkts (bucket-partition (lambda (x y) (eq? (car x) (car y))) i-eqs))
                    (i-eqs  (fold (lambda (b ax) 
                                    (match b 
                                           ((and ps ((i e gion) . rst))  
                                            (let* ((sum   (if e `(* ,(sum (map third ps)) (- v ,e))
                                                              (sum (map third ps))))
                                                   (sum0  (rhsexpr sum))
                                                   (sum1  (canonicalize-expr/NMODL sum0)))
                                              (cons (list i sum1) ax)))
                                           
                                           ((i e gion)
                                            (let* ((expr0  (rhsexpr (if e `(* ,gion (- v ,e)) gion)))
                                                   (expr1  (canonicalize-expr/NMODL expr0)))
                                              (cons (list i expr1) ax)))
                                           
                                           
                                           (else ax)))
                                  (list) i-bkts))
                    (locals (find-locals i-eqs)))
               (if (not (null? locals))   (pp indent+ (LOCAL ,(sl\ ", " locals))))
               (if (not (null? asgns))    (pp indent+ (rates ())))
               (if (not method) (pp indent+ (SOLVE states))
                   (pp indent+ (SOLVE states METHOD ,method)))
               (if (not (null? stcomps))  (pp indent+ (stcomps ())))
               (for-each (lambda (p) (pp indent+ ,(expr->string/NMODL (second p) (first p)))) i-eqs)
               (pp indent "}"))
             
             (if (not (null? states))
                 (begin
                   (pp indent ,nl (DERIVATIVE states "{"))
                   (let* ((eq-defs (reverse (poset->state-eq-defs poset sys)))
                          (locals (find-locals eq-defs))) 
                     (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
                     (for-each (lambda (def)
                                 (let ((n (first def)) (b (second def)))
                                   (pp indent+ ,(expr->string/NMODL b n)))) eq-defs))
                   (pp indent "}")))
             
             (pp indent ,nl (INITIAL "{"))
             (let* ((init-defs  (poset->state-init-defs poset sys))
                    (locals     (concatenate (find-locals init-defs)))) 
               (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals))))
               (if (not (null? asgns))  (pp indent+ (rates ())))
               (for-each (lambda (def)
                           (let ((n (first def)) (b (second def)))
                             (pp indent+ ,(expr->string/NMODL b n)))) init-defs)
               (for-each (lambda (x)  (pp indent+ (,(third x) = ,(fourth x))))
                         perm-ions))
             (pp indent "}")
             
             )))
        )))))