Demo 2 of 15 in category Tcl3DSpecificDemos
 |
# 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
# 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 { num msg } {
if { [winfo exists .fr.timeinfo] } {
if { $num > 0 } {
set msg "Key-$num: $msg"
}
.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 $num $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
}
$imgRow delete
}
# 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
$toglwin swapbuffers
}
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 true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand 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 . <Key-Escape> "ExitProg"
bind . <Key-1> "Method 1"
bind . <Key-2> "Method 2"
bind . <Key-3> "Method 3"
bind . <Key-4> "Method 4"
bind . <Key-5> "Method 5"
bind . <Key-6> "Method 6"
bind . <Key-7> "Method 7"
.fr.usage insert end "Key-1: Gradient with tcl3dVector (slow)"
.fr.usage insert end "Key-2: Gradient with tcl3dVectorFromByteArray (slow)"
.fr.usage insert end "Key-3: Gradient with tcl3dVectorFromByteArray (fast)"
.fr.usage insert end "Key-4: Gradient with tcl3VectorLinspace (fast)"
.fr.usage insert end "Key-5: Gradient with tcl3dVectorFromByteArray (fast)"
.fr.usage insert end "Key-6: Color gradient with tcl3dVectorFromByteArray"
.fr.usage insert end "Key-7: Gradient readback with tcl3dVectorToByteArray"
.fr.usage insert end "Key-Escape: Exit"
.fr.usage configure -state disabled
PrintTimeInfo -1 "Press a key to create a texure"
PrintInfo [tcl3dOglGetInfoString]
Method 3
|
