;#if defined(SCHEME)
;#if defined(GAMBIT)
;; Gambit configuration file for NanoCAD
;#else
;; MzScheme/MrEd configuration file for NanoCAD
;#endif /* defined (GAMBIT) */
;#else
;; Common Lisp configuration file for NanoCAD
;#endif  /* defined (SCHEME) */

;#ifdef SCHEME
;#define DEFCONST(x,y)  (define x y)
;#define TRUE  #t
;#define FALSE #f
;#else
;#define DEFCONST(x,y)  (defconstant x y)
;#define TRUE  t
;#define FALSE nil
(defmacro define (name-args &rest body)
  (cond ((listp name-args)
	 `(defun ,(car name-args) ,(cdr name-args) ,@body))
	(t
	 `(defvar ,name-args ,@body))))
;#endif

DEFCONST(true, TRUE)
DEFCONST(false, FALSE)

;#ifdef DEBUG
DEFCONST(debugging, TRUE)
;#else
DEFCONST(debugging, FALSE)
;#endif

;#ifdef USE_MRED
DEFCONST(use-mred, TRUE)
;#else
DEFCONST(use-mred, FALSE)
;#endif

;#if defined(SCHEME)

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

(define-macro (dolist 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 args . body)
  `(do ((,(car args) 0 (+ 1 ,(car args)))
	(iteration-limit ,(cadr args)))
       ((>= ,(car args) iteration-limit))
       ,@body))

;#ifdef DEBUG
(define-macro (dbgprintf x . y) `(printf ,x ,@y))
(define-macro (entering name) `(printf "Entering ~s~%" ,name))
;#else
(define-macro (dbgprintf x . y) '())
(define-macro (entering name) '())
;#endif

;#else   /* !defined(GAMBIT) */

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

;#ifdef DEBUG
(define-macro dbgprintf
  (lambda (x . y) `(printf ,x ,@y)))
