;; Gambit configuration file for NanoCAD

;;; If you remove the quote from the following expression, load 
;;; "run-gambit.scm" into the gambit interpreter, then type
;;; (display (list fix_+ fix_- fix_* fix_/ flo_+ flo_- flo_* flo_/ flo_sqrt flo_acos flo_sin flo_cos))
;;; you will get a list of how many operations of each type were executed.
;;; The result after commenting out the call to (blab) is
;;; (26554 14 22 0 219454 106000 381037 26200 44200 3600 0 0)
;;; After adjusting the heap size to be quite large, this takes
;;; 150 ms compiled (without the instrumentation code) on my Ultra 2270.
;;; Assuming that an acos takes 10 flops, I'm getting 5.4 Mflops.
;;; Results with a time-limit of 40:
;;; (264154 14 22 0 2194054 1060000 3810037 262000 442000 36000 0 0)
;;; This took 2130 ms, with 4 garbage collections.

'(begin
  (define fix_+ 0)
  (define fix_- 0)
  (define fix_* 0)
  (define fix_/ 0)
  (define flo_+ 0)
  (define flo_- 0)
  (define flo_* 0)
  (define flo_/ 0)
  (define flo_sqrt 0)
  (define flo_acos 0)
  (define flo_sin 0)
  (define flo_cos 0)
  
  (let ((old_+ +)
	(old_- -)
	(old_* *)
	(old_/ /)
	(old_sqrt sqrt)
	(old_acos acos)
	(old_sin sin)
	(old_cos cos))
    (set! + (lambda args
	      (if (##fixnum? (car args))
		  (set! fix_+ (old_+ fix_+ (old_- (length args) 1)))
		  (set! flo_+ (old_+ flo_+ (old_- (length args) 1))))
	      (apply old_+ args)))
    (set! - (lambda args
	      (if (##fixnum? (car args))
		  (set! fix_- (old_+ fix_- (old_- (length args) 1)))
		  (set! flo_- (old_+ flo_- (old_- (length args) 1))))
	      (apply old_- args)))
    (set! * (lambda args
	      (if (##fixnum? (car args))
		  (set! fix_* (old_+ fix_* (old_- (length args) 1)))
		  (set! flo_* (old_+ flo_* (old_- (length args) 1))))
	      (apply old_* args)))
    (set! / (lambda args
	      (set! flo_/ (old_+ flo_/ (old_- (length args) 1)))
	      (apply old_/ args)))
    (set! sqrt (lambda (x)
		 (set! flo_sqrt (old_+ flo_sqrt 1))
		 (old_sqrt x)))
    (set! acos (lambda (x)
		 (set! flo_acos (old_+ flo_acos 1))
		 (old_acos x)))
    (set! sin (lambda (x)
		(set! flo_sin (old_+ flo_sin 1))
		(old_sin x)))
    (set! cos (lambda (x)
		(set! flo_cos (old_+ flo_cos 1))
		(old_cos x)))))

(declare (standard-bindings) (extended-bindings) (block) (not safe)
	 (not interrupts-enabled))

(declare (not inline) (inlining-limit 0))

(include "strcase.scm")

(define (call-with-output-string proc) ; needed by format
  (let ((port (open-output-string)))
    (proc port)
    (close-output-port port)))

(define current-error-port ##stderr)

(define force-output flush-output)

(include "format.scm")

(declare (inline) (inlining-limit 1000))

(##define-macro (printf fmt . args)
  `(format #t ,fmt ,@args))

(##define-macro (fprintf f . args)
  `(format ,f ,@args))

(##define-macro (declare-fixnum)
  '(declare (fixnum)))

(##define-macro (declare-flonum)
  '(declare (flonum)))

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

(define  debugging    #f  ) 

(define  use-mred    #f  ) 

(define (delete-file file-name)
  (##shell-command (string-append "/bin/rm " file-name)))

(##define-macro (make-lambda args . body)
  `(lambda ,args ,@body))

(##define-macro (funcall lexp . args)
  `(,lexp ,@args))

(##define-macro (func x)
  x)

(define mapcar map)

(define-macro qsort (lambda (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)
  (let ((local-list (gensym))
	(loop-name (gensym)))
    `(let ,loop-name ((,local-list ,(cadr args)))
	  (if (null? ,local-list)
	      (void)
	      (let ((,(car args) (car ,local-list)))
		,@body
		(,loop-name (cdr ,local-list)))))))

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


(##define-macro (dbgprintf x . y) ''())

(##define-macro (entering name) ''())

(##define-macro (if-defined? a b c)
   c)

(define-structure atm element species position velocity force)

(define (create-atm e p)
  (make-atm e
	    (lookup-species (element-name e)
			    (element-initial-hybridization e))
	    p
	    '#(0.0 0.0 0.0)
	    '#(0.0 0.0 0.0)))

(define atm-set-species atm-species-set!)

(define (atm-add-pos a x)
  (atm-position-set! a (vplus x (atm-position a))))

(define atm-set-pos atm-position-set!)

(define (atm-add-velocity a v)
  (atm-velocity-set! a (vplus v (atm-velocity a))))

(define atm-set-velocity atm-velocity-set!)

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

(define-structure bond  order first second)

(define create-bond make-bond)

(define-structure element
  name rvdw mass total-bonds initial-hybridization how-to-hybridize)

(define create-element make-element)

(define-structure species  name hybridization evdw mm2index)

(define create-species make-species)

(define-structure bond-count  singles doubles triples total-bonds)

(define (create-bond-count n)
  (let ((singles 0)
	(doubles 0)
	(triples 0))
    (declare-fixnum)
    (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-bond-count singles doubles triples (+ singles
						(* 2 doubles)
						(* 3 triples)))))

(define-structure dd   diff dist)

(define (create-diff-dist m n)
  (let ((dif (vdiff (atm-position m) (atm-position n))))
    (make-dd dif (vlen dif))))