;; MzScheme/MrEd configuration file for NanoCAD

(define  true    #t  ) 
(define  false    #f  ) 

(define  debugging    #f  ) 

(define  use-mred    #f  ) 

(define-macro make-lambda (lambda (args . body) `(lambda ,args ,@body)))
(define-macro funcall (lambda (lexp . args) `(,lexp ,@args)))
(define-macro func (lambda (x) x))
(define-macro mapcar (lambda (f lst) `(map ,f ,lst)))
(define-macro qsort (lambda (x y) `(quicksort ,x ,y)))
(define-macro declare-fixnum (lambda lst '()))
(define-macro declare-flonum (lambda lst '()))
(define-macro labels
  (lambda (defns . body)
    `(let
	 ,(map
	   (lambda (x)
	     (list (car x) (cons 'lambda (cdr x))))
	   defns)
       ,@body)))

(define-macro dolist
  (lambda (args . body)
    `(do ((local-list ,(cadr args) (cdr local-list))
	  (,(car args) '()))
	 ((null? local-list))
       (set! ,(car args) (car local-list))
       ,@body)))

(define-macro dotimes
  (lambda (args . body)
    `(do ((,(car args) 0 (+ 1 ,(car args)))
	  (iteration-limit ,(cadr args)))
	 ((>= ,(car args) iteration-limit))
       ,@body)))

(define-macro dbgprintf
  (lambda (x . y) '()))
(define-macro entering
  (lambda (name) '()))

(define-macro if-defined?
  (lambda (a b c)
    (if (defined? (cadr a))
	b
	c)))

(define (create-atm elem pos)
  (entering "make-atm")
  (let ((velocity '#(0.0 0.0 0.0))
	(force '#(0.0 0.0 0.0))
	(species (lookup-species (funcall elem 'name)
				 (funcall elem 'initial-hybridization))))
    (make-lambda (x y)
      (case x
	((element) elem)
	((species) species)
	((set-species) (set! species y))
	((position) pos)
	((add-pos) (set! pos (vplus pos y)))
	((set-pos) (set! pos y))
        ((velocity) velocity)
        ((add-velocity) (set! velocity (vplus velocity y)))
        ((set-velocity) (set! velocity y))
        ((zero-velocity) (set! velocity '#(0.0 0.0 0.0)))
	((force) force)
	((zero-force) (set! force '#(0.0 0.0 0.0)))
	((add-force) (set! force (vplus force y)))
	(else
	 (printf "Atom trouble, args: ~s, ~s~%" x y))))))

(define (atm-element a)        (funcall a 'element '()))
(define (atm-species a)        (funcall a 'species '()))
(define (atm-set-species a s)  (funcall a 'set-species s))
(define (atm-position a)       (funcall a 'position '()))
(define (atm-add-pos a x)      (funcall a 'add-pos x))
(define (atm-set-pos a x)      (funcall a 'set-pos x))
(define (atm-velocity a)       (funcall a 'velocity '()))
(define (atm-add-velocity a v) (funcall a 'add-velocity v))
(define (atm-set-velocity a v) (funcall a 'set-velocity v))
(define (atm-zero-velocity a)  (funcall a 'zero-velocity '()))
(define (atm-force a)          (funcall a 'force '()))
(define (atm-zero-force a)     (funcall a 'zero-force '()))
(define (atm-add-force a x)    (funcall a 'add-force x))

(define (create-bond order first second)
  (entering "make-bond")
  (make-lambda (x)
    (case x
      ((order) order)
      ((first) first)
      ((second) second))))

(define (bond-order b)  (funcall b 'order))
(define (bond-first b)  (funcall b 'first))
(define (bond-second b) (funcall b 'second))

(define (create-element name rvdw mass bonds init-hybrid ch-hybrid)
  (entering "make-element")
  (make-lambda (x)
    (case x
      ((name) name)
      ((rvdw) rvdw)
      ((mass) mass)
      ((total-bonds) bonds)
      ((initial-hybridization) init-hybrid)
      ((how-to-hybridize) ch-hybrid))))

(define (element-name e)                  (funcall e 'name))
(define (element-rvdw e)                  (funcall e 'rvdw))
(define (element-mass e)                  (funcall e 'mass))
(define (element-total-bonds e)           (funcall e 'total-bonds))
(define (element-initial-hybridization e) (funcall e 'initial-hybridization))
(define (element-how-to-hybridize e)      (funcall e 'how-to-hybridize))

(define (create-species name hybrid evdw mm2)
  (entering "make-species")
  (make-lambda (x)
    (case x
      ((name) name)
      ((hybridization) hybrid)
      ((evdw) evdw)
      ((mm2index) mm2))))

(define (species-name s)          (funcall s 'name))
(define (species-hybridization s) (funcall s 'hybridization))
(define (species-evdw s)          (funcall s 'evdw))
(define (species-mm2index s)      (funcall s 'mm2index))

(define (create-bond-count n)
  (entering "make-bond-count")
  (let ((singles 0)
	(doubles 0)
	(triples 0))
    (dolist (bond bond-list)
	    (if (or (= n (bond-first bond)) (= n (bond-second bond)))
		(case (bond-order bond)
		  ((1) (set! singles (+ singles 1)))
		  ((2) (set! doubles (+ doubles 1)))
		  (else (set! triples (+ triples 1))))))
    (make-lambda (x)
      (case x
	((singles) singles)
	((doubles) doubles)
	((triples) triples)
	((total-bonds) (+ singles (* 2 doubles) (* 3 triples)))))))

(define (bond-count-singles bc)     (funcall bc 'singles))
(define (bond-count-doubles bc)     (funcall bc 'doubles))
(define (bond-count-triples bc)     (funcall bc 'triples))
(define (bond-count-total-bonds bc) (funcall bc 'total-bonds))

(define (create-diff-dist m n)
  (let* ((ma (atm-position m))
	 (na (atm-position n))
	 (diff (vdiff ma na))
	 (dist (vlen diff)))
    (make-lambda (x)
      (case x
	((diff) diff)
	((distance) dist)))))

(define (dd-diff dd) (funcall dd 'diff))
(define (dd-dist dd) (funcall dd 'distance))