ncad023
|
Makefile,
RCS,
README,
cl-nogui.lsp,
compile.lsp,
config.lsp,
contrib,
forces.scm,
gui-1.scm,
gui-2.lsp,
gui-2.mrd,
gui-2.tcl,
hackv.scm,
helper,
lisp.lsp,
lispd.lsp,
make-tgz,
make-zip,
methane,
mred.scm,
mz-nogui.scm,
ncad023.scm,
propane,
run-clisp.lsp,
run-mred.scm,
scheme.scm,
test.scm,
trial,
|
|
|
;; gui-1.scm - Implementation-independent GUI code for NanoCAD
;; Copyright (C) 1996,1997 Will Ware
;;
;; 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 2
;; 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.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; I can be reached via email at .
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GUI variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define center-x false)
(define center-y false)
(define start-mouse ())
(define selected-atom 0)
(define current-element "C")
(define current-bond-order 1)
(define atom-drawing-diameter 15)
(define draw-force-vectors false)
(define current-mouse-button false)
(define scale-factor 25.0)
(define (atom-color z) false) ;; redefine these in gui-2.xxx
(define (select-pen z) false)
(define (delete-all) false)
(define (draw-ellipse x1 y1 d) false)
(define (draw-line x1 y1 x2 y2) false)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-scale-factor x) (set! scale-factor x))
(define (su2a x) (/ x scale-factor))
(define (a2su x) (* x scale-factor))
(define (select-atom x y)
(set! x (su2a x))
(set! y (su2a y))
(do ((n false)
(i 0 (+ i 1))
(p 0.0)
(sq-dist 0.0)
(min-sq-dist 0.0)
(L atom-list (cdr L)))
((null? L) n)
(set! p (- x (vector-ref (atm-position (car L)) 0)))
(set! sq-dist (* p p))
(set! p (- y (vector-ref (atm-position (car L)) 1)))
(set! sq-dist (+ sq-dist (* p p)))
(if (or (not n) (< sq-dist min-sq-dist))
(let ()
(set! min-sq-dist sq-dist)
(set! n i)))))
(define (move-atom n x y)
(let ((a (list-ref atom-list n)))
(atm-set-pos a
(vector (su2a x)
(su2a y)
(vector-ref (atm-position a) 2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Drawing Lists, z-sorting
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (select-an-atom x y)
(set! selected-atom
(select-atom (- x center-x)
(- y center-y))))
(define (rotate-press x y)
(center-structure)
(set! start-mouse (list x y)))
(define (rotate-drag x y)
(rotate-structure
(* 0.01 (- x (car start-mouse)))
(* -0.01 (- y (cadr start-mouse))))
(set! start-mouse (list x y))
(update-display false))
(define (rotate-release x y)
(update-display true))
(define (moveatom-drag x y)
(move-atom selected-atom
(- x center-x)
(- y center-y))
(update-display true))
(define (addatom-press x y)
(let ((x1 (- x center-x))
(y1 (- y center-y)))
(add-atom current-element
(vector (su2a (- x center-x)) (su2a (- y center-y)) 0.0))
(update-display true)))
(define (deleteatom-press x y)
(select-an-atom x y)
(delete-atom selected-atom)
(update-display true))
(define (deletebond-release x y)
(let ((n selected-atom))
(select-an-atom x y)
(delete-bond n selected-atom)
(update-display true)))
(define (addbond-release x y)
(let ((n selected-atom))
(select-an-atom x y)
(if (not (= n selected-atom))
(add-bond current-bond-order selected-atom n))
(update-display true)))
(define (do-nothing x y) '())
(define press-function (func rotate-press))
(define drag-function (func rotate-drag))
(define release-function (func rotate-release))
;; For now, pay attention only to the left mouse button
(define (press-function-b x y)
(if (eq? current-mouse-button 1)
(press-function x y)))
(define (drag-function-b x y)
(if (eq? current-mouse-button 1)
(drag-function x y)))
(define (release-function-b x y)
(if (eq? current-mouse-button 1)
(release-function x y)))
(define (create-draw-object type x1 y1 x2 y2 z xf yf pen element)
(make-lambda (x)
(case x
('type type)
('x1 x1)
('y1 y1)
('x2 x2)
('y2 y2)
('z z)
('xf xf)
('yf yf)
('pen pen)
('element element))))
(define (wireframe-drawing-list)
(entering "wireframe-drawing-list")
(let ((DL '()))
(dolist
(bond bond-list)
(let ((pos1 (atm-position (list-ref atom-list
(bond-first bond))))
(pos2 (atm-position (list-ref atom-list
(bond-second bond)))))
(set! DL
(cons
(create-draw-object
'bond
(a2su (vector-ref pos1 0))
(a2su (vector-ref pos1 1))
(a2su (vector-ref pos2 0))
(a2su (vector-ref pos2 1))
false false false 'normal false)
DL))))
DL))
(define (detailed-drawing-list)
(entering "detailed-drawing-list")
;; the first thing we'll be doing is sorting the drawing list by Z
;; coordinates, so compute them for bonds first, then for atoms
(let ((DL '()))
(dbgprintf "detailed-drawing-list: bonds~%")
(dolist
(bond bond-list)
(let* ((pos1 (atm-position (list-ref atom-list
(bond-first bond))))
(pos2 (atm-position (list-ref atom-list
(bond-second bond))))
(p1 (vector (a2su (vector-ref pos1 0))
(a2su (vector-ref pos1 1))
(a2su (vector-ref pos1 2))))
(p2 (vector (a2su (vector-ref pos2 0))
(a2su (vector-ref pos2 1))
(a2su (vector-ref pos2 2))))
;; (g (* 0.5 (/ atom-drawing-diameter (vlen (vdiff p1 p2)))))
(g (* 0.3 (/ atom-drawing-diameter (vlen (vdiff p1 p2)))))
(x1 (+ (* (- 1.0 g) (vector-ref p1 0))
(* g (vector-ref p2 0))))
(y1 (+ (* (- 1.0 g) (vector-ref p1 1))
(* g (vector-ref p2 1))))
(x2 (+ (* (- 1.0 g) (vector-ref p2 0))
(* g (vector-ref p1 0))))
(y2 (+ (* (- 1.0 g) (vector-ref p2 1))
(* g (vector-ref p1 1)))))
(dbgprintf "pos1: ~s pos2: ~s~%" pos1 pos2)
(set! DL
(cons
(create-draw-object
'bond x1 y1 x2 y2
(* 0.5 (+ (vector-ref pos1 2) (vector-ref pos2 2)))
false false
(case (bond-order bond)
(2 'double-bond)
(3 'triple-bond)
(else 'normal))
false)
DL))))
(dbgprintf "detailed-drawing-list: atoms~%")
(dolist (atom atom-list)
(let ((atm-pos (atm-position atom))
(atm-frc (atm-force atom)))
(set! DL
(cons
(create-draw-object
'atom
(a2su (vector-ref atm-pos 0))
(a2su (vector-ref atm-pos 1))
false
false
(vector-ref atm-pos 2)
(* 0.05 (a2su (vector-ref atm-frc 0)))
(* 0.05 (a2su (vector-ref atm-frc 1)))
'normal
(atm-element atom))
DL))))
(dbgprintf "detailed-drawing-list: sorting~%")
(qsort DL (lambda (x y) (< (funcall x 'z) (funcall y 'z))))))
;; >>>>> In Scheme, we want to use quicksort instead of sort. <<<<<<<<
(set! center-x 200)
(set! center-y 200)
(define (update-display full-blown)
(entering "update-display")
(delete-all)
(re-center)
(if full-blown
(let ((DL '())
(minus-half-diameter (* -0.5 atom-drawing-diameter)))
(if draw-force-vectors (compute-forces))
(set! DL (detailed-drawing-list))
(mapcar
(make-lambda (z)
(if (eq? (funcall z 'type) 'atom)
(let ()
(atom-color
(funcall (funcall z 'element) 'name))
(draw-ellipse
(+ (funcall z 'x1) center-x minus-half-diameter)
(+ (funcall z 'y1) center-y minus-half-diameter)
atom-drawing-diameter)
(if draw-force-vectors
(let ()
(select-pen 'force-vector)
(draw-line
(+ center-x (funcall z 'x1))
(+ center-y (funcall z 'y1))
(+ center-x
(funcall z 'x1) (funcall z 'xf))
(+ center-y
(funcall z 'y1) (funcall z 'yf)))))
(select-pen 'normal))
(let ()
(select-pen (funcall z 'pen))
(draw-line (+ center-x (funcall z 'x1))
(+ center-y (funcall z 'y1))
(+ center-x (funcall z 'x2))
(+ center-y (funcall z 'y2)))
(select-pen 'normal))))
DL))
(mapcar
(make-lambda (z)
(draw-line (+ center-x (funcall z 'x1))
(+ center-y (funcall z 'y1))
(+ center-x (funcall z 'x2))
(+ center-y (funcall z 'y2))))
(wireframe-drawing-list))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Control Panel Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-action a)
(case a
(rotate
(set! press-function (func rotate-press))
(set! drag-function (func rotate-drag))
(set! release-function (func rotate-release)))
(moveatom
(set! press-function (func select-an-atom))
(set! drag-function (func moveatom-drag))
(set! release-function (func do-nothing)))
(addatom
(set! press-function (func addatom-press))
(set! drag-function (func do-nothing))
(set! release-function (func do-nothing)))
(deleteatom
(set! press-function (func deleteatom-press))
(set! drag-function (func do-nothing))
(set! release-function (func do-nothing)))
(addbond
(set! press-function (func select-an-atom))
(set! drag-function (func do-nothing))
(set! release-function (func addbond-release)))
(deletebond
(set! press-function (func select-an-atom))
(set! drag-function (func do-nothing))
(set! release-function (func deletebond-release)))))
(define (set-zoomfactor z)
(if (not (= z scale-factor))
(let ()
(cond ((= z 10)
(set! scale-factor 10.0)
(set! atom-drawing-diameter 6))
((= z 25)
(set! scale-factor 25.0)
(set! atom-drawing-diameter 15))
((= z 50)
(set! scale-factor 50.0)
(set! atom-drawing-diameter 30))
((= z 100)
(set! scale-factor 100.0)
(set! atom-drawing-diameter 60)))
(update-display true))))
|