OUTPUT BUFFER:
# 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 Paul Obermeier (Tcl3D version) # See the LICENSE file for copyright details. # # Original sources available at: http://sourceforge.net/projects/togl/ package require tcl3d 0.5.0 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. frame .fr pack .fr -expand 1 -fill both label .fr.t -text "Click and drag to rotate camera view" pack .fr.t -side top -padx 2 -pady 5 frame .fr.f pack .fr.f -side top button .fr.f.n1 -text "Add" -command AutoRot button .fr.f.r1 -text "Remove" -command DelRot button .fr.f.b1 -text "Quit" -command exit entry .fr.f.t -width 4 -textvariable vTime pack .fr.f.n1 .fr.f.t .fr.f.r1 .fr.f.b1 -side left -anchor w -padx 5 bind .