(define-macro entering
  (lambda (name) `(printf "Entering ~s~%" ,name)))
;#else
(define-macro dbgprintf
  (lambda (x . y) '()))
(define-macro entering
  (lambda (name) '()))
;#endif

;#endif  /* defined(GAMBIT) */

;#else  /* !defined(SCHEME) */
(defconstant else t)
(defmacro list-ref (lst n) `(nth ,n ,lst))
(defmacro make-lambda (args &rest body) `#'(lambda ,args ,@body))
(defmacro func (x)  `#',x)
(defmacro real-part (x) x)
(defmacro printf (fmt &rest args) `(format t ,fmt ,@args))
(defmacro set! (var value) `(setf ,var ,value))
(defmacro equal? (x y) `(equal ,x ,y))
(defmacro null? (x) `(null ,x))
(defmacro vector-ref (v n) `(svref ,v ,n))
(defmacro vector-set! (v n value) `(setf (svref ,v ,n) ,value))
(defmacro defined? (x) `(boundp ,x))
(defmacro qsort (x y) `(sort ,x ,y))
(defmacro eq? (x y) `(eq ,x ,y))
(defmacro fprintf (f &rest args)
  `(format ,f ,@args))
(defmacro define-structure (name &rest stuff)
  `(defstruct ,name ,@stuff))

(defun make-vector (n) (make-array (list n)))
(defun open-input-file (name)
  (open name))
(defun open-output-file (name)
  (open name :direction :output :if-exists :supersede))
(defun close-input-port (name)
  (close name))
(defun close-output-port (name)
  (close name))

;#ifdef DEBUG
(defmacro dbgprintf (x &rest y)
  `(format t ,x ,@y))
(defmacro entering (name)
  `(format t "Entering ~s~%" ,name))
;#else
(defmacro dbgprintf (x &rest y) nil)
(defmacro entering (name) nil)
;#endif

;#endif  /* defined(SCHEME) */

;#if defined(GAMBIT) || !defined(SCHEME)

(define-structure atm   element species position velocity force)
(define (create-atm e p)
  (let ((s (lookup-species (element-name e)
			   (element-initial-hybridization e))))
;#if defined(GAMBIT)
    (make-atm e s p '#(0.0 0.0 0.0) '#(0.0 0.0 0.0))
;#else
    (make-atm :element e :species s :position p
	      :velocity '#(0.0 0.0 0.0) :force '#(0.0 0.0 0.0))
;#endif
    ))

;#ifdef GAMBIT
(define (atm-set-species a s) (atm-species-set! a s))
(define (atm-add-pos a x)
  (atm-position-set! a
		     (vplus x (atm-position a))))
(define (atm-set-pos a s) (atm-position-set! a s))
(define (atm-add-velocity a v)
  (atm-velocity-set! a
		     (vplus v (atm-velocity a))))
(define (atm-set-velocity a s) (atm-velocity-set! a s))
(define (atm-zero-velocity a) (atm-velocity-set! a '#(0.0 0.0 0.0)))
(define (atm-zero-force a) (atm-force-set! a '#(0.0 0.0 0.0)))
(define (atm-add-force a v)
  (atm-force-set! a
        (vplus v (atm-force a))))
;#else
(define (atm-set-species a s) (set! (atm-species a) s))
(define (atm-add-pos a x)
  (set! (atm-position a)
        (vplus x (atm-position a))))
(define (atm-set-pos a s) (set! (atm-position a) s))
(define (atm-add-velocity a v)
  (set! (atm-velocity a)
        (vplus v (atm-velocity a))))
(define (atm-set-velocity a s) (set! (atm-velocity a) s))
(define (atm-zero-velocity a) (set! (atm-velocity a) '#(0.0 0.0 0.0)))
(define (atm-zero-force a) (set! (atm-force a) '#(0.0 0.0 0.0)))
(define (atm-add-force a v)
  (set! (atm-force a)
        (vplus v (atm-force a))))
;#endif

(define-structure bond  order first second)
;#if defined(GAMBIT)
(define (create-bond ord f s)
  (make-bond ord f s))
;#else
(define (create-bond ord f s)
  (make-bond :order ord :first f :second s))
;#endif

(define-structure element
  name rvdw mass total-bonds initial-hybridization how-to-hybridize)
;#if defined(GAMBIT)
(define (create-element name rvdw mass bonds init-hybrid ch-hybrid)
  (make-element name rvdw mass bonds init-hybrid ch-hybrid))
;#else
(define (create-element name rvdw mass bonds init-hybrid ch-hybrid)
  (make-element :name name :rvdw rvdw :mass mass :total-bonds bonds
                :initial-hybridization init-hybrid
                :how-to-hybridize ch-hybrid))
;#endif

(define-structure species  name hybridization evdw mm2index)
;#if defined(GAMBIT)
(define (create-species name hybrid evdw mm2)
  (make-species name hybrid evdw mm2))
;#else
(define (create-species name hybrid evdw mm2)
  (make-species :name name :hybridization hybrid :evdw evdw :mm2index mm2))
;#endif

(define-structure bond-count  singles doubles triples total-bonds)
(define (create-bond-count n)
  (let ((b1 0) (b2 0) (b3 0))
    (do ((BL bond-list (cdr BL)))
	((null? BL))
	(if (or (= n (bond-first (car BL))) (= n (bond-second (car BL))))
	    (cond ((= (bond-order (car BL)) 1) (set! b1 (+ b1 1)))
		  ((= (bond-order (car BL)) 2) (set! b2 (+ b1 1)))
		  (else (set! b2 (+ b1 1))))))
    (let ((total (+ b1 (* 2 b2) (* 3 b3))))
;#if defined(GAMBIT)
      (make-bond-count b1 b2 b3 total)
;#else
      (make-bond-count :singles b1 :doubles b2 :triples b3 :total-bonds total)
;#endif
      )))

(define-structure dd   diff dist)
(define (create-diff-dist m n)
  (let ((dif (vdiff (atm-position m) (atm-position n))))
;#ifdef GAMBIT
    (make-dd dif (vlen dif))
#else
    (make-dd :diff dif :dist (vlen dif))
#endif
    ))

;#else /* ! (defined(GAMBIT) || !defined(SCHEME)) */

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

;#endif /* defined(USE_STRUCTS) */