source: project/release/3/nemo/trunk/extensions/nemo-hh.scm @ 11977

;;
;; 
;; An extension for specifying Hodgkin-Huxley type dynamics in NeuroML
;; systems
;;
;; 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 srfi-1)
(require-extension srfi-13)
(require-extension nemo-core)
(require-extension environments)

(define (s+ . lst)    (string-concatenate (map ->string lst)))

(define (p$ p n) (string->symbol (s+ (->string p) "_" (->string n))))


(define (lookup-field k lst . rest)
  (let-optionals rest ((default #f))
   (let ((v (alist-ref k lst)))
     (if v (first v) default))))


(define (check-names ion env . names)
  (for-each (lambda (name)
              (if (environment-includes? env name)
                  (nemo:error 'nemo:hh-transformer "quantity " name " in ionic conductance declaration " ion
                             "is already declared elsewhere")))
            names))

(define (check-decls ion names alst . rest)
  (let-optionals rest ((raise-exception? #t))
    (if raise-exception?
        (for-each (lambda (name) 
                    (if (not (alist-ref name alst))
                        (nemo:error 'nemo:hh-transformer "required quantity " name 
                                   " is not present in ionic conductance declaration " ion)))
                  names)
        (every (lambda (name) (alist-ref name alst)) names))))


(define (handle thunk dflt)
  (condition-case (thunk)
                  [(exn) dflt]))

(define (hh-ionic-conductance-transform sys eval-const env-extend! add-external! component-extend! comp en)
  (match en
         ((or (('hh 'ionic 'conductance)  ('name (? symbol? ion)) . alst)
              (('hh-ionic-conductance)    ('name (? symbol? ion)) . alst))
          (check-decls ion '(m-power h-power) alst)
          (let ((suffix (->string ion))
                (m-power (eval-const sys (lookup-field 'm-power alst)))
                (h-power (eval-const sys (lookup-field 'h-power alst 0))))
            
            (if (not (and (integer? m-power) (positive? m-power)))
                (nemo:error 'nemo:hh-transformer 
                           "m-power value in ionic conductance declaration " ion
                           " must be a positive integer"))
            
            ;; check for required decls in m
            (check-decls ion '(initial-m) alst)
            (if (not (check-decls ion '(m-inf m-tau) alst #f))
                (check-decls ion '(m-alpha m-beta) alst))
            
            ;; check for required decls in h
            (if (positive? h-power) 
                (begin (check-decls ion '(initial-h) alst)
                       (if (not (check-decls ion '(h-inf h-tau) alst #f))
                           (check-decls ion '(h-alpha h-beta) alst))))
            
            (if (not (and (integer? h-power) (or (zero? h-power) (positive? m-power))))
                (nemo:error 'nemo:hh-transformer 
                           "h-power value in ionic conductance declaration " ion
                                                        " must be a positive integer"))
                                         
            (let* ((initial-m  ((lambda (x) (handle (lambda () (eval-const sys x)) x))
                                (lookup-field 'initial-m alst)))
                   (m-inf      (lookup-field 'm-inf alst))
                   (m-tau      (lookup-field 'm-tau alst))
                   (m-alpha    (or (lookup-field 'm-alpha alst)  `(/ ,m-inf ,m-tau)))
                   (m-beta     (or (lookup-field 'm-beta alst)   `(/ (- 1 ,m-inf) ,m-tau)))
                   (open       (p$ ion 'mO))
                   (closed     (p$ ion 'mC))
                   (mst        `((power ,m-power)  (open  ,open)
                                 (transitions (-> ,closed ,open ,m-alpha) 
                                              (-> ,open ,closed ,m-beta)))))
              (apply env-extend! (cons* (p$ ion 'm) '(tscomp) initial-m mst))
              (add-external! (p$ ion 'm) 'output)
              (component-extend! comp (p$ ion 'm))
              )
            
            (if (positive? h-power)
                (let* ((initial-h  ((lambda (x) (handle (lambda () (eval-const sys x)) x))
                                    (lookup-field 'initial-h alst)))
                       (h-inf      (lookup-field 'h-inf alst))
                       (h-tau      (lookup-field 'h-tau alst))
                       (h-alpha    (or (lookup-field 'h-alpha alst)
                                       `(/ ,h-inf ,h-tau)))
                       (h-beta     (or (lookup-field 'h-beta alst)
                                       `(/ (- 1 ,h-inf) ,h-tau)))

                       (open       (p$ ion 'hO))
                       (closed     (p$ ion 'hC))
                       (hst        `((power ,h-power)
                                     (open  ,open)
                                     (transitions (-> ,closed ,open ,h-alpha) 
                                                  (-> ,open ,closed ,h-beta)))))
                  (apply env-extend! (cons* (p$ ion 'h) '(tscomp) initial-h hst))
                  (add-external! (p$ ion 'h) 'output)
                  (component-extend! comp (p$ ion 'h))
                  ))))
         (else (list))))

(define (nemo:hh-transformer sys . rest)
  (let ((new-sys  (nemo:env-copy sys)))
   (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref new-sys (nemo-intern 'dispatch))))
     (let* ((eval-const         (dis 'eval-const))
            (env-extend!        ((dis 'env-extend!) new-sys))
            (add-external!      ((dis 'add-external!) new-sys))
            (component-extend!  ((dis 'component-extend!) new-sys))
            (indent  0)
            (indent+ (+ 2 indent )))
       (let recur ((comp-name (nemo-intern 'toplevel)))
         (let* ((comp-symbols   ((dis 'component-symbols) new-sys comp-name))
                (subcomps       ((dis 'component-subcomps) new-sys comp-name)))
           (print "comp-name: " comp-name)
           (print "comp-symbols: " comp-symbols)
            (for-each (lambda (sym)
                        (hh-ionic-conductance-transform  
                         new-sys (dis 'eval-const) env-extend! add-external! component-extend!
                         comp-name (environment-ref new-sys sym)))
                      comp-symbols)
            (for-each recur (map second subcomps))))
       new-sys))))