Demo 15 of 15 in category Tcl3DSpecificDemos
 |
# 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
# 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 } {
set len [string length $msg]
if { $len > 0 } {
glColor3f 1.0 1.0 1.0
glRasterPos3f $x $y 0.0
glListBase $::FontBase
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]
}
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
$toglwin swapbuffers
}
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 true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand 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 . <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-Escape> "ExitProg"
.fr.usage insert end "Key-1: Copy: Dest(bw) = Src(bw)"
.fr.usage insert end "Key-2: Copy: Dest(r,g,b) = Src(r,g,b)"
.fr.usage insert end "Key-3: Manip: Dest(bw) = -1 * Src(bw) + 255"
.fr.usage insert end "Key-4: Manip: Dest(r,g,b) = -1 * Src(r,g,b) + 255"
.fr.usage insert end "Key-5: Swap : Dest(r,g,b) = Src(g,r,b)"
.fr.usage insert end "Key-Escape: Exit"
.fr.usage configure -state disabled
Method 1
PrintInfo [tcl3dOglGetInfoString]
|
