mirror of
https://github.com/NGSolve/netgen.git
synced 2024-11-11 16:49:16 +05:00
91 lines
2.4 KiB
Tcl
91 lines
2.4 KiB
Tcl
#!/bin/sh
|
|
# the next line restarts using tclsh \
|
|
exec tclsh "$0" "$@"
|
|
|
|
# Togl - a Tk OpenGL widget
|
|
# Copyright (C) 1996-1997 Brian Paul and Ben Bederson
|
|
# Copyright (C) 2006-2007 Greg Couch
|
|
# See the LICENSE file for copyright details.
|
|
|
|
|
|
#
|
|
# Test Togl using GL Gears Demo
|
|
#
|
|
# Copyright (C) 1997 Philip Quaife
|
|
#
|
|
|
|
package provide gears 1.0
|
|
|
|
# add parent directory to path to find Togl's pkgIndex in current directory
|
|
if { [file exists pkgIndex.tcl] } {
|
|
set auto_path [linsert $auto_path 0 ..]
|
|
}
|
|
# following load also loads Tk and Togl packages
|
|
load [file dirname [info script]]/gears[info sharedlibextension]
|
|
|
|
# create ::gears namespace
|
|
namespace eval ::gears {
|
|
}
|
|
|
|
proc ::gears::setup {} {
|
|
global startx starty xangle0 yangle0 xangle yangle RotCnt
|
|
global vTime
|
|
set RotCnt 1
|
|
set xangle 0.0
|
|
set yangle 0.0
|
|
set vTime 100
|
|
wm title . "Rotating Gear Widget Test"
|
|
|
|
label .t -text "Click and drag to rotate image"
|
|
pack .t -side top -padx 2 -pady 10
|
|
frame .f
|
|
pack .f -side top
|
|
button .f.n1 -text " Add " -command ::gears::AutoRot
|
|
button .f.r1 -text "Remove" -command ::gears::DelRot
|
|
button .f.b1 -text " Quit " -command exit
|
|
entry .f.t -width 4 -textvariable vTime
|
|
pack .f.n1 .f.t .f.r1 .f.b1 -side left -anchor w -padx 5
|
|
newRot .w0 10
|
|
|
|
}
|
|
proc ::gears::AutoRot {} {
|
|
global RotCnt vTime
|
|
newRot .w$RotCnt $vTime
|
|
set RotCnt [expr $RotCnt + 1]
|
|
}
|
|
|
|
proc ::gears::DelRot {} {
|
|
global RotCnt vTime
|
|
if { $RotCnt != 0 } {
|
|
set RotCnt [expr $RotCnt - 1]
|
|
destroy .w$RotCnt
|
|
}
|
|
}
|
|
|
|
proc ::gears::newRot {win {tick 100} } {
|
|
togl $win -width 200 -height 200 -rgba true -double true -depth true -privatecmap false -time $tick -create init -destroy zap -display draw -reshape reshape -timer idle
|
|
bind $win <ButtonPress-1> {::gears::RotStart %x %y %W}
|
|
bind $win <B1-Motion> {::gears::RotMove %x %y %W}
|
|
pack $win -expand true -fill both
|
|
}
|
|
|
|
proc ::gears::RotStart {x y W} {
|
|
global startx starty xangle0 yangle0 xangle yangle
|
|
set startx $x
|
|
set starty $y
|
|
set vPos [position $W]
|
|
set xangle0 [lindex $vPos 0]
|
|
set yangle0 [lindex $vPos 1]
|
|
}
|
|
|
|
proc ::gears::RotMove {x y W} {
|
|
global startx starty xangle0 yangle0 xangle yangle
|
|
set xangle [expr $xangle0 + ($x - $startx)]
|
|
set yangle [expr $yangle0 + ($y - $starty)]
|
|
rotate $W $xangle $yangle
|
|
}
|
|
|
|
if { [info script] == $argv0 } {
|
|
::gears::setup
|
|
}
|