# testDrawReadPixels.tcl
#
# Tcl3D demo testing the speed of the glDrawPixels and glReadPixels functions.
# The program generates a color gradient image of a specified size.
# If the image size is greater than 256x256, the color gradient is tiled.
# This image is then drawn into the framebuffer with glDrawPixels and read
# back with glReadPixels several times.
# The time needed for drawing and reading back is reported into a text widget
# and onto stdout (for batch processing).
# The format and type of the image data can be specified for testing the
# differences in speed.
# Currently the following formats and types are implemented:
# Formats: GL_RGB, GL_BGR, GL_RGBA, GL_BGRA.
# Types : GL_UNSIGNED_BYTE
#
# Author: Paul Obermeier
# Date: 2009-07-16
package require tcl3d
# Font to be used in the Tk listbox.
set gDemo(listFont) {-family {Courier} -size 10}
# Determine the directory of this script
set gDemo(scriptDir) [file dirname [info script]]
# The possible formats and types.
set g_formats(GL_RGB,enum) $::GL_RGB
set g_formats(GL_BGR,enum) $::GL_BGR
set g_formats(GL_RGBA,enum) $::GL_RGBA
set g_formats(GL_BGRA,enum) $::GL_BGRA
set g_formats(GL_RGB,numChans) 3
set g_formats(GL_BGR,numChans) 3
set g_formats(GL_RGBA,numChans) 4
set g_formats(GL_BGRA,numChans) 4
set g_types(GL_UNSIGNED_BYTE,enum) $::GL_UNSIGNED_BYTE
set g_types(GL_UNSIGNED_BYTE,numBytes) 1
foreach fmt [lsort [array names g_formats "*,enum"]] {
lappend gOpts(formatsList) [lindex [split $fmt ","] 0]
}
foreach type [lsort [array names g_types "*,enum"]] {
lappend gOpts(typesList) [lindex [split $type ","] 0]
}
# Default values for optional parameters.
set gOpts(curFormat) GL_RGB
set gOpts(curType) GL_UNSIGNED_BYTE
set gOpts(imgWidth) 256
set gOpts(imgHeight) 256
set gOpts(imgSize) [format "%dx%d" $gOpts(imgWidth) $gOpts(imgHeight)]
set gOpts(numCalls) 100
set gOpts(batch) false
set gDemo(winWidth) $gOpts(imgWidth)
set gDemo(winHeight) $gOpts(imgHeight)
set gDemo(lastFormat) $gOpts(curFormat)
# 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 label widget at the bottom of the window.
proc PrintInfo { msg } {
if { [winfo exists .fr.info] } {
.fr.info configure -text $msg
}
}
# Print report message into text widget at the bottom of the window.
proc PrintReport { msg } {
global gDemo
if { [winfo exists $gDemo(out)] } {
$gDemo(out) insert end "$msg\n"
$gDemo(out) see end
}
puts $msg
}
# Save the image stored in tcl3dVector "vec" into file "fileName".
proc SaveImg { fileName vec w h numChans } {
set ph [image create photo -width $w -height $h]
tcl3dVectorToPhoto $vec $ph $w $h $numChans
set fmt [string range [file extension $fileName] 1 end]
$ph write $fileName -format $fmt
image delete $ph
}
# Create an image of size (w x h) with numChans channels.
proc MakeImg { w h numChans } {
global gOpts gDemo
if { $numChans == 3 } {
set template [binary format ccc 1 0 0]
for { set j 1 } { $j < $w } { incr j } {
append template [binary format ccc $j 0 0]
}
} elseif { $numChans == 4 } {
set template [binary format cccc 1 0 0 0]
for { set j 1 } { $j < $w } { incr j } {
append template [binary format cccc $j 0 0 0]
}
} else {
error "Cannot make an image with $numChans channels"
}
set row $template
for { set i 0 } { $i < $gOpts(imgHeight) } { incr i } {
append img $row
set row [string map [list [binary format c 0] [binary format c $i]] \
$template]
}
set gDemo(imgVec) [tcl3dVectorFromByteArray GLubyte $img]
}
proc NewSquareImage {} {
global gOpts
scan $gOpts(imgSize) "%dx%d" gOpts(imgWidth) gOpts(imgHeight)
if { $gOpts(imgWidth) < 1 } {
set gOpts(imgWidth) 1
}
if { $gOpts(imgHeight) < 1 } {
set gOpts(imgHeight) 1
}
set gOpts(imgSize) [format "%dx%d" $gOpts(imgWidth) $gOpts(imgHeight)]
NewImage
.fr.toglwin configure -width $gOpts(imgWidth) -height $gOpts(imgHeight)
}
proc NewImage {} {
global gOpts g_formats g_types
Cleanup true
set curFmt $gOpts(curFormat)
MakeImg $gOpts(imgWidth) $gOpts(imgHeight) $g_formats($curFmt,numChans)
}
proc ReadPixels { vec w h } {
global gOpts g_formats g_types
set fmt $g_formats($gOpts(curFormat),enum)
set type $g_types($gOpts(curType),enum)
glReadPixels 0 0 $w $h $fmt $type $vec
}
proc DrawPixels { vec w h } {
global gOpts g_formats g_types
set fmt $g_formats($gOpts(curFormat),enum)
set type $g_types($gOpts(curType),enum)
glDrawPixels $w $h $fmt $type $vec
}
proc TimedDrawReadPixels {} {
global gOpts gDemo g_formats
set w $gOpts(imgWidth)
set h $gOpts(imgHeight)
set numChans $g_formats($gOpts(curFormat),numChans)
set imgVec [tcl3dVector GLubyte [expr $w * $h * $numChans]]
glPixelStorei GL_PACK_ALIGNMENT 1
NewImage
set measure [time {DrawPixels $gDemo(imgVec) $w $h} $gOpts(numCalls)]
scan $measure "%f" msDraw
set measure [time {ReadPixels $imgVec $w $h} $gOpts(numCalls)]
scan $measure "%f" msRead
set totDraw [format "%.4f" [expr $msDraw * $gOpts(numCalls) / 1000000.0]]
set imgDraw [format "%.4f" [expr $msDraw / 1000.0]]
set pixDraw [format "%.4f" [expr $msDraw / $w / $h]]
set totRead [format "%.4f" [expr $msRead * $gOpts(numCalls) / 1000000.0]]
set imgRead [format "%.4f" [expr $msRead / 1000.0]]
set pixRead [format "%.4f" [expr $msRead / $w / $h]]
PrintReport "Draw/Read of $gOpts(numCalls) images: $totDraw $totRead secs"
PrintReport "Draw/Read of 1 image: $imgDraw $imgRead msecs ([expr $w*$h] pixels)"
PrintReport "Draw/Read of 1 pixel: $pixDraw $pixRead msecs"
# Write out the last read image.
set fileName [format "%s-%dx%d.png" $gOpts(curFormat) $w $h]
set filePath [file join $gDemo(scriptDir) $fileName]
# Create a name on the file system, if running from within a Starpack.
set imgName [tcl3dGenExtName $filePath]
PrintReport "Saving image to [file tail $imgName]"
SaveImg $imgName $imgVec $w $h $numChans
$imgVec delete
}
proc CreateCallback { toglwin } {
glClearColor 0.0 0.0 0.0 0.0
glShadeModel GL_FLAT
glEnable GL_DEPTH_TEST
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
global gOpts gDemo
set w [$toglwin width]
set h [$toglwin height]
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
glOrtho 0 $gOpts(imgWidth) 0 $gOpts(imgHeight) -1.0 1.0
glMatrixMode GL_MODELVIEW
set gDemo(winWidth) $w
set gDemo(winHeight) $h
}
proc DisplayCallback { toglwin } {
global gOpts gDemo
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]
glRasterPos2i 0 0
if { $gOpts(curFormat) ne $gDemo(lastFormat) } {
set gDemo(lastFormat) $gOpts(curFormat)
NewImage
}
DrawPixels $gDemo(imgVec) $gOpts(imgWidth) $gOpts(imgHeight)
glFlush
$toglwin swapbuffers
}
proc ExecTest {} {
TimedDrawReadPixels
.fr.toglwin postredisplay
}
proc Cleanup { { imgOnly false } } {
global gDemo
if { [info exists gDemo(imgVec)] } {
$gDemo(imgVec) delete
}
if { ! $imgOnly } {
foreach var [info globals g_*] {
uplevel #0 unset $var
}
uplevel #0 unset gDemo
uplevel #0 unset gOpts
}
}
proc ExitProg {} {
exit
}
# Create the widgets and bindings.
proc CreateWindow {} {
global gDemo gOpts
frame .fr
pack .fr -expand 1 -fill both
# Create the OpenGL widget.
togl .fr.toglwin -width $gDemo(winWidth) -height $gDemo(winHeight) \
-double true -depth true -alpha true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
frame .fr.frBtns
frame .fr.frReport
label .fr.info
grid .fr.toglwin -row 0 -column 0 -sticky news
grid .fr.frBtns -row 1 -column 0 -sticky news
grid .fr.frReport -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
wm title . "Tcl3D demo: Speed test of glDrawPixels and glReadPixels"
labelframe .fr.frBtns.frSett -text "Format and type"
pack .fr.frBtns.frSett -side left -padx 2
set gOpts(formatsMenu) [eval {tk_optionMenu .fr.frBtns.frSett.fm \
gOpts(curFormat)} $gOpts(formatsList)]
set gOpts(typesMenu) [eval {tk_optionMenu .fr.frBtns.frSett.tm \
gOpts(curType)} $gOpts(typesList)]
eval pack [winfo children .fr.frBtns.frSett] -side left \
-anchor w -expand 1 -fill x
labelframe .fr.frBtns.frSize -text "Image size"
pack .fr.frBtns.frSize -side left -padx 2
entry .fr.frBtns.frSize.size -textvariable gOpts(imgSize) -width 8
bind .fr.frBtns.frSize.size <Key-Return> "NewSquareImage"
tcl3dToolhelpAddBinding .fr.frBtns.frSize.size \
"Press Enter to generate a new image. Resize the window to fit the image."
eval pack [winfo children .fr.frBtns.frSize] -side left \
-anchor w -expand 1 -fill x
labelframe .fr.frBtns.frMisc -text "Num calls"
pack .fr.frBtns.frMisc -side left -padx 2
entry .fr.frBtns.frMisc.numCalls -textvariable gOpts(numCalls) -width 4
bind .fr.frBtns.frMisc.numCalls <Key-Return> "ExecTest"
tcl3dToolhelpAddBinding .fr.frBtns.frMisc.numCalls \
"Number of glDrawPixels and glReadPixels calls executed in test."
eval pack [winfo children .fr.frBtns.frMisc] -side left \
-anchor w -expand 1 -fill x
labelframe .fr.frBtns.frCmds -text "Test"
pack .fr.frBtns.frCmds -side left -padx 2
button .fr.frBtns.frCmds.exe -text "Run" -command "ExecTest"
eval pack [winfo children .fr.frBtns.frCmds] -side left \
-anchor w -expand 1 -fill x -padx 1
set gDemo(out) [tcl3dCreateScrolledText .fr.frReport "" \
-height 5 -width 60 -borderwidth 1 -font $gDemo(listFont)]
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
}
set i 0
while { $i < $argc } {
set curArg [lindex $argv $i]
if { $curArg eq "-help" || $curArg eq "--help" } {
puts "Usage: $argv0 \[Options\]"
puts "Options:"
puts " -size w h: Specify image width and height"
puts " -num n : Specify number of draw and read calls"
puts " -batch : Execute test and quit"
puts " -format : Specify image format (GL_RGB, GL_BGR, ...)"
puts " -type : Specify image type (GL_UNSIGNED_BYTE)"
ExitProg
} elseif { $curArg eq "-size" } {
incr i
set gOpts(imgWidth) [lindex $argv $i]
incr i
set gOpts(imgHeight) [lindex $argv $i]
set gOpts(imgSize) [format "%dx%d" $gOpts(imgWidth) $gOpts(imgHeight)]
set gDemo(winWidth) $gOpts(imgWidth)
set gDemo(winHeight) $gOpts(imgHeight)
} elseif { $curArg eq "-num" } {
incr i
set gOpts(numCalls) [lindex $argv $i]
} elseif { $curArg eq "-format" } {
incr i
set gOpts(curFormat) [lindex $argv $i]
if { [lsearch $gOpts(formatsList) $gOpts(curFormat)] < 0 } {
puts "Unknown format $gOpts(curFormat)"
puts "Formats available: $gOpts(formatsList)"
ExitProg
}
} elseif { $curArg eq "-type" } {
incr i
set gOpts(curType) [lindex $argv $i]
if { [lsearch $gOpts(typesList) $gOpts(curType)] < 0 } {
puts "Unknown type $gOpts(curType)"
puts "Types available: $gOpts(typesList)"
ExitProg
}
} elseif { $curArg eq "-batch" } {
set gOpts(batch) true
} else {
puts "Ignoring unknown option $curArg"
}
incr i
}
CreateWindow
NewImage
PrintInfo [tcl3dOglGetInfoString]
if { $gOpts(batch) } {
update
TimedDrawReadPixels
ExitProg
}
|
