ncad023b
|
compile-lisp.lsp,
forces.scm,
format.scm,
gambit.scm,
gui-1.scm,
gui-2.lsp,
gui-2.mrd,
gui-2.tcl,
hackv.scm,
hackw.scm,
lisp.lsp,
make-tgz,
mred.scm,
mzscheme.scm,
ncad023.scm,
run-c-clisp.lsp,
run-c-gcl.lsp,
run-clisp.lsp,
run-gambit.scm,
run-mred.scm,
run-mz-nogui.scm,
strcase.scm,
|
|
|
;; gui-2.mrd - Implementation-dependent GUI code, MrEd
;; 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 .
(define my-frame%
(make-class wx:frame%
(public
(on-size (lambda (w h) '()))
(change-resize-function
(lambda (f)
(set! on-size f))))))
(define my-canvas%
(make-class wx:canvas%
(private
(which-button 0))
(public
(on-event
(lambda (event)
(let ((which-button
(cond ((send event button? 1) 1)
((send event button? 2) 2)
(else 3)))
(x (send event get-x))
(y (send event get-y)))
(cond ((send event button-down? -1)
(set! current-mouse-button which-button)
(press-function-b x y))
((send event button-up? -1)
(release-function-b x y)
(set! current-mouse-button #f))
((and current-mouse-button
(send event dragging?))
(drag-function-b x y))
(else #f))))))))
;; annoying little hack, because the name of the command changed after
;; version 42
(if (equal? (version) "42")
(define (get-cursor-hack panel u v)
(send panel get-cursor u v))
(define (get-cursor-hack panel u v)
(send panel get-item-cursor u v)))
(define session%
(class () ()
(public
(PANEL-WIDTH
(if (eq? (system-type) 'unix) 530 390))
(PANEL-HEIGHT
(if (eq? (system-type) 'unix) 200 230))
(CANVAS-WIDTH 400)
(CANVAS-HEIGHT 400)
(a-frame
(make-object my-frame%
'() ; No parent frame
"NanoCAD Control Panel"
-1 -1 ; Use the default position
PANEL-WIDTH PANEL-HEIGHT))
(b-frame
(make-object my-frame%
'() ; No parent frame
"NanoCAD Structure View"
-1 -1 ; Use the default position
CANVAS-WIDTH CANVAS-HEIGHT))
(canvas-height 10)
(canvas-width 10)
(canvas
(make-object my-canvas%
b-frame
0 0
canvas-width canvas-height
wx:const-retained ""))
(canvas-dc
(send canvas get-dc))
(awaken
(lambda ()
(send a-frame show #t)
(send b-frame show #t)))
(snooze
(lambda ()
(send canvas-dc end-drawing)
(send a-frame show #f)
(send b-frame show #f))))
(private
(carbon-brush
(make-object wx:brush% "BLACK" wx:const-solid))
(hydrogen-brush
(make-object wx:brush% "WHITE" wx:const-solid))
(oxygen-brush
(make-object wx:brush% "RED" wx:const-solid))
(nitrogen-brush
(make-object wx:brush% "BLUE" wx:const-solid))
(normal-pen
(make-object wx:pen% "BLACK" 1 wx:const-solid))
(double-bond-pen
(make-object wx:pen% "BLACK" 3 wx:const-solid))
(triple-bond-pen
(make-object wx:pen% "BLACK" 5 wx:const-solid))
(force-vector-pen
(make-object wx:pen% "RED" 1 wx:const-solid))
(a-panel
(make-object wx:panel%
a-frame
0 0 PANEL-WIDTH PANEL-HEIGHT))
(load-button
(make-object wx:button%
a-panel
(lambda (self event)
(load-structure (wx:file-selector ""))
(update-display #t))
"Load"))
(save-button
(make-object wx:button%
a-panel
(lambda (self event)
(save-structure (wx:file-selector ""))
(update-display #t))
"Save"))
(save-xyz-button
(make-object wx:button%
a-panel
(lambda (self event)
(save-structure-xyz (wx:file-selector ""))
(update-display #t))
"SaveXYZ"))
(clear-button
(make-object wx:button%
a-panel
(lambda (self event)
(clear-structure)
(update-display #t))
"Clear"))
(emin-button
(make-object wx:button%
a-panel
(lambda (self event)
(emin-step)
(update-display #t))
"Emin"))
(hide-button
(make-object wx:button%
a-panel
(lambda (self event)
(snooze))
"HideGUI")))
(sequence
(send a-panel new-line))
(private
(show-forces-checkbox
(make-object wx:check-box%
a-panel
(lambda (self event)
(set! draw-force-vectors (send event checked?))
(update-display #t))
"Show Force Vectors"))
(use-torsion-checkbox
(make-object wx:check-box%
a-panel
(lambda (self event)
(set! use-torsion-forces (send event checked?)))
"Use Torsion Forces"))
(use-vdw-checkbox
(make-object wx:check-box%
a-panel
(lambda (self event)
(set! use-vdw-forces (send event checked?)))
"Use VDW Forces")))
(sequence
(send a-panel new-line))
(public
(select-pen
(lambda (n)
(case n
('force-vector (send canvas-dc set-pen force-vector-pen))
('double-bond (send canvas-dc set-pen double-bond-pen))
('triple-bond (send canvas-dc set-pen triple-bond-pen))
(else (send canvas-dc set-pen normal-pen)))))
(atom-color
(lambda (element-name)
(cond
((equal? element-name "C")
(send canvas-dc set-brush carbon-brush))
((equal? element-name "H")
(send canvas-dc set-brush hydrogen-brush))
((equal? element-name "O")
(send canvas-dc set-brush oxygen-brush))
(else
(send canvas-dc set-brush nitrogen-brush)))))
(re-center
(lambda ()
(set! center-x (* 0.5 canvas-width))
(set! center-y (* 0.5 canvas-height))))
(draw-line
(lambda (x1 y1 x2 y2)
(send canvas-dc draw-line x1 y1 x2 y2)))
(draw-ellipse
(lambda (x1 y1 d)
(send canvas-dc draw-ellipse x1 y1 d d)))
(delete-all
(lambda ()
(send canvas-dc clear))))
(private
(mode-selector
(make-object wx:radio-box%
a-panel
(lambda (self event)
(let ((n (send event get-command-int)))
(case n
(0 (set-action 'rotate))
(1 (set-action 'moveatom))
(2 (set-action 'addatom))
(3 (set-action 'deleteatom))
(4 (set-action 'addbond))
(5 (set-action 'deletebond)))))
""
-1 -1 -1 -1
(list "Rotate" "MoveAtom" "AddAtom" "DeleteAtom"
"AddBond" "DeleteBond")))
(bond-order-selector
(make-object wx:radio-box%
a-panel
(lambda (self event)
(let ((n (send event get-command-int)))
(set! current-bond-order (+ n 1))))
"Bond"
-1 -1 -1 -1
(list "Single" "Double" "Triple")))
(element-selector
(make-object wx:radio-box%
a-panel
(lambda (self event)
(let ((n (send event get-command-int)))
(case n
(0 (set! current-element "C"))
(1 (set! current-element "H"))
(2 (set! current-element "O"))
(else (set! current-element "N")))))
""
-1 -1 -1 -1
(list "Carbon" "Hydrogen" "Oxygen" "Nitrogen")))
(zoom-factor
(make-object wx:radio-box%
a-panel
(lambda (self event)
(let ((n (send event get-command-int)))
(case n
(0 (set-zoomfactor 10.0))
(1 (set-zoomfactor 25.0))
(2 (set-zoomfactor 50.0))
(else (set-zoomfactor 100.0))))
(update-display #t))
"Zoom"
-1 -1 -1 -1
(list "10" "25" "50" "100")))
(emin-convergence
(make-object wx:radio-box%
a-panel
(lambda (self event)
(let ((n (send event get-command-int)))
(case n
(0 (set! emin-factor fine-emin-factor))
(else (set! emin-factor coarse-emin-factor)))))
"Emin"
-1 -1 -1 -1
(list "Fine" "Coarse"))))
(sequence
(send a-panel new-line)
(send a-panel fit))
(public
(force-rotate-mode
(lambda ()
(send mode-selector set-selection 0)
(set! press-function rotate-press)
(set! drag-function rotate-drag)
(set! release-function rotate-release))))
(private
(canvas-y
(let ((u (box 0)) (v (box 0)))
(get-cursor-hack a-panel u v)
(unbox v)))
(resize-canvas
(lambda (w h)
;; (set! canvas-height (- h canvas-y))
(set! canvas-height h)
(set! canvas-width w)
(set! canvas
(make-object my-canvas%
b-frame
;; 0 canvas-y
0 0
canvas-width canvas-height
wx:const-retained ""))
(send canvas-dc end-drawing)
(set! canvas-dc
(send canvas get-dc))
(send canvas-dc begin-drawing)
(update-display #t))))
(sequence
(set! error-msg
(lambda (txt)
(send canvas-dc draw-text txt 10 10)))
(set! warning-msg
(lambda (txt)
(send canvas-dc draw-text txt 10 20)))
(set-scale-factor 25.0)
(send zoom-factor set-selection 1)
(send use-vdw-checkbox set-value #t)
(send b-frame change-resize-function resize-canvas)
(re-center)
(awaken)
(send canvas-dc begin-drawing))))
(define (delete-all)
(if this-session
((ivar this-session delete-all))))
(define (atom-color z)
((ivar this-session atom-color) z))
(define (select-pen z)
((ivar this-session select-pen) z))
(define (draw-line x1 y1 x2 y2)
((ivar this-session draw-line) x1 y1 x2 y2))
(define (draw-ellipse x1 y1 d)
((ivar this-session draw-ellipse) x1 y1 d))
(define (re-center)
((ivar this-session re-center)))
(define (show-gui)
(if (not this-session)
(set! this-session (make-object session%))
(send this-session awaken)))
(define (hide-gui) (send this-session snooze))
(define (force-rotate-mode) (send this-session force-rotate-mode))
|