Demo 4 of 5 in category tcl3dTogl
 |
# tcl3dTexture.tcl
#
# Togl texture map demo
#
# This is a version of the original Togl texture demo written entirely in Tcl
# with the help of the Tcl3D package.
#
# Copyright (C) 1996 Brian Paul and Ben Bederson (Original C/Tcl version)
# Copyright (C) 2005-2024 Paul Obermeier (Tcl3D version)
# See the LICENSE file for copyright details.
#
# Original sources available at: http://sourceforge.net/projects/togl/
package require Img
package require tcl3d
set CHECKER 0
set FACE 1
set TREE 2
set blend $::GL_FALSE
# Determine the directory of this script.
set g_scriptDir [file dirname [info script]]
# 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 a the bottom of the window.
proc PrintInfo { msg } {
if { [winfo exists .fr.info] } {
.fr.info configure -text $msg
}
}
proc ReadImg { imgName } {
global gPo
if { [info exists ::vecImg] } {
$::vecImg delete
}
set texName [file join $::g_scriptDir $imgName]
set retVal [catch {set phImg [image create photo -file $texName]} err1]
if { $retVal != 0 } {
error "Failure reading image $texName"
} else {
set w [image width $phImg]
set h [image height $phImg]
set z [tcl3dPhotoChans $phImg]
set ::vecImg [tcl3dVectorFromPhoto $phImg]
image delete $phImg
glEnable GL_TEXTURE_2D
glPixelStorei GL_UNPACK_ALIGNMENT 1
if { $z == 3 } {
set type $::GL_RGB
} else {
set type $::GL_RGBA
}
gluBuild2DMipmaps GL_TEXTURE_2D $z $w $h \
$type GL_UNSIGNED_BYTE $::vecImg
}
}
#
# Load a texture image. n is one of CHECKER, FACE or TREE.
#
proc TextureImage { n } {
if { $n == $::CHECKER } {
set WIDTH 64
set HEIGHT 64
set teximage [tcl3dVector GLubyte [expr $WIDTH*$HEIGHT*4]]
for { set i 0 } { $i < $HEIGHT } { incr i } {
for { set j 0 } { $j < $WIDTH } { incr j } {
set c [expr ($i / 4 + $j / 4) % 2]
if { $c } {
set value 0xff
} else {
set value 0x00
}
$teximage set [expr ($i * $WIDTH + $j)*4 + 0] $value
$teximage set [expr ($i * $WIDTH + $j)*4 + 1] $value
$teximage set [expr ($i * $WIDTH + $j)*4 + 2] $value
$teximage set [expr ($i * $WIDTH + $j)*4 + 3] $value
}
}
glEnable GL_TEXTURE_2D
gluBuild2DMipmaps GL_TEXTURE_2D 4 $WIDTH $HEIGHT \
GL_RGBA GL_UNSIGNED_BYTE $teximage
set ::blend $::GL_FALSE
} elseif { $n == $::FACE } {
ReadImg "ben.rgb"
set ::blend $::GL_TRUE
} elseif { $n == $::TREE } {
ReadImg "tree2.rgba"
set ::blend $::GL_TRUE
} else {
error "Wrong texture image number $n"
}
}
#
# Togl widget create callback. This is called by Tcl/Tk when the widget has
# been realized. Here's where one may do some one-time context setup or
# initializations.
#
proc CreateCallback { toglwin } {
glEnable GL_DEPTH_TEST
TextureImage $::CHECKER
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::magfilter
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::minfilter
}
#
# Togl widget reshape callback. This is called by Tcl/Tk when the widget
# has been resized. Typically, we call glViewport and perhaps setup the
# projection matrix.
#
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
set w [$toglwin width]
set h [$toglwin height]
glViewport 0 0 $w $h
}
proc CheckError { where } {
set errMsg [tcl3dOglGetError]
if { $errMsg eq "" } {
return
}
error [format "OpenGL error in proc %s: %s\n" $where $errMsg]
}
#
# Togl widget display callback. This is called by Tcl/Tk when the widget's
# contents have to be redrawn. Typically, we clear the color and depth
# buffers, render our objects, then swap the front/back color buffers.
#
proc DisplayCallback { toglwin } {
set aspect [expr double ([$toglwin width]) / double ([$toglwin height])]
CheckError "DisplayCallback"
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
glMatrixMode GL_PROJECTION
glLoadIdentity
glMatrixMode GL_MODELVIEW
glLoadIdentity
glDisable GL_TEXTURE_2D
glDisable GL_DEPTH_TEST
glBegin GL_POLYGON
glColor3f 0.0 0.0 0.3
glVertex2f -1.0 -1.0
glColor3f 0.0 0.0 0.3
glVertex2f 1.0 -1.0
glColor3f 0.0 0.0 0.9
glVertex2f 1.0 1.0
glColor3f 0.0 0.0 0.9
glVertex2f -1.0 1.0
glEnd
glMatrixMode GL_PROJECTION
glLoadIdentity
glFrustum [expr -1.0 * $aspect] $aspect -1.0 1.0 2.0 10.0
glMatrixMode GL_MODELVIEW
glLoadIdentity
glTranslatef 0.0 0.0 -5.0
glScalef $::scale $::scale $::scale
glRotatef $::xangle 0.0 1.0 0.0
glRotatef $::yangle 1.0 0.0 0.0
glEnable GL_DEPTH_TEST
glEnable GL_TEXTURE_2D
glColor4ubv $::polycolor
if {$::blend == $::GL_TRUE} {
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
glEnable GL_BLEND
}
glBegin GL_POLYGON
glTexCoord2f 0.0 0.0
glVertex2f -1.0 -1.0
glTexCoord2f $::coord_scale 0.0
glVertex2f 1.0 -1.0
glTexCoord2f $::coord_scale $::coord_scale
glVertex2f 1.0 1.0
glTexCoord2f 0.0 $::coord_scale
glVertex2f -1.0 1.0
glEnd
glDisable GL_BLEND
$toglwin swapbuffers
}
# Called magnification filter changes
proc NewMagFilter {} {
global magfilter
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $magfilter
.fr.f1.view postredisplay
}
# Called minification filter changes
proc NewMinFilter {} {
global minfilter
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $minfilter
.fr.f1.view postredisplay
}
# Called when texture image radio button changes
proc NewImage {} {
global teximage
TextureImage $teximage
.fr.f1.view postredisplay
}
# Called when texture S wrap button changes
proc NewWrapS {} {
global swrap
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $swrap
.fr.f1.view postredisplay
}
# Called when texture T wrap button changes
proc NewWrapT {} {
global twrap
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $twrap
.fr.f1.view postredisplay
}
# Called when texture environment radio button selected
proc NewEnv {} {
global envmode
glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $envmode
.fr.f1.view postredisplay
}
# Called when polygon color sliders change
proc NewColor { foo } {
global poly_red poly_green poly_blue
set ::polycolor [list $poly_red $poly_green $poly_blue 255]
.fr.f1.view postredisplay
}
proc NewCoordScale { name element op } {
global coord_scale
if { $coord_scale eq "" || ! [string is double $coord_scale] } {
set coord_scale 1.0
}
.fr.f1.view postredisplay
}
# Make the widgets
proc CreateWindows {} {
global magfilter
global minfilter
global teximage
global swrap
global twrap
global envmode
global poly_red
global poly_green
global poly_blue
global polycolor
global coord_scale
global startx starty # location of mouse when button pressed
global xangle yangle
global xangle0 yangle0
global scale scale0
# set default values
set minfilter $::GL_NEAREST_MIPMAP_LINEAR
set magfilter $::GL_LINEAR
set swrap $::GL_REPEAT
set twrap $::GL_REPEAT
set envmode $::GL_MODULATE
set teximage $::CHECKER
set poly_red 255
set poly_green 255
set poly_blue 255
set polycolor [list $poly_red $poly_green $poly_blue 255]
set coord_scale 1.0
set xangle 0.0
set yangle 0.0
set scale 1.0
wm title . "Tcl3D demo: Texture Map Options"
# Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
frame .fr
pack .fr -expand 1 -fill both
### Two frames: top half and bottom half
frame .fr.f1
frame .fr.f2
### The OpenGL window
togl .fr.f1.view -width 250 -height 250 \
-rgba true -double true -depth true \
-createcommand CreateCallback \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback
### Filter radio buttons
frame .fr.f1.filter -relief ridge -borderwidth 3
frame .fr.f1.filter.mag -relief ridge -borderwidth 2
label .fr.f1.filter.mag.label -text "Magnification Filter" -anchor w
radiobutton .fr.f1.filter.mag.nearest -text GL_NEAREST -anchor w \
-variable magfilter -value $::GL_NEAREST -command NewMagFilter
radiobutton .fr.f1.filter.mag.linear -text GL_LINEAR -anchor w \
-variable magfilter -value $::GL_LINEAR -command NewMagFilter
frame .fr.f1.filter.min -relief ridge -borderwidth 2
label .fr.f1.filter.min.label -text "Minification Filter" -anchor w
radiobutton .fr.f1.filter.min.nearest -text GL_NEAREST -anchor w \
-variable minfilter -value $::GL_NEAREST -command NewMinFilter
radiobutton .fr.f1.filter.min.linear -text GL_LINEAR -anchor w \
-variable minfilter -value $::GL_LINEAR -command NewMinFilter
radiobutton .fr.f1.filter.min.nearest_mipmap_nearest -text GL_NEAREST_MIPMAP_NEAREST -anchor w \
-variable minfilter -value $::GL_NEAREST_MIPMAP_NEAREST -command NewMinFilter
radiobutton .fr.f1.filter.min.linear_mipmap_nearest -text GL_LINEAR_MIPMAP_NEAREST -anchor w \
-variable minfilter -value $::GL_LINEAR_MIPMAP_NEAREST -command NewMinFilter
radiobutton .fr.f1.filter.min.nearest_mipmap_linear -text GL_NEAREST_MIPMAP_LINEAR -anchor w \
-variable minfilter -value $::GL_NEAREST_MIPMAP_LINEAR -command NewMinFilter
radiobutton .fr.f1.filter.min.linear_mipmap_linear -text GL_LINEAR_MIPMAP_LINEAR -anchor w \
-variable minfilter -value $::GL_LINEAR_MIPMAP_LINEAR -command NewMinFilter
pack .fr.f1.filter.mag -fill x
pack .fr.f1.filter.mag.label -fill x
pack .fr.f1.filter.mag.nearest -side top -fill x
pack .fr.f1.filter.mag.linear -side top -fill x
pack .fr.f1.filter.min -fill both -expand true
pack .fr.f1.filter.min.label -side top -fill x
pack .fr.f1.filter.min.nearest -side top -fill x
pack .fr.f1.filter.min.linear -side top -fill x
pack .fr.f1.filter.min.nearest_mipmap_nearest -side top -fill x
pack .fr.f1.filter.min.linear_mipmap_nearest -side top -fill x
pack .fr.f1.filter.min.nearest_mipmap_linear -side top -fill x
pack .fr.f1.filter.min.linear_mipmap_linear -side top -fill x
### Texture coordinate scale and wrapping
frame .fr.f2.coord -relief ridge -borderwidth 3
frame .fr.f2.coord.scale -relief ridge -borderwidth 2
label .fr.f2.coord.scale.label -text "Max Texture Coord" -anchor w
entry .fr.f2.coord.scale.entry -textvariable coord_scale -exportselection 0
frame .fr.f2.coord.s -relief ridge -borderwidth 2
label .fr.f2.coord.s.label -text "GL_TEXTURE_WRAP_S" -anchor w
radiobutton .fr.f2.coord.s.repeat -text "GL_REPEAT" -anchor w -variable swrap \
-value $::GL_REPEAT -command NewWrapS
radiobutton .fr.f2.coord.s.clamp -text "GL_CLAMP" -anchor w -variable swrap \
-value $::GL_CLAMP -command NewWrapS
frame .fr.f2.coord.t -relief ridge -borderwidth 2
label .fr.f2.coord.t.label -text "GL_TEXTURE_WRAP_T" -anchor w
radiobutton .fr.f2.coord.t.repeat -text "GL_REPEAT" -anchor w -variable twrap \
-value $::GL_REPEAT -command NewWrapT
radiobutton .fr.f2.coord.t.clamp -text "GL_CLAMP" -anchor w -variable twrap \
-value $::GL_CLAMP -command NewWrapT
pack .fr.f2.coord.scale -fill both -expand true
pack .fr.f2.coord.scale.label -side top -fill x
pack .fr.f2.coord.scale.entry -side top -fill x
pack .fr.f2.coord.s -fill x
pack .fr.f2.coord.s.label -side top -fill x
pack .fr.f2.coord.s.repeat -side top -fill x
pack .fr.f2.coord.s.clamp -side top -fill x
pack .fr.f2.coord.t -fill x
pack .fr.f2.coord.t.label -side top -fill x
pack .fr.f2.coord.t.repeat -side top -fill x
pack .fr.f2.coord.t.clamp -side top -fill x
### Texture image radio buttons (just happens to fit into the coord frame)
frame .fr.f2.env -relief ridge -borderwidth 3
frame .fr.f2.env.image -relief ridge -borderwidth 2
label .fr.f2.env.image.label -text "Texture Image" -anchor w
radiobutton .fr.f2.env.image.checker -text "Checker" -anchor w \
-variable teximage -value $::CHECKER -command NewImage
radiobutton .fr.f2.env.image.tree -text "Tree" -anchor w \
-variable teximage -value $::TREE -command NewImage
radiobutton .fr.f2.env.image.face -text "Face" -anchor w \
-variable teximage -value $::FACE -command NewImage
pack .fr.f2.env.image -fill x
pack .fr.f2.env.image.label -side top -fill x
pack .fr.f2.env.image.checker -side top -fill x
pack .fr.f2.env.image.tree -side top -fill x
pack .fr.f2.env.image.face -side top -fill x
### Texture Environment
label .fr.f2.env.label -text "GL_TEXTURE_ENV_MODE" -anchor w
radiobutton .fr.f2.env.modulate -text "GL_MODULATE" -anchor w \
-variable envmode -value $::GL_MODULATE -command NewEnv
radiobutton .fr.f2.env.decal -text "GL_DECAL" -anchor w \
-variable envmode -value $::GL_DECAL -command NewEnv
radiobutton .fr.f2.env.blend -text "GL_BLEND" -anchor w \
-variable envmode -value $::GL_BLEND -command NewEnv
pack .fr.f2.env.label -fill x
pack .fr.f2.env.modulate -side top -fill x
pack .fr.f2.env.decal -side top -fill x
pack .fr.f2.env.blend -side top -fill x
### Polygon color
frame .fr.f2.color -relief ridge -borderwidth 3
label .fr.f2.color.label -text "Polygon color" -anchor w
scale .fr.f2.color.red -label Red -from 0 -to 255 -orient horizontal \
-variable poly_red -command NewColor
scale .fr.f2.color.green -label Green -from 0 -to 255 -orient horizontal \
-variable poly_green -command NewColor
scale .fr.f2.color.blue -label Blue -from 0 -to 255 -orient horizontal \
-variable poly_blue -command NewColor
pack .fr.f2.color.label -fill x
pack .fr.f2.color.red -side top -fill x
pack .fr.f2.color.green -side top -fill x
pack .fr.f2.color.blue -side top -fill x
### Main widgets
pack .fr.f1.view -side left -fill both -expand true
pack .fr.f1.filter -side left -fill y
pack .fr.f1 -side top -fill both -expand true
pack .fr.f2.coord .fr.f2.env -side left -fill both
pack .fr.f2.color -fill x
pack .fr.f2 -side top -fill x
label .fr.info
pack .fr.info -expand false
trace add variable coord_scale write NewCoordScale
bind .fr.f1.view <ButtonPress-1> {
set startx %x
set starty %y
set xangle0 $xangle
set yangle0 $yangle
}
bind .fr.f1.view <B1-Motion> {
set xangle [expr $xangle0 + (%x - $startx) / 3.0 ]
set yangle [expr $yangle0 + (%y - $starty) / 3.0 ]
.fr.f1.view postredisplay
}
bind .fr.f1.view <ButtonPress-2> {
set startx %x
set starty %y
set scale0 $scale
}
bind .fr.f1.view <B2-Motion> {
set q [ expr ($starty - %y) / 400.0 ]
set scale [expr $scale0 * exp($q)]
.fr.f1.view postredisplay
}
bind . <Key-Escape> "exit"
}
proc Cleanup {} {
global coord_scale
trace remove variable coord_scale write NewCoordScale
}
CreateWindows
PrintInfo [tcl3dOglGetInfoString]
|
