1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
#!/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
}
|
