# tcl3dGears.tcl
#
# Test Togl using GL Gears Demo
#
# This is a version of the original Togl gears demo written entirely in Tcl
# with the help of the Tcl3D package.
#
# Copyright (C) 1997 Philip Quaife (Original C/Tcl version)
# Copyright (C) 2005-2022 Paul Obermeier (Tcl3D version)
# See the LICENSE file for copyright details.
#
# Original sources available at: http://sourceforge.net/projects/togl/
package require tcl3d
set M_PI 3.14159265
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
proc gear { inner_radius outer_radius width teeth tooth_depth } {
set r0 $inner_radius
set r1 [expr $outer_radius - $tooth_depth / 2.0]
set r2 [expr $outer_radius + $tooth_depth / 2.0]
set da [expr 2.0 * $::M_PI / $teeth / 4.0]
glShadeModel GL_FLAT
glNormal3f 0.0 0.0 1.0
glBegin GL_QUAD_STRIP
for { set i 0 } { $i <= $teeth } { incr i } {
set angle [expr $i * 2.0 * $::M_PI / $teeth]
glVertex3f [expr $r0 * cos($angle)] \
[expr $r0 * sin($angle)] \
[expr $width * 0.5]
glVertex3f [expr $r1 * cos($angle)] \
[expr $r1 * sin($angle)] \
[expr $width * 0.5]
glVertex3f [expr $r0 * cos($angle)] \
[expr $r0 * sin($angle)] \
[expr $width * 0.5]
glVertex3f [expr $r1 * cos($angle + 3 * $da)] \
[expr $r1 * sin($angle + 3 * $da)] \
[expr $width * 0.5]
}
glEnd
glBegin GL_QUADS
set da [expr 2.0 * $::M_PI / $teeth / 4.0]
for { set i 0 } { $i < $teeth } { incr i } {
set angle [expr $i * 2.0 * $::M_PI / $teeth]
glVertex3f [expr $r1 * cos($angle)] \
[expr $r1 * sin($angle)] \
[expr $width * 0.5]
glVertex3f [expr $r2 * cos($angle + $da)] \
[expr $r2 * sin($angle + $da)] \
[expr $width * 0.5]
glVertex3f [expr $r2 * cos($angle + 2 * $da)] \
[expr $r2 * sin($angle + 2 * $da)] \
[expr $width * 0.5]
glVertex3f [expr $r1 * cos($angle + 3 * $da)] \
[expr $r1 * sin($angle + 3 * $da)] \
[expr $width * 0.5]
}
glEnd
glNormal3f 0.0 0.0 -1.0
glBegin GL_QUAD_STRIP
for { set i 0 } { $i <= $teeth } { incr i } {
set angle [expr $i * 2.0 * $::M_PI / $teeth]
glVertex3f [expr $r1 * cos($angle)] \
[expr $r1 * sin($angle)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r0 * cos($angle)] \
[expr $r0 * sin($angle)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r1 * cos($angle + 3 * $da)] \
[expr $r1 * sin($angle + 3 * $da)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r0 * cos($angle)] \
[expr $r0 * sin($angle)] \
[expr -1.0 * $width * 0.5]
}
glEnd
glBegin GL_QUADS
set da [expr 2.0 * $::M_PI / $teeth / 4.0]
for { set i 0 } { $i < $teeth } { incr i } {
set angle [expr $i * 2.0 * $::M_PI / $teeth]
glVertex3f [expr $r1 * cos($angle + 3 * $da)] \
[expr $r1 * sin($angle + 3 * $da)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r2 * cos($angle + 2 * $da)] \
[expr $r2 * sin($angle + 2 * $da)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r2 * cos($angle + $da)] \
[expr $r2 * sin($angle + $da)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r1 * cos($angle)] \
[expr $r1 * sin($angle)] \
[expr -1.0 * $width * 0.5]
}
glEnd
glBegin GL_QUAD_STRIP
for { set i 0 } { $i < $teeth } { incr i } {
set angle [expr $i * 2.0 * $::M_PI / $teeth]
glVertex3f [expr $r1 * cos($angle)] \
[expr $r1 * sin($angle)] \
[expr $width * 0.5]
glVertex3f [expr $r1 * cos($angle)] \
[expr $r1 * sin($angle)] \
[expr -1.0 * $width * 0.5]
set u [expr $r2 * cos($angle + $da) - $r1 * cos($angle)]
set v [expr $r2 * sin($angle + $da) - $r1 * sin($angle)]
set len [expr sqrt($u * $u + $v * $v)]
set u [expr $u / $len]
set v [expr $v / $len]
glNormal3f $v [expr -1.0 * $u] 0.0
glVertex3f [expr $r2 * cos($angle + $da)] \
[expr $r2 * sin($angle + $da)] \
[expr $width * 0.5]
glVertex3f [expr $r2 * cos($angle + $da)] \
[expr $r2 * sin($angle + $da)] \
[expr -1.0 * $width * 0.5]
glNormal3f [expr cos($angle)] [expr sin($angle)] 0.0
glVertex3f [expr $r2 * cos($angle + 2 * $da)] \
[expr $r2 * sin($angle + 2 * $da)] \
[expr $width * 0.5]
glVertex3f [expr $r2 * cos($angle + 2 * $da)] \
[expr $r2 * sin($angle + 2 * $da)] \
[expr -1.0 * $width * 0.5]
set u [expr $r1 * cos($angle + 3 * $da) - $r2 * cos($angle + 2 * $da)]
set v [expr $r1 * sin($angle + 3 * $da) - $r2 * sin($angle + 2 * $da)]
glNormal3f $v [expr -1.0 * $u] 0.0
glVertex3f [expr $r1 * cos($angle + 3 * $da)] \
[expr $r1 * sin($angle + 3 * $da)] \
[expr $width * 0.5]
glVertex3f [expr $r1 * cos($angle + 3 * $da)] \
[expr $r1 * sin($angle + 3 * $da)] \
[expr -1.0 * $width * 0.5]
glNormal3f [expr cos($angle)] [expr sin($angle)] 0.0
}
glVertex3f [expr $r1 * cos(0)] [expr $r1 * sin(0)] [expr $width * 0.5]
glVertex3f [expr $r1 * cos(0)] [expr $r1 * sin(0)] [expr -1.0 * $width * 0.5]
glEnd
glShadeModel GL_SMOOTH
glBegin GL_QUAD_STRIP
for { set i 0 } { $i <= $teeth } { incr i } {
set angle [expr $i * 2.0 * $::M_PI / $teeth]
glNormal3f [expr -cos($angle)] [expr -sin($angle)] 0.0
glVertex3f [expr $r0 * cos($angle)] \
[expr $r0 * sin($angle)] \
[expr -1.0 * $width * 0.5]
glVertex3f [expr $r0 * cos($angle)] \
[expr $r0 * sin($angle)] \
[expr $width * 0.5]
}
glEnd
}
proc DisplayCallback { toglwin } {
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
# Viewport command is not really needed, but has been inserted for
# Mac OSX. Presentation framework (Tk) does not send a reshape event,
# when switching from one demo to another.
glViewport 0 0 [$toglwin width] [$toglwin height]
glDisable GL_TEXTURE_2D
glPushMatrix
glRotatef $::Wg($toglwin,Rotx) 1.0 0.0 0.0
glRotatef $::Wg($toglwin,Roty) 0.0 1.0 0.0
glRotatef $::Wg($toglwin,Rotz) 0.0 0.0 1.0
glPushMatrix
glTranslatef -3.0 -2.0 0.0
glRotatef $::Wg($toglwin,Angle) 0.0 0.0 1.0
glEnable GL_DEPTH_TEST
glCallList $::Wg($toglwin,Gear1)
glEnable GL_DEPTH_TEST
glPopMatrix
glPushMatrix
glTranslatef 3.1 -2.0 0.0
glRotatef [expr -2.0 * $::Wg($toglwin,Angle) - 9.0] 0.0 0.0 1.0
glCallList $::Wg($toglwin,Gear2)
glPopMatrix
glPushMatrix
glTranslatef -3.1 4.2 0.0
glRotatef [expr -2.0 * $::Wg($toglwin,Angle) - 25.0] 0.0 0.0 1.0
glCallList $::Wg($toglwin,Gear3)
glPopMatrix
glPopMatrix
$toglwin swapbuffers
}
proc Idle { toglwin tick } {
set ::Wg($toglwin,Angle) [expr $::Wg($toglwin,Angle) + 2.0]
$toglwin postredisplay
set ::Wg($toglwin,idleId) [after $tick "Idle $toglwin $tick"]
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
set width [$toglwin width]
set height [$toglwin height]
glViewport 0 0 $width $height
glMatrixMode GL_PROJECTION
glLoadIdentity
if { $width > $height } {
set w [expr double ($width) / double ($height)]
glFrustum [expr -1.0*$w] $w -1.0 1.0 5.0 60.0
} else {
set h [expr double ($height) / double ($width)]
glFrustum -1.0 1.0 [expr -1.0*$h] $h 5.0 60.0
}
glMatrixMode GL_MODELVIEW
glLoadIdentity
glTranslatef 0.0 0.0 -40.0
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
}
proc CreateCallback { toglwin } {
set red { 0.8 0.1 0.0 1.0 }
set green { 0.0 0.8 0.2 1.0 }
set blue { 0.2 0.2 1.0 1.0 }
set pos { 5.0 5.0 10.0 0.0 }
glLightfv GL_LIGHT0 GL_POSITION $pos
glEnable GL_CULL_FACE
glEnable GL_LIGHTING
glEnable GL_LIGHT0
glEnable GL_DEPTH_TEST
set ::Wg($toglwin,Gear1) [glGenLists 1]
glNewList $::Wg($toglwin,Gear1) GL_COMPILE
glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE $red
gear 1.0 4.0 1.0 20 0.7
glEndList
set ::Wg($toglwin,Gear2) [glGenLists 1]
glNewList $::Wg($toglwin,Gear2) GL_COMPILE
glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE $green
gear 0.5 2.0 2.0 10 0.7
glEndList
set ::Wg($toglwin,Gear3) [glGenLists 1]
glNewList $::Wg($toglwin,Gear3) GL_COMPILE
glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE $blue
gear 1.3 2.0 0.5 10 0.7
glEndList
glEnable GL_NORMALIZE
set ::Wg($toglwin,Angle) 0.0
set ::Wg($toglwin,Rotx) 0.0
set ::Wg($toglwin,Roty) 0.0
set ::Wg($toglwin,Rotz) 0.0
}
proc setup {} {
global startx starty xangle0 yangle0 xangle yangle RotCnt
global vTime
set RotCnt 1
set xangle 0.0
set yangle 0.0
set vTime 10
wm title . "Tcl3D demo: Rotating Gear Widget Test"
# Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
ttk::frame .fr
pack .fr -expand 1 -fill both
ttk::label .fr.t -text "Click and drag to rotate camera view"
pack .fr.t -side top -padx 2 -pady 5
ttk::frame .fr.f
pack .fr.f -side top
ttk::button .fr.f.a -text "Add" -command AutoRot
ttk::button .fr.f.r -text "Remove" -command DelRot
ttk::label .fr.f.l -text "Update rate:"
ttk::entry .fr.f.t -width 4 -textvariable vTime
pack .fr.f.a .fr.f.r .fr.f.l .fr.f.t -side left -anchor w -padx 2
bind . <Key-Escape> "exit"
AutoRot
}
proc AutoRot {} {
global RotCnt vTime
if { $vTime <= 0 } {
set vTime 1
}
newRot .fr.w$RotCnt $vTime
set RotCnt [expr $RotCnt + 1]
}
proc DelRot {} {
global RotCnt vTime
if { $RotCnt != 0 } {
set RotCnt [expr $RotCnt - 1]
after cancel $::Wg(.fr.w$RotCnt,idleId)
destroy .fr.w$RotCnt
}
}
proc newRot {win {tick 100} } {
togl $win -width 400 -height 400 -rgba true -double true \
-depth true -privatecmap false \
-createcommand CreateCallback \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback
bind $win <ButtonPress-1> {RotStart %x %y %W}
bind $win <B1-Motion> {RotMove %x %y %W}
pack $win -expand true -fill both
tcl3dAfterIdle "Idle $win $tick"
}
proc RotStart {x y W } {
global startx starty xangle0 yangle0 xangle yangle
set startx $x
set starty $y
set xangle0 $::Wg($W,Roty)
set yangle0 $::Wg($W,Rotx)
$W postredisplay
}
proc RotMove {x y W} {
global startx starty xangle0 yangle0 xangle yangle
set xangle [expr $xangle0 + ($x - $startx)]
set yangle [expr $yangle0 + ($y - $starty)]
set ::Wg($W,Roty) $xangle
set ::Wg($W,Rotx) $yangle
$W postredisplay
}
setup
|
