ncad023a
|
Makefile,
RCS,
README,
cl-nogui.lsp,
compile.lsp,
config.lsp,
contrib,
diamondoid,
feedback-317,
forces.scm,
gambit.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-2.tcl - Tcl code for communicating with CLISP, NanoCAD GUI
# 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 .
toplevel .w
wm title . "NanoCAD Structure Viewer"
wm title .w "NanoCAD Control Panel"
frame .w.f1
frame .w.f2
frame .w.f3
frame .w.f3.sf1 -relief groove -borderwidth 4
frame .w.f3.sf2 -relief groove -borderwidth 4
frame .w.f3.sf3 -relief groove -borderwidth 4
frame .w.f3.sf4 -relief groove -borderwidth 4
frame .w.f3.sf5 -relief groove -borderwidth 4
############################
button .w.f1.b1 -text Load -command {talk_to_lisp "(load)"}
button .w.f1.b2 -text Save -command {talk_to_lisp "(save)"}
button .w.f1.b3 -text SaveXYZ -command {talk_to_lisp "(savexyz)"}
button .w.f1.b4 -text SavePS -command {canvas_ps cl-gui.ps}
button .w.f1.b5 -text Clear -command {talk_to_lisp "(clear)"}
button .w.f1.b6 -text Emin -command {talk_to_lisp "(emin)"}
button .w.f1.b7 -text HideGUI -command \
{puts stdout "exit"; flush stdout; after 5 destroy .}
############################
set show_force 0
set use_torsion 0
set use_vdw 0
checkbutton .w.f2.cb1 -text "Show Force Vectors" -variable show_force \
-command update_options
checkbutton .w.f2.cb2 -text "Use Torsion Forces" -variable use_torsion \
-command update_options
checkbutton .w.f2.cb3 -text "Use VDW Forces" -variable use_vdw \
-command update_options
############################
set action rotate
radiobutton .w.f3.sf1.rb1 -text Rotate \
-variable action -value rotate -anchor w -command update_controls
radiobutton .w.f3.sf1.rb2 -text MoveAtom \
-variable action -value moveatom -anchor w -command update_controls
radiobutton .w.f3.sf1.rb3 -text AddAtom \
-variable action -value addatom -anchor w -command update_controls
radiobutton .w.f3.sf1.rb4 -text DeleteAtom \
-variable action -value deleteatom -anchor w -command update_controls
radiobutton .w.f3.sf1.rb5 -text AddBond \
-variable action -value addbond -anchor w -command update_controls
radiobutton .w.f3.sf1.rb6 -text DeleteBond \
-variable action -value deletebond -anchor w -command update_controls
pack .w.f3.sf1.rb1 .w.f3.sf1.rb2 .w.f3.sf1.rb3 \
.w.f3.sf1.rb4 .w.f3.sf1.rb5 .w.f3.sf1.rb6 -side top
############################
set bondorder single
label .w.f3.sf2.lbl -text Bond
radiobutton .w.f3.sf2.rb1 -text Single \
-variable bondorder -value single -anchor w -command update_controls
radiobutton .w.f3.sf2.rb2 -text Double \
-variable bondorder -value double -anchor w -command update_controls
radiobutton .w.f3.sf2.rb3 -text Triple \
-variable bondorder -value triple -anchor w -command update_controls
pack .w.f3.sf2.lbl \
.w.f3.sf2.rb1 .w.f3.sf2.rb2 .w.f3.sf2.rb3 -side top
############################
set element C
radiobutton .w.f3.sf3.rb1 -text Carbon \
-variable element -value C -anchor w -command update_controls
radiobutton .w.f3.sf3.rb2 -text Hydrogen \
-variable element -value H -anchor w -command update_controls
radiobutton .w.f3.sf3.rb3 -text Oxygen \
-variable element -value O -anchor w -command update_controls
radiobutton .w.f3.sf3.rb4 -text Nitrogen \
-variable element -value N -anchor w -command update_controls
pack .w.f3.sf3.rb1 .w.f3.sf3.rb2 .w.f3.sf3.rb3 .w.f3.sf3.rb4 -side top
############################
set zoomfactor 25
label .w.f3.sf4.lbl -text Zoom
radiobutton .w.f3.sf4.rb1 -text 10 \
-variable zoomfactor -value 10 -anchor w -command update_controls
radiobutton .w.f3.sf4.rb2 -text 25 \
-variable zoomfactor -value 25 -anchor w -command update_controls
radiobutton .w.f3.sf4.rb3 -text 50 \
-variable zoomfactor -value 50 -anchor w -command update_controls
radiobutton .w.f3.sf4.rb4 -text 100 \
-variable zoomfactor -value 100 -anchor w -command update_controls
pack .w.f3.sf4.lbl \
.w.f3.sf4.rb1 .w.f3.sf4.rb2 .w.f3.sf4.rb3 .w.f3.sf4.rb4 -side top
############################
set eminspeed fine
label .w.f3.sf5.lbl -text Emin
radiobutton .w.f3.sf5.rb1 -text Coarse \
-variable eminspeed -value coarse -anchor w -command update_controls
radiobutton .w.f3.sf5.rb2 -text Fine \
-variable eminspeed -value fine -anchor w -command update_controls
pack .w.f3.sf5.lbl .w.f3.sf5.rb1 .w.f3.sf5.rb2 -side top
############################
pack .w.f1.b1 .w.f1.b2 .w.f1.b3 .w.f1.b4 .w.f1.b5 .w.f1.b6 .w.f1.b7 -side left
pack .w.f2.cb1 .w.f2.cb2 .w.f2.cb3 -side left
pack .w.f3.sf1 .w.f3.sf2 .w.f3.sf3 .w.f3.sf4 .w.f3.sf5 -side left
pack .w.f1 .w.f2 .w.f3
############################
set cansize 400
canvas .can -width $cansize -height $cansize
bind .can {
talk_to_lisp "(press-1 %x %y)"
}
bind .can {
talk_to_lisp "(move-1 %x %y)"
}
bind .can {
talk_to_lisp "(release-1 %x %y)"
}
pack .can -side left -expand yes -fill both
proc update_options { } {
global show_force
global use_torsion
global use_vdw
talk_to_lisp "(options $show_force $use_torsion $use_vdw)"
}
proc update_controls { } {
global action
global bondorder
global element
global zoomfactor
global eminspeed
talk_to_lisp "(controls $action $bondorder $element \
$zoomfactor $eminspeed)"
}
set pen_color black
set pen_width 1
proc set_color { c } {
global pen_color
set pen_color $c
}
proc set_pen { c w } {
global pen_color
global pen_width
set pen_color $c
set pen_width $w
}
proc delete_erasable { } {
.can delete erasable
}
proc create_line { x1 y1 x2 y2 } {
global pen_color
global pen_width
.can create line $x1 $y1 $x2 $y2 -width $pen_width \
-fill $pen_color -tags erasable
}
proc create_ellipse { x1 y1 x2 y2 } {
global pen_color
.can create oval $x1 $y1 $x2 $y2 -fill $pen_color -tags erasable
}
proc canvas_ps { fname } {
.can postscript -file $fname
}
proc talk_to_lisp { cmd } {
puts stdout $cmd
flush stdout
# accept one or more commands from Lisp, and execute them
set ex ""
for { gets stdin i } { [string compare @ $i] != 0 } \
{ gets stdin i } { set ex "$ex\n$i" }
foreach b $ex { eval $b }
}
talk_to_lisp "(startup)"
update_controls
update_options
|