OUTPUT BUFFER:
# vectormanip.tcl # # Tcl3D demo showing the use of the Vector manipulation functions, # introduced in Version 0.3.2. # The program texture maps an image generated with Tcl (the source) onto the # left quad. The source texture is manipulated with the vector functions # according to the choosen method and mapped onto the right quad. # See functions execMethod? below. # # Author: Paul Obermeier # Date: 2006-08-15 package require tcl3d 0.3.2 # Font to be used in the Tk listbox. set g_ListFont {-family {Courier} -size 10} # Create checkerboard texture set ::g_TexWidth 256 set ::g_TexHeight 256 # Show errors occuring in the Togl callbacks. proc bgerror { msg } { tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo" ExitProg } # Print info message into widget a the bottom of the window. proc PrintInfo { msg } { if { [winfo exists .fr.info] } { .fr.info configure -text $msg } } # Print info message into window title. proc PrintTitle { msg } { set titleStr "Tcl3D demo: Manipulating image vectors" wm title . [format "%s (%s)" $titleStr $msg] } # Print info message into OpenGL canvas. proc PrintOgl { msg x y } { glColor3f 1.0 1.0 1.0 glRasterPos3f $x $y 0.0 glListBase $::FontBase set len [string length $msg] set sa [tcl3dVectorFromString GLubyte $msg] glCallLists $len GL_UNSIGNED_BYTE $sa $sa delete } # Execute one of the texture manipulation procedures execMethod$num. proc Method { num } { if { [package vcompare [package versions tcl3d] "0.3"] <= 0 } { tk_messageBox -icon info -type ok -title "Info" \ -message "Method $num needs Tcl3D 0.3.2 or higher" return } glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT] glFlush if { [info exists ::g_TexSrc] } { $::g_TexSrc delete } if { [info exists ::g_TexDst] } { $::g_TexDst delete } execMethod$num glPixelStorei GL_UNPACK_ALIGNMENT 1 if { [info exists ::g_TexName] } { $::g_TexName delete } set ::g_TexName [tcl3dVector GLuint 2] glGenTextures 2 $::g_TexName glBindTexture GL_TEXTURE_2D [$::g_TexName get 0] glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA \ $::g_TexWidth $::g_TexHeight \ 0 $::g_TexType GL_UNSIGNED_BYTE $::g_TexSrc glBindTexture GL_TEXTURE_2D [$::g_TexName get 1] glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA \ $::g_TexWidth $::g_TexHeight \ 0 $::g_TexType GL_UNSIGNED_BYTE $::g_TexDst .fr.toglwin postredisplay } # Utility function to create a GLubyte vector with numChans channels. proc createVector { numChans } { return [tcl3dVector GLubyte [expr $::g_TexWidth * $::g_TexHeight * $numChans]] } # Create a gray-scale gradient: Generate a binary Tcl string for only one row. # Transfer this row data with several calls to low-level function # tcl3dByteArray2Vector while incrementing the destination offset. proc makeTexture1Chan {} { set tex [createVector 1] set ::g_TexType $::GL_LUMINANCE for { set j 0 } { $j < $::g_TexWidth } { incr j } { append imgRow [binary format c $j] } for { set i 0 } { $i < $::g_TexHeight } { incr i } { set off [expr {$i * $::g_TexWidth}] tcl3dByteArray2Vector $imgRow $tex [string length $imgRow] 0 $off } return $tex } # Create a color gradient with tcl3dVectorFromByteArray. proc makeTexture3Chan {} { set ::g_TexType $::GL_RGB set template [binary format ccc 1 0 0] for { set j 1 } { $j < $::g_TexWidth } { incr j } { append template [binary format ccc $j 0 0] } set row $template for { set i 0 } { $i < $::g_TexHeight } { incr i } { append img $row set row [string map [list [binary format c 0] [binary format c $i]] \ $template] } set tex [tcl3dVectorFromByteArray GLubyte $img] return $tex } proc createTexture { numChans } { if { $numChans == 1 } { return [makeTexture1Chan] } elseif { $numChans == 3 } { return [makeTexture3Chan] } return "" } # Test of function tcl3dVectorCopy with 1 channel. # Copy the source image vector into the destination vector. proc execMethod1 {} { set ::g_TexSrc [createTexture 1] set ::g_TexDst [createVector 1] tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 1 PrintTitle "Test 1" } # Test of function tcl3dVectorCopy with 3 channels. # Copy the source image vector into the destination vector. proc execMethod2 {} { set ::g_TexSrc [createTexture 3] set ::g_TexDst [createVector 3] tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 3 PrintTitle "Test 2" } # Test of function tcl3dVectorManip with 1 channel. # Invert the image, i.e. scale by -1 and offset by 255. proc execMethod3 {} { set ::g_TexSrc [createTexture 1] set ::g_TexDst [createVector 1] tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 1 tcl3dVectorManip $::g_TexDst $::g_TexWidth $::g_TexHeight 1 -1 255 PrintTitle "Test 3" } # Test of function tcl3dVectorManip with 3 channels. # Invert the image, i.e. scale by -1 and offset by 255. proc execMethod4 {} { set ::g_TexSrc [createTexture 3] set ::g_TexDst [createVector 3] tcl3dVectorCopy $::g_TexSrc $::g_TexDst $::g_TexWidth $::g_TexHeight 3 tcl3dVectorManip $::g_TexDst $::g_TexWidth $::g_TexHeight 3 -1 255 PrintTitle "Test 4" } # Test of function tcl3dVectorCopyChannel with 3 channels. # Swap red and green channels. proc execMethod5 {} { set ::g_TexSrc [createTexture 3] set ::g_TexDst [createVector 3] tcl3dVectorCopyChannel $::g_TexSrc $::g_TexDst 0 1 $::g_TexWidth $::g_TexHeight 3 3 tcl3dVectorCopyChannel $::g_TexSrc $::g_TexDst 1 0 $::g_TexWidth $::g_TexHeight 3 3 tcl3dVectorCopyChannel $::g_TexSrc $::g_TexDst 2 2 $::g_TexWidth $::g_TexHeight 3 3 PrintTitle "Test 5" } proc CreateCallback { toglwin } { glClearColor 0.5 0.5 0.5 0.0 glShadeModel GL_FLAT glEnable GL_DEPTH_TEST set ::FontBase [$toglwin loadbitmapfont "fixed"] } 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] # First quad showing the original texture. if { [info exists ::g_TexName] } { glEnable GL_TEXTURE_2D glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL glBindTexture GL_TEXTURE_2D [$::g_TexName get 0] } glBegin GL_QUADS glTexCoord2f 0.0 0.0 ; glVertex3f -2.1 -1.0 0.0 glTexCoord2f 0.0 1.0 ; glVertex3f -2.1 1.0 0.0 glTexCoord2f 1.0 1.0 ; glVertex3f -0.1 1.0 0.0 glTexCoord2f 1.0 0.0 ; glVertex3f -0.1 -1.0 0.0 glEnd # Second quad showing the modified texture. if { [info exists ::g_TexName] } { glEnable GL_TEXTURE_2D glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL glBindTexture GL_TEXTURE_2D [$::g_TexName get 1] } glBegin GL_QUADS glTexCoord2f 0.0 0.0 ; glVertex3f 0.1 -1.0 0.0 glTexCoord2f 0.0 1.0 ; glVertex3f 0.1 1.0 0.0 glTexCoord2f 1.0 1.0 ; glVertex3f 2.1 1.0 0.0 glTexCoord2f 1.0 0.0 ; glVertex3f 2.1 -1.0 0.0 glEnd glDisable GL_TEXTURE_2D PrintOgl "Source texture" -2.1 -1.2 PrintOgl "Destination texture" 0.1 -1.2 glFlush } proc ReshapeCallback { toglwin { w -1 } { h -1 } } { set w [$toglwin width] set h [$toglwin height] set fov [expr (2.0 * atan2 (4.5/2.0, 2.0)) * 180.0 / 3.14159] glViewport 0 0 $w $h glMatrixMode GL_PROJECTION glLoadIdentity gluPerspective $fov [expr double($w)/double($h)] 1.0 30.0 glMatrixMode GL_MODELVIEW glLoadIdentity glTranslatef 0.0 0.0 -2.0 } proc Cleanup {} { if { [info exists ::g_TexName] } { $::g_TexName delete } if { [info exists ::g_TexSrc] } { $::g_TexSrc delete } if { [info exists ::g_TexDst] } { $::g_TexDst delete } foreach var [info globals g_*] { uplevel #0 unset $var } } # Put all exit related code here. proc ExitProg {} { exit } frame .fr pack .fr -expand 1 -fill both togl .fr.toglwin -width 640 -height 500 \ -double false -depth true \ -createproc CreateCallback \ -reshapeproc ReshapeCallback \ -displayproc DisplayCallback listbox .fr.usage -height 6 -font $g_ListFont label .fr.info grid .fr.toglwin -row 0 -column 0 -sticky news grid .fr.usage -row 1 -column 0 -sticky news grid .fr.info -row 2 -column 0 -sticky news grid rowconfigure .fr 0 -weight 1 grid columnconfigure .fr 0 -weight 1 bind .