OUTPUT BUFFER:
# bytearray.tcl # # Tcl3D demo showing the use of the tcl3dByteArray2Vector function, # introduced in Version 0.3. # The program texture maps an image generated with Tcl onto a quad. # # Author: Paul Obermeier # Date: 2006-02-01 package require tcl3d 0.4.1 # 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" exit } # Print info message into widget at 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: Creating textures from byte arrays" wm title . [format "%s (%s)" $titleStr $msg] } # Print info message into widget at the bottom of the window. proc PrintTimeInfo { msg } { if { [winfo exists .fr.timeinfo] } { .fr.timeinfo configure -text $msg } } # Execute one of the texture creation procedures makeTexture$num # with time measurement. proc Method { num } { if { [package vcompare [package versions tcl3d] "0.2"] <= 0 && \ $num > 1 } { tk_messageBox -icon info -type ok -title "Info" \ -message "Method $num needs Tcl3D 0.3 or higher" return } glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT] glFlush Cleanup true set measure [time makeTexture$num] PrintTimeInfo $measure PrintTitle "Test $num" glPixelStorei GL_UNPACK_ALIGNMENT 1 set ::g_TexName [tcl3dVector GLuint 1] glGenTextures 1 $::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_TexImg .fr.toglwin postredisplay } # Create a gray-scale gradient: Set each pixel value by calling the set method # of a tcl3dVector. # Slow, needs Tcl3D >= 0.2. proc makeTexture1 {} { set texSize [expr $::g_TexHeight*$::g_TexWidth * 1] set ::g_TexImg [tcl3dVector GLubyte $texSize] set ::g_TexType $::GL_LUMINANCE set count 0 for { set i 0 } { $i < $::g_TexHeight } { incr i } { for { set j 0 } { $j < $::g_TexWidth } { incr j } { $::g_TexImg set $count $j incr count } } } # Create a gray-scale gradient: Generate a binary Tcl string by appending each # individual pixel value. # Transfer the image data with 1 call to tcl3dVectorFromByteArray. # Fast, needs Tcl3D >= 0.3. proc makeTexture2 {} { set ::g_TexType $::GL_LUMINANCE for { set i 0 } { $i < $::g_TexHeight } { incr i } { for { set j 0 } { $j < $::g_TexWidth } { incr j } { append img [binary format c $j] } } set ::g_TexImg [tcl3dVectorFromByteArray GLubyte $img] } # Create a gray-scale gradient: Generate a binary Tcl string for only one row. # Append that string for each row of the image to the image binary string. # Transfer the image data with 1 call to tcl3dVectorFromByteArray. # Faster, needs Tcl3D >= 0.3. proc makeTexture3 {} { 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 } { append img $imgRow } set ::g_TexImg [tcl3dVectorFromByteArray GLubyte $img] } # Create a gray-scale gradient: Generate a gradient vector for 1 row # with the Linspace function. # Transfer this row data with several calls to function tcl3dVectorCopy # while incrementing the destination offset. # Faster, needs Tcl3D >= 0.4.1. proc makeTexture4 {} { set texSize [expr $::g_TexHeight*$::g_TexWidth * 1] set ::g_TexImg [tcl3dVector GLubyte $texSize] set ::g_TexType $::GL_LUMINANCE set imgRow [tcl3dVectorFromLinspace GLubyte 0 255 $::g_TexWidth] for { set i 0 } { $i < $::g_TexHeight } { incr i } { set off [expr {$i * $::g_TexWidth}] tcl3dVectorCopy $imgRow [tcl3dVectorInd $::g_TexImg GLubyte $off] \ $::g_TexWidth 1 1 } } # 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. # Fastest, needs Tcl3D >= 0.3. proc makeTexture5 {} { set texSize [expr $::g_TexHeight*$::g_TexWidth * 1] set ::g_TexImg [tcl3dVector GLubyte $texSize] 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 $::g_TexImg [string length $imgRow] 0 $off } } # Create a color gradient with tcl3dVectorFromByteArray. # Needs Tcl3D >= 0.3. proc makeTexture6 {} { set texSize [expr $::g_TexHeight*$::g_TexWidth * 3] 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 ::g_TexImg [tcl3dVectorFromByteArray GLubyte $img] } # Create a gray-scale gradient: Generate a binary Tcl string for only one row. # Append that string for each row of the image to the binary string. # Transfer the image data with 1 call to utility procedure tcl3dVectorFromByteArray, # then read back the tcl3dVector into a second binary string and compare the two # binary strings. Print an error message, if they are not equal. # Needs Tcl3D >= 0.3. proc makeTexture7 {} { set texSize [expr $::g_TexHeight*$::g_TexWidth * 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 } { append img $imgRow } set ::g_TexImg [tcl3dVectorFromByteArray GLubyte $img] set readback [tcl3dVectorToByteArray $::g_TexImg $texSize 0 0] if { [string compare $img $readback] != 0 } { tk_messageBox -icon error -type ok -title "Error" \ -message "ByteArray read back differs from original" } } proc CreateCallback { toglwin } { glClearColor 0.5 0.5 0.5 0.0 glShadeModel GL_FLAT glEnable GL_DEPTH_TEST } 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] 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 -1.0 -1.0 0.0 glTexCoord2f 0.0 1.0 ; glVertex3f -1.0 1.0 0.0 glTexCoord2f 1.0 1.0 ; glVertex3f 1.0 1.0 0.0 glTexCoord2f 1.0 0.0 ; glVertex3f 1.0 -1.0 0.0 glEnd glFlush glDisable GL_TEXTURE_2D } proc ReshapeCallback { toglwin { w -1 } { h -1 } } { set w [$toglwin width] set h [$toglwin height] glViewport 0 0 $w $h glMatrixMode GL_PROJECTION glLoadIdentity gluPerspective 60.0 [expr double($w)/double($h)] 1.0 30.0 glMatrixMode GL_MODELVIEW glLoadIdentity glTranslatef 0.0 0.0 -2.6 } proc Cleanup { { texOnly false } } { if { [info exists ::g_TexName] } { glDeleteTextures 1 [$::g_TexName get 0] $::g_TexName delete } if { [info exists ::g_TexImg] } { $::g_TexImg delete } if { ! $texOnly } { foreach var [info globals g_*] { uplevel #0 unset $var } } } proc ExitProg {} { exit } frame .fr pack .fr -expand 1 -fill both togl .fr.toglwin -width 500 -height 500 \ -double false -depth true \ -createproc CreateCallback \ -reshapeproc ReshapeCallback \ -displayproc DisplayCallback listbox .fr.usage -height 7 -font $g_ListFont label .fr.timeinfo -bg white label .fr.info grid .fr.toglwin -row 0 -column 0 -sticky news grid .fr.usage -row 1 -column 0 -sticky news grid .fr.timeinfo -row 2 -column 0 -sticky news grid .fr.info -row 3 -column 0 -sticky news grid rowconfigure .fr 0 -weight 1 grid columnconfigure .fr 0 -weight 1 PrintTitle "Init" wm protocol . WM_DELETE_WINDOW "ExitProg" bind .