ncad022
|
README,
compare,
config.c,
contrib,
forces.scm,
gui.scm,
hackv.scm,
helper,
make-tgz,
make-zip,
methane,
nc.lsp,
nc.scm,
ncad022.scm,
ncd.lsp,
ncm.scm,
perform.lsp,
propane,
test.scm,
|
|
|
;; Truly sick and twisted hack. By extensive use of macros, and with a
;; little help from the C preprocessor, we now can run NanoCAD in either
;; Common Lisp or in MzScheme/MrEd.
#ifdef SCHEME
#define DEFVAR(x,y) (define x y)
#define TRUE #t
#define FALSE #f
#else
#define DEFVAR(x,y) (defvar x y)
#define TRUE t
#define FALSE nil
#endif
DEFVAR(true, TRUE)
DEFVAR(false, FALSE)
#ifdef DEBUG
DEFVAR(debugging, TRUE)
#else
DEFVAR(debugging, FALSE)
#endif
#ifdef USE_MRED
DEFVAR(use-mred, TRUE)
#else
DEFVAR(use-mred, FALSE)
#endif
#ifdef SCHEME
(define-macro make-lambda (lambda (args . body) `(lambda ,args ,@body)))
(define-macro funcall (lambda (lexp . args) `(,lexp ,@args)))
(define-macro do-lisp (lambda (x) '()))
(define-macro do-scheme (lambda (x) x))
(define-macro func (lambda (x) x))
(define-macro mapcar (lambda (f lst) `(map ,f ,lst)))
(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)
(if debugging
`(printf ,x ,@y)
'())))
(define-macro entering
(lambda (name)
(if debugging
`(printf "Entering ~s~%" ,name)
'())))
#else
(defvar else t)
(defmacro list-ref (lst n) `(nth ,n ,lst))
(defmacro make-lambda (args &rest body) `#'(lambda ,args ,@body))
(defmacro func (x) `#',x)
(defmacro do-lisp (x) x)
(defmacro do-scheme (x) '())
(defmacro define (name-args &rest body)
(cond ((listp name-args)
`(defun ,(car name-args) ,(cdr name-args) ,@body))
(t
`(defvar ,name-args ,@body))))
(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))
(defun make-vector (n)
(make-array (list n)))
; (labels
; ((make-list (n)
; (if (= n 0) '() (cons '() (make-list (- n 1))))))
; (apply #'vector (make-list n))))
(if debugging
(let ()
(defmacro dbgprintf (x &rest y)
`(format t ,x ,@y))
(defmacro entering (name)
`(format t "Entering ~s~%" ,name)))
(let ()
(defmacro dbgprintf (x &rest y) nil)
(defmacro entering (name) nil)))
#endif
;; ==================================================================
;; Big Fun Data Types
#ifdef 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 (elem 'name)
(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) (a 'element #f))
(define (atm-species a) (a 'species #f))
(define (atm-set-species a s) (a 'set-species s))
(define (atm-position a) (a 'position #f))
(define (atm-add-pos a x) (a 'add-pos x))
(define (atm-set-pos a x) (a 'set-pos x))
(define (atm-velocity a) (a 'velocity #f))
(define (atm-add-velocity a v) (a 'add-velocity v))
(define (atm-set-velocity a v) (a 'set-velocity v))
(define (atm-zero-velocity a) (a 'zero-velocity #f))
(define (atm-force a) (a 'force #f))
(define (atm-zero-force a) (a 'zero-force #f))
(define (atm-add-force a x) (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) (b 'order))
(define (bond-first b) (b 'first))
(define (bond-second b) (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) (e 'name))
(define (element-rvdw e) (e 'rvdw))
(define (element-mass e) (e 'mass))
(define (element-total-bonds e) (e 'total-bonds))
(define (element-initial-hybridization e) (e 'initial-hybridization))
(define (element-how-to-hybridize e) (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) (s 'name))
(define (species-hybridization s) (s 'hybridization))
(define (species-evdw s) (s 'evdw))
(define (species-mm2index s) (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) (bc 'singles))
(define (bond-count-doubles bc) (bc 'doubles))
(define (bond-count-triples bc) (bc 'triples))
(define (bond-count-total-bonds bc) (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) (dd 'diff))
(define (dd-dist dd) (dd 'distance))
#else
(defstruct atm element species position velocity force)
(defun create-atm (e p)
(let ((a (make-atm :element e :position p
:velocity '#(0.0 0.0 0.0) :force '#(0.0 0.0 0.0))))
(setf (atm-species a)
(lookup-species (element-name e)
(element-initial-hybridization e)))
a))
(defun atm-set-species (a s) (setf (atm-species a) s))
(defun atm-add-pos (a x)
(setf (atm-position a)
(vplus x (atm-position a))))
(defun atm-set-pos (a s) (setf (atm-position a) s))
(defun atm-add-velocity (a v)
(setf (atm-velocity a)
(vplus v (atm-velocity a))))
(defun atm-set-velocity (a s) (setf (atm-velocity a) s))
(defun atm-zero-velocity (a) (setf (atm-velocity a) '#(0.0 0.0 0.0)))
(defun atm-zero-force (a) (setf (atm-force a) '#(0.0 0.0 0.0)))
(defun atm-add-force (a v)
(setf (atm-force a)
(vplus v (atm-force a))))
(defstruct bond order first second)
(defun create-bond (ord f s) (make-bond :order ord :first f :second s))
(defstruct element
name rvdw mass total-bonds initial-hybridization how-to-hybridize)
(defun 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))
(defstruct species name hybridization evdw mm2index)
(defun create-species (name hybrid evdw mm2)
(make-species :name name :hybridization hybrid :evdw evdw :mm2index mm2))
(defstruct bond-count singles doubles triples total-bonds)
(defun create-bond-count (n)
(let ((bc (make-bond-count :singles 0 :doubles 0 :triples 0 :total-bonds 0)))
(dolist (bond bond-list)
(if (or (= n (bond-first bond)) (= n (bond-second bond)))
(case (bond-order bond)
(1 (incf (bond-count-singles bc)))
(2 (incf (bond-count-doubles bc)))
(t (incf (bond-count-triples bc))))))
(setf (bond-count-total-bonds bc)
(+ (bond-count-singles bc)
(* 2 (bond-count-doubles bc))
(* 3 (bond-count-triples bc))))
bc))
(defstruct dd diff dist)
(defun create-diff-dist (m n)
(let* ((dif (vdiff (atm-position m) (atm-position n))))
(make-dd :diff dif :dist (vlen dif))))
#endif
(load "ncad022.scm")
|