# trislam.tcl
#
# Purpose: Determine performance curves for various methods of pushing
# triangles and quads through the OpenGL pipeline
#
# Copyright (c) 2004-2006, Geoff Broadwell; this script is released
# as open source and may be distributed and modified under the terms
# of either the Artistic License or the GNU General Public License,
# in the same manner as Perl itself. These licenses should have been
# distributed to you as part of your Perl distribution, and can be
# read using `perldoc perlartistic` and `perldoc perlgpl` respectively.
#
# Rewritten in Python by Bob Free
#
# Rewritten and extended for Tcl3D by Paul Obermeier, 2008
package require Tk
package require tcl3d
tcl3dConsoleCreate .tcl3dOutputConsole "# " "Console of TrislamTcl3D"
### USER CONFIG
# Primitive sizes (and therefore counts) are integer divisors of
# (A^i * B^j * C^k ...) where good A, B, C, ... are relatively prime;
# this number is used for the draw area height and width and defaults to:
# 2^4 * 3^2 * 5 = 720
# You may also want to get fewer data points across the same range by
# directly using higher powers; for example:
# 16 * 9 * 5 = 720
#
# max_powers = (16 => 1, 9 => 1, 5 => 1);
set max_powers [list 2 4 3 2 5 1]
# Maximum quads along each axis for known slow versus usually fast tests;
# chosen to be somewhat reasonable for most common settings of @max_powers
# my $max_count_slow = 60;
set max_count_slow 154
set max_count_fast 154
# Font to use to label graphs
set fontName {-family {Helvetica} -size 10}
### MISC GLOBALS
set VERSION "0.1.24"
set MIN_FRAMES 0
set MIN_SECONDS 0
set w 0
set h 0
set slow [list]
set fast [list]
set test 0
set run 0
set done 0
set ready 0
set showing_graph 0
set empty_time 0
set empty_frames 0
set optLineMode 1
# Create a stop watch for time measurement.
set stopwatch [tcl3dNewSwatch]
tcl3dStartSwatch $stopwatch
### BENCHMARK TYPES
array set va_types {
q make_quads_va
t make_tris_va
qs make_qs_va
ts make_ts_va
}
array set dl_types {
qs draw_qs
ts draw_ts
qsv draw_qs_va
tsv draw_ts_va
}
# Nick Draw Routine Stats Calc Type Graph Color
set testTemplates { \
{empty draw_empty stats_empty single {1.0 1.0 1.0} 0xFFFF} \
{t draw_tris stats_tris slow {1.0 0.0 0.0} 0xAAAA} \
{q draw_quads stats_quads slow {1.0 0.5 0.0} 0xAAAA} \
{ts draw_ts stats_ts slow {1.0 1.0 0.0} 0xAAAA} \
{qs draw_qs stats_qs slow {0.0 1.0 0.0} 0xAAAA} \
{tsd draw_ts_dl stats_ts fast {0.0 1.0 1.0} 0xAAAA} \
{qsd draw_qs_dl stats_qs fast {0.0 0.0 1.0} 0xAAAA} \
{tv draw_tris_va stats_tris fast {0.8 0.0 0.0} 0xFFFF} \
{qv draw_quads_va stats_quads fast {0.8 0.4 0.0} 0xFFFF} \
{tsv draw_ts_va stats_ts fast {0.8 0.8 0.0} 0xFFFF} \
{qsv draw_qs_va stats_qs fast {0.0 0.8 0.0} 0xFFFF} \
{tsvd draw_ts_va_dl stats_ts fast {0.0 0.8 0.8} 0xFFFF} \
{qsvd draw_qs_va_dl stats_qs fast {0.0 0.0 0.8} 0xFFFF} \
}
# Utility procedures for output to console and text widget.
proc PrintTextMsg { msg newline } {
append msg $newline
puts -nonewline $msg ; flush stdout
}
proc OUTS { msg } {
PrintTextMsg $msg "\n"
}
proc OUT { msg } {
PrintTextMsg $msg "\n"
}
proc OUTN { msg } {
PrintTextMsg $msg ""
}
# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg"
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
}
}
### BENCHMARK INITS
proc SelectionChanged {} {
global labels
set labels(selectionChanged) 1
}
proc Reset {} {
global test run done ready
global tests testTemplates stats
global max total
global labels
set test 0
set run 0
set done 0
set ready 0
ClearTestLabels
ClearCountLabels
set stats [list]
set total [list]
set max [list]
# Fill the tests list with the tests as selected in the GUI.
set tests [list]
foreach t $testTemplates {
set name [lindex $t 0]
if { $labels(usetest,$name) } {
lappend tests $t
}
}
set labels(selectionChanged) 0
}
proc make_quads_va { count size } {
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
for { set x 0 } { $x < $count } { incr x } {
set x0 [expr {$x * $size}]
set xs [expr {$x0 + $size}]
lappend l $x0 $ys $x0 $y0 $xs $y0 $xs $ys
}
}
return [tcl3dVectorFromList GLfloat $l]
}
proc make_qs_va { count size } {
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
for { set x 0 } { $x <= $count } { incr x } {
set x0 [expr {$x * $size}]
lappend l $x0 $ys $x0 $y0
}
}
return [tcl3dVectorFromList GLfloat $l]
}
proc make_tris_va { count size } {
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
for { set x 0 } { $x < $count } { incr x } {
set x0 [expr {$x * $size}]
set xs [expr {$x0 + $size}]
lappend l $x0 $ys $x0 $y0 $xs $ys
lappend l $xs $ys $x0 $y0 $xs $y0
}
}
return [tcl3dVectorFromList GLfloat $l]
}
proc make_ts_va { count size } {
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
for { set x 0 } { $x <= $count } { incr x } {
set x0 [expr {$x * $size}]
lappend l $x0 $ys $x0 $y0
}
}
return [tcl3dVectorFromList GLfloat $l]
}
### BENCHMARK METHODS
proc draw_empty { count size } {
return
}
proc stats_empty { count size } {
return [list 0 0 0 0]
}
proc draw_quads { count size } {
glBegin GL_QUADS
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
for { set x 0 } { $x < $count } { incr x } {
set x0 [expr {$x * $size}]
set xs [expr {$x0 + $size}]
glVertex2f $x0 $ys
glVertex2f $x0 $y0
glVertex2f $xs $y0
glVertex2f $xs $ys
}
}
glEnd
}
proc draw_quads_va { count size } {
global vas
set va $vas(q_$count)
glVertexPointer 2 GL_FLOAT 0 $va
glEnableClientState GL_VERTEX_ARRAY
glDrawArrays GL_QUADS 0 [expr {4 * $count * $count}]
glDisableClientState GL_VERTEX_ARRAY
}
proc stats_quads { count size } {
set length [expr {$size * $count}]
set area [expr {$length * $length}]
set prims [expr {$count * $count}]
set tris [expr {2 * $prims}]
set verts [expr {4 * $prims}]
return [list $area $prims $tris $verts]
}
proc draw_qs { count size } {
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
glBegin GL_QUAD_STRIP
for { set x 0 } { $x <= $count } { incr x } {
set x0 [expr {$x * $size}]
glVertex2f $x0 $ys
glVertex2f $x0 $y0
}
glEnd
}
}
proc draw_qs_va { count size } {
global vas
set va $vas(qs_$count)
set row [expr {2 * ($count + 1)}]
glVertexPointer 2 GL_FLOAT 0 $va
glEnableClientState GL_VERTEX_ARRAY
for { set y 0 } { $y < $count } { incr y } {
glDrawArrays GL_QUAD_STRIP [expr {$y * $row}] $row
}
glDisableClientState GL_VERTEX_ARRAY
}
proc draw_qs_dl { count size } {
global dls
glCallList $dls(qs_$count)
}
proc draw_qs_va_dl { count size } {
global vas dls
set va $vas(qs_$count)
glVertexPointer 2 GL_FLOAT 0 $va
glEnableClientState GL_VERTEX_ARRAY
glCallList $dls(qsv_$count)
glDisableClientState GL_VERTEX_ARRAY
}
proc stats_qs { count size } {
set length [expr {$size * $count}]
set area [expr {$length * $length}]
set prims $count
set tris [expr {2 * $count * $prims}]
set verts [expr {2 * ($count + 1) * $prims}]
return [list $area $prims $tris $verts]
}
proc draw_tris { count size } {
glBegin GL_TRIANGLES
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
for { set x 0 } { $x < $count } { incr x } {
set x0 [expr {$x * $size}]
set xs [expr {$x0 + $size}]
glVertex2f $x0 $ys
glVertex2f $x0 $y0
glVertex2f $xs $ys
glVertex2f $xs $ys
glVertex2f $x0 $y0
glVertex2f $xs $y0
}
}
glEnd
}
proc draw_tris_va { count size } {
global vas
set va $vas(t_$count)
glVertexPointer 2 GL_FLOAT 0 $va
glEnableClientState GL_VERTEX_ARRAY
glDrawArrays GL_TRIANGLES 0 [expr {6 * $count * $count}]
glDisableClientState GL_VERTEX_ARRAY
}
proc stats_tris { count size } {
set length [expr {$size * $count}]
set area [expr {$length * $length}]
set prims [expr {2 * $count * $count}]
set tris $prims
set verts [expr {3 * $prims}]
return [list $area $prims $tris $verts]
}
proc draw_ts { count size } {
for { set y 0 } { $y < $count } { incr y } {
set y0 [expr {$y * $size}]
set ys [expr {$y0 + $size}]
glBegin GL_TRIANGLE_STRIP
for { set x 0 } { $x <= $count } { incr x } {
set x0 [expr {$x * $size}]
glVertex2f $x0 $ys
glVertex2f $x0 $y0
}
glEnd
}
}
proc draw_ts_va { count size } {
global vas
set va $vas(ts_$count)
set row [expr {2 * ($count + 1)}]
glVertexPointer 2 GL_FLOAT 0 $va
glEnableClientState GL_VERTEX_ARRAY
for { set y 0 } { $y < $count } { incr y } {
glDrawArrays GL_TRIANGLE_STRIP [expr {$y * $row}] $row
}
glDisableClientState GL_VERTEX_ARRAY
}
proc draw_ts_dl { count size } {
global dls
glCallList $dls(ts_$count)
}
proc draw_ts_va_dl { count size } {
global vas dls
set va $vas(ts_$count)
glVertexPointer 2 GL_FLOAT 0 $va
glEnableClientState GL_VERTEX_ARRAY
glCallList $dls(tsv_$count)
glDisableClientState GL_VERTEX_ARRAY
}
proc stats_ts { count size } {
set length [expr {$size * $count}]
set area [expr {$length * $length}]
set prims $count
set tris [expr {2 * $count * $prims}]
set verts [expr {2 * ($count + 1) * $prims}]
return [list $area $prims $tris $verts]
}
# STATISTICS
proc fixup_stats {} {
global ready
global stats total
global max
global empty_time empty_frames
set stat [lindex $stats 0]
if { [lindex $stat 0] eq "empty" } {
set empty_time [lindex $stat 2]
set empty_frames [lindex $stat 3]
set empty_tpf [expr $empty_time / $empty_frames]
#puts "Found empty stat: $empty_time $empty_frames $empty_tpf"
while { [lindex $stat 0] eq "empty" } {
set stats [lrange $stats 1 end]
set stat [lindex $stats 0]
}
} else {
set empty_time 0
set empty_frames 0
set empty_tpf 0
}
lappend total "totl,"
lappend total 0
for { set i 0 } { $i < 12 } { incr i } {
lappend total 0.0
}
lappend max "max"
lappend max 0
for { set i 0 } { $i < 12 } { incr i } {
lappend max 0.0
}
set newstats [list]
foreach stat $stats {
foreach {name count secs frames pixpf prmpf tpf vpf} $stat { break }
# Subtract out empty loop time, and loop if negative result
# $time -= $empty_tpf * $frames;
if { $secs <= 0 } {
for { set i 0 } { $i < 5 } { incr i } {
lappend stat 0
}
continue
}
# Calc "work", the geometric mean of pixels and vertices
set workpf [expr sqrt (double ($pixpf) * $vpf)]
# Calc fps
set fps [expr double($frames) / $secs]
# Calc other perf stats
set pixps [expr $pixpf * $fps]
set prmps [expr $prmpf * $fps]
set tps [expr $tpf * $fps]
set vps [expr $vpf * $fps]
set wps [expr $workpf * $fps]
# Add them to stat row
lappend stat $fps $pixps $prmps $tps $vps $wps
# Convert per frame counts to totals
for { set i 4 } { $i < 8 } { incr i } {
lset stat $i [expr [lindex $stat $i] * double($frames)]
}
# Update running totals
for { set i 2 } { $i < 8 } { incr i } {
lset total $i [expr [lindex $total $i] + [lindex $stat $i]]
}
# Update running maximums
for { set i 2 } { $i < 14 } { incr i } {
if { [lindex $max $i] < [lindex $stat $i] } {
lset max $i [lindex $stat $i]
}
}
lappend newstats $stat
}
set stats $newstats
# Calc averages for totals line
for { set i 8 } { $i < 14 } { incr i } {
if { [lindex $total 2] == 0 } {
lset total $i 0
} else {
lset total $i [expr [lindex $total [expr $i-5]] / [lindex $total 2]]
}
}
lset total 1 "avg"
incr ready
}
proc show_stats {} {
global total stats
global empty_time empty_frames
set basic {Name Cnt Time}
set raw {Frms Mpix Kprim Ktri Kvert}
set calc $raw
set header [concat $basic $raw $calc]
set mags {0 6 3 3 3 0 6 3 3 3}
foreach i $mags {
lappend scale [expr pow (10, $i)]
}
set g_form "%9s%-*s%s"
set h_form "%-5s%3s %6s"
append h_form [string repeat " %5s" [llength $raw]]
append h_form [string repeat " %5s" [llength $calc]]
set fmt "%-5s%3s %6.3f"
append fmt [string repeat " %5d" [llength $raw]]
append fmt [string repeat " %5d" [llength $calc]]
OUT [format "Line mode %s" [expr $::optLineMode ? "ON" : "OFF"]]
OUT [format $g_form "" [expr 6*[llength $raw] + 8] "MEASURED" "PER SECOND"]
set cmd "format \"$h_form\" [join $header]"
OUTS [eval $cmd]
set empty_stat { \
"empty" "1" $empty_time $empty_frames \
0 0 0 0 0 0 0 0 0 \
}
set cmd "format \"$fmt\" [join $empty_stat]"
OUTS [eval $cmd]
lappend stats $total
foreach stat $stats {
set count 0
foreach val $stat {
set tstat($count) $val
incr count
}
for { set i 0 } { $i < [llength $scale] } { incr i } {
set tstat([expr $i+3]) [expr int ($tstat([expr $i+3]) / [lindex $scale $i])]
}
OUTS [format $fmt \
$tstat(0) $tstat(1) $tstat(2) $tstat(3) $tstat(4) $tstat(5) \
$tstat(6) $tstat(7) $tstat(8) $tstat(9) $tstat(10) $tstat(11) \
$tstat(12)]
}
}
proc kilo_mag { num } {
set mag [expr {int(log($num) / log(10))}]
return [expr {int($mag / 3)}]
}
proc mag_char { num } {
return [lindex {"" "K" "M" "G" "T" "P" "E" "Z" "Y"} [kilo_mag $num]]
}
proc mag_scale { num } {
return [expr {pow (10, [expr 3*[kilo_mag $num]])}]
}
proc tick_inc { max { parts 5 } } {
if { $max < 1 } {
return [expr {$max / $parts}]
}
set mag [expr {int(log($max) / log(10))}]
set scl [expr {pow (10, ($mag - 1))}]
set inc [expr {$max / ($scl * $parts)}]
if { $inc > 7.5 } {
set inc 10
} elseif { $inc > 3.5 } {
set inc 5
} elseif { $inc > 1.5 } {
set inc 2
} else {
set inc 1
}
return [expr {$inc * $scl}]
}
proc draw_one_stat { x_loc y_loc y_off x_scale num } {
global tests stats
global max h
set y_max [lindex $max $num]
set y_scale [expr {($h - 4.0*$y_off) / (2.0*$y_max)}]
foreach item $tests {
set name [lindex $item 0]
set colors($name) [lindex $item end-1]
set stipple($name) [lindex $item end]
}
set last ""
glEnable GL_LINE_STIPPLE
glBegin GL_LINE_STRIP
for { set run 0 } { $run < [llength $stats] -1 } { incr run } {
set stat [lindex $stats $run]
set name [lindex $stat 0]
set count [lindex $stat 1]
set value [lindex $stat $num]
if { $name ne $last } {
glEnd
glLineStipple 3 $stipple($name)
glBegin GL_LINE_STRIP
set color $colors($name)
glColor3f [lindex $color 0] [lindex $color 1] [lindex $color 2]
set last $name
}
glVertex2f [expr {$count*$x_scale + $x_loc}] [expr {$value*$y_scale + $y_loc}]
}
glEnd
glDisable GL_LINE_STIPPLE
}
proc draw_string { font str x y } {
set len [string length $str]
if { $len > 0 } {
glRasterPos2f $x $y
glListBase $font
set sa [tcl3dVectorFromString GLubyte $str]
glCallLists $len GL_UNSIGNED_BYTE $sa
$sa delete
}
}
proc draw_stats {} {
global ready
global w h
global slow fast
global tests
global max
global font_style
if { ! $ready } {
return
}
# Graph config
set x_off 10
set y_off 10
set tick_size 3
set val_space 50
set key_size 20
# OPA set x_count len(fast) and fast[-1] or slow[-1]
set x_count [lindex $slow end]
set x_scale [expr {($w - 4.0 * $x_off) / (2.0 * $x_count)}]
set key_scale [expr {($h - 4.0 * $y_off) / (2.0 * [llength $tests])}]
# Get a fresh black frame for graphing
glClearColor 0 0 0 1
start_frame
# Use antialiased lines
glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
glEnable GL_LINE_SMOOTH
glHint GL_LINE_SMOOTH_HINT GL_NICEST
# Draw axis ticks
glColor3f 1 1 1
glBegin GL_LINES
foreach count [concat 0 $slow $fast] {
set x_tick [expr {$count * $x_scale + $x_off}]
glVertex2f $x_tick $y_off
glVertex2f $x_tick [expr {$y_off - $tick_size}]
glVertex2f $x_tick [expr {$y_off + $h / 2.0}]
glVertex2f $x_tick [expr {$y_off + $h / 2.0 - $tick_size}]
glVertex2f [expr {$x_tick + $w / 2.0}] [expr {$y_off + $h / 2.0}]
glVertex2f [expr {$x_tick + $w / 2.0}] [expr {$y_off + $h / 2.0 - $tick_size}]
}
glEnd
set x_tick [expr {$x_off + 3}]
set val_max [expr {int(($h / 2.0 - 2.0 * $y_off) / $val_space)}]
# Work
for { set value 0 } { $value < $val_max } { incr value } {
set y_tick [expr {$value * $val_space + $y_off}]
glBegin GL_LINES
glVertex2f $x_off $y_tick
glVertex2f [expr {$x_off - $tick_size}] $y_tick
glEnd
}
# Pixels
set value 0
set val_max [expr {[lindex $max 9] / [mag_scale [lindex $max 9]] }]
set y_scale [expr {($h - 4.0 * $y_off) / (2.0 * $val_max)}]
set val_inc [tick_inc $val_max 5]
while { $value < $val_max } {
set y_tick [expr {($value * $y_scale) + $y_off}]
glBegin GL_LINES
glVertex2f $x_off [expr {$y_tick + $h / 2.0}]
glVertex2f [expr {$x_off - $tick_size}] [expr {$y_tick + $h / 2.0}]
glEnd
if { $value } {
draw_string $font_style $value $x_tick [expr {$y_tick + $h / 2.0}]
}
set value [expr {$value + $val_inc}]
}
# Vertices
set value 0
set val_max [expr {[lindex $max 12] / [mag_scale [lindex $max 12]] }]
set y_scale [expr {($h - 4.0 * $y_off) / (2.0 * $val_max)}]
set val_inc [tick_inc $val_max 5]
while { $value < $val_max } {
set y_tick [expr {($value * $y_scale) + $y_off}]
glBegin GL_LINES
glVertex2f [expr {$x_off + $w / 2.0}] [expr {$y_tick + $h / 2.0}]
glVertex2f [expr {$x_off + $w / 2.0 - $tick_size}] [expr {$y_tick + $h / 2.0}]
glEnd
if { $value } {
draw_string $font_style $value [expr {$x_tick + $w/2.0}] [expr {$y_tick + $h/2.0}]
}
set value [expr {$value + $val_inc}]
}
# Draw axes
glBegin GL_LINE_STRIP
glVertex2f $x_off [expr {$h / 2.0 - $y_off}]
glVertex2f $x_off $y_off
glVertex2f [expr {$w / 2.0 - $x_off}] $y_off
glEnd
glBegin GL_LINE_STRIP
glVertex2f $x_off [expr {$h - $y_off}]
glVertex2f $x_off [expr {$h / 2.0 + $y_off}]
glVertex2f [expr {$w / 2.0 - $x_off}] [expr {$h / 2.0 + $y_off}]
glEnd
glBegin GL_LINE_STRIP
glVertex2f [expr {$w / 2.0 + $x_off}] [expr {$h - $y_off}]
glVertex2f [expr {$w / 2.0 + $x_off}] [expr {$h / 2.0 + $y_off}]
glVertex2f [expr {$w - $x_off}] [expr {$h / 2.0 + $y_off}]
glEnd
# Draw color key
for { set num 0 } { $num < [llength $tests] } { incr num } {
set test [lindex $tests $num]
set name [lindex $test 0]
set color [lindex $test end-1]
set stipple [lindex $test end]
glEnable GL_LINE_STIPPLE
glLineStipple 3 $stipple
glBegin GL_LINES
glColor3f [lindex $color 0] [lindex $color 1] [lindex $color 2]
glVertex2f [expr {$x_off + $w / 2.0}] [expr {$y_off + $num * $key_scale}]
glVertex2f [expr {$x_off + $w / 2.0 + $key_size}] [expr {$y_off + $num * $key_scale}]
glEnd
glDisable GL_LINE_STIPPLE
draw_string $font_style $name \
[expr {$x_off+$w/2.0+$key_size*2.0}] \
[expr {$y_off+$num*$key_scale}]
}
# Draw performance graph lines
# Pixels per second
draw_one_stat $x_off [expr {$y_off + $h / 2.0}] $y_off $x_scale 9
glColor3f 1.0 1.0 1.0
draw_string $font_style "[mag_char [lindex $max 9]] Pixels/Sec" \
[expr {$w/4.0}] [expr {$h-2.0*$y_off}]
# Vertices per second
draw_one_stat [expr {$x_off + $w/2.0}] [expr {$y_off + $h/2.0}] $y_off $x_scale 12
glColor3f 1.0 1.0 1.0
draw_string $font_style "[mag_char [lindex $max 12]] Vertices/Sec" \
[expr {3.0*$w/4.0}] [expr {$h-2.0*$y_off}]
# "Work" per second, the geometric mean of pixels and vertices
draw_one_stat $x_off $y_off $y_off $x_scale 13
glColor3f 1.0 1.0 1.0
draw_string $font_style "Work/Sec" [expr {$w/4.0}] [expr {$h/2.0 - 2.0*$y_off}]
# Show our graph
end_frame
set showing_graph 1
}
proc RedrawStats {} {
fixup_stats
show_stats
draw_stats
}
proc display { toglwin } {
global done ready
global tests
if { ! [info exists tests] || [llength $tests] == 0 } {
start_frame
end_frame
return
}
if { ! $done && [info exists ::animateId] } {
benchmark
} elseif { ! $ready && [info exists ::animateId] } {
RedrawStats
} elseif { $done && $ready } {
StopAnimation
set ::startStop 0
draw_stats
}
}
proc Animate {} {
.fr.toglwin postredisplay
set ::animateId [tcl3dAfterIdle Animate]
}
# This procedure should not be named StartAnimation, as this a reserved
# name of the Tcl3D presentation framework for demos which should be
# automatically animated after startup, which we don't want for this demo.
proc StartAnimationTest {} {
global labels
if { ! [info exists ::animateId] } {
if { $labels(selectionChanged) } {
Reset
}
Animate
}
}
proc StopAnimation {} {
if { [info exists ::animateId] } {
after cancel $::animateId
unset ::animateId
}
}
proc StartStopAnimation {} {
if { [info exists ::animateId] } {
StopAnimation
} else {
StartAnimationTest
}
}
proc start_frame {} {
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
}
proc end_frame {} {
glFinish
}
proc fade_to_white { frac } {
glColor4f $frac $frac $frac 1
glClearColor $frac $frac $frac 1
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
glFinish
}
proc benchmark {} {
global MIN_FRAMES MIN_SECONDS
global w h
global stats tests test
global done run
global slow fast
global labels
if { $test >= [llength $tests] } {
if { ! $done } {
OUT "."
}
incr done
return
}
set currentTest [lindex $tests $test]
foreach { name draw do_stats class } $currentTest { break }
if { $class eq "single" } {
set counts [list 1]
} elseif { $class eq "slow" } {
set counts $slow
} else {
set counts [concat $slow $fast]
}
$labels(test,$name) configure -background yellow
if { ! $run } {
OUTN " $name" ; flush stdout
}
set count [lindex $counts $run]
set size [expr $w / $count]
$labels(count,$count) configure -background yellow
fade_to_white [expr ($test + (double($run)/[llength $counts])) / \
[llength $tests]]
# Set polygon mode.
if { $::optLineMode } {
glColor3f 0 1 0
glPolygonMode GL_FRONT_AND_BACK GL_LINE
} else {
glPolygonMode GL_FRONT_AND_BACK GL_POLYGON
}
set run_done 0
set frames 0
tcl3dResetSwatch $::stopwatch
while { ! $run_done } {
start_frame
$draw $count $size
end_frame
incr frames
if { $MIN_FRAMES <= $frames && \
$MIN_SECONDS <= [tcl3dLookupSwatch $::stopwatch] } {
set run_done 1
}
}
glFinish
set secs [tcl3dLookupSwatch $::stopwatch]
lappend stats [join [list $name $count $secs $frames \
[$do_stats $count $size]]]
incr run
if { $run >= [llength $counts] } {
$labels(test,$name) configure -background green
ClearCountLabels
incr test
set run 0
}
}
proc init_display_lists {} {
global w h
global dl_types dls
global slow fast
OUTN "Init display lists:"
set l [concat $slow $fast]
set num_lists [expr [array size dl_types] * [llength $l]]
set current [glGenLists $num_lists]
set types [lsort [array names dl_types]]
tcl3dResetSwatch $::stopwatch
foreach type $types {
OUTN " $type" ; flush stdout
foreach count $l {
set dls(${type}_${count}) $current
glNewList $current GL_COMPILE
incr current
set drawFunc $dl_types($type)
$drawFunc $count [expr $w / $count]
glEndList
}
}
set secs [format " (%.2f secs)" [tcl3dLookupSwatch $::stopwatch]]
OUT "$secs"
}
proc init_vertex_arrays {} {
global w h
global va_types vas
global slow fast
OUTN "Init vertex arrays:"
set types [lsort [array names va_types]]
tcl3dResetSwatch $::stopwatch
foreach type $types {
OUTN " $type" ; flush stdout
set l [concat $slow $fast]
foreach count $l {
set dataFunc $va_types($type)
set data [$dataFunc $count [expr $w / $count]]
set vas(${type}_${count}) $data
}
}
set secs [format " (%.2f secs)" [tcl3dLookupSwatch $::stopwatch]]
OUT "$secs"
}
proc show_basic_config { version } {
global conf
OUT "$conf(title), version $version\n"
OUT "Operating system: $::tcl_platform(os)"
OUT "Tcl version: [info patchlevel]"
OUT "Graphic card: [glGetString GL_RENDERER]"
OUT "OpenGL version: [glGetString GL_VERSION]"
OUT ""
OUT "window size: $conf(width) x $conf(height)"
OUT "min frames/test: $conf(frames)"
OUT "min seconds/test: $conf(seconds)"
}
proc show_user_message {} {
global slow fast
set msg {
TRISLAM benchmarks several methods of pushing OpenGL primitives,
testing each method with various primitive counts and sizes.
During the benchmark, the test window will start out black, slowly
brightening to white as testing progresses. Once benchmarking is
complete, the collected data will be dumped in tabular form.
The configuration for this series of tests will be as follows:
}
OUT $msg
show_basic_config $::VERSION
OUT "standard runs: "
foreach i $slow {
OUTN " $i"
}
OUT ""
OUT "extra fast runs: "
foreach i $fast {
OUTN " $i"
}
OUT ""
OUT [string repeat "-" 80]
OUT ""
}
proc recurse_combos { argList } {
if { [llength $argList] == 0 } {
return [list 1]
}
set base [lindex $argList 0]
set max_power [lindex $argList 1]
set combos [list]
for { set power 0 } { $power <= $max_power } { incr power } {
set multiplier [expr int (pow ($base, $power))]
foreach item [recurse_combos [lrange $argList 2 end]] {
lappend combos [expr {$item * $multiplier}]
}
}
return $combos
}
proc ClearTestLabels {} {
global labels
foreach key [array names labels "test,*"] {
$labels($key) configure -background white
}
}
proc ClearCountLabels {} {
global labels
foreach key [array names labels "count,*"] {
$labels($key) configure -background white
}
}
proc SetAllTests { allTestsOn } {
global labels
foreach key [array names labels "usetest,*"] {
set labels($key) $allTestsOn
}
SelectionChanged
}
proc AllTestsOn {} {
SetAllTests 1
}
proc AllTestsOff {} {
SetAllTests 0
}
proc SnapShot { fileName } {
. configure -cursor watch
update
if { $fileName ne "" } {
# Create a name on the file system, if running from within a Starpack.
set fileName [tcl3dGenExtName $fileName]
set imgName [file rootname $fileName]
set imgExt ".png"
set imgFmt "PNG"
append imgName $imgExt
tcl3dWidget2File . $imgName "*Console*" $imgFmt
puts "Screenshot written to: $imgName"
}
. configure -cursor top_left_arrow
}
proc SaveSnapshot {} {
global ready done run
global test tests
set fileName ""
if { $done && $ready } {
set fileName "trislam-stat"
} elseif { ! $done } {
set currentTest [lindex $tests $test]
set testName [lindex $currentTest 0]
set fileName "trislam-$testName-$run"
}
if { $fileName ne "" } {
SnapShot $fileName
}
}
proc init_opengl { title w h } {
global testTemplates
global slow fast
global labels
frame .fr
pack .fr -expand 1 -fill both
set toglwin .fr.toglwin
togl $toglwin -width $w -height $h \
-double false -depth true \
-displaycommand display
frame .fr.btns
label .fr.info
grid $toglwin -row 0 -column 0 -sticky news
grid .fr.btns -row 0 -column 1 -sticky new
grid .fr.info -row 1 -column 0 -sticky news -columnspan 2
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
set actionFrame .fr.btns.actionFr
labelframe $actionFrame -text "Actions"
pack $actionFrame -side top -fill x -expand 1 -pady 5 -padx 2
checkbutton $actionFrame.start -indicatoron false -text "Start" \
-variable ::startStop -command StartStopAnimation
pack $actionFrame.start -side top -fill x -expand 1
button $actionFrame.reset -text "Reset" -command Reset
pack $actionFrame.reset -side top -fill x -expand 1
button $actionFrame.snap -text "Snapshot" -command SaveSnapshot
pack $actionFrame.snap -side top -fill x -expand 1
set optionFrame .fr.btns.optionFr
labelframe $optionFrame -text "Options"
pack $optionFrame -side top -fill x -expand 1 -pady 5 -padx 2
checkbutton $optionFrame.line -text "Line Mode" -variable ::optLineMode
pack $optionFrame.line -side top -fill x -expand 1
set testFrame .fr.btns.testFr
labelframe $testFrame -text "Test Selection"
pack $testFrame -side top -fill x -expand 1 -pady 5 -padx 2
set labels(selectionChanged) 0
foreach t $testTemplates {
set name [lindex $t 0]
set labels(usetest,$name) 0
set labels(test,$name) [checkbutton $testFrame.cb_$name \
-text $name -bg white -anchor w \
-command SelectionChanged \
-variable labels(usetest,$name)]
pack $testFrame.cb_$name -side top -fill x
}
set labels(usetest,t) 1
SelectionChanged
button $testFrame.allOn -text "All On" -command AllTestsOn
pack $testFrame.allOn -side top -fill x -expand 1
button $testFrame.allOff -text "All Off" -command AllTestsOff
pack $testFrame.allOff -side top -fill x -expand 1
set infoFrame .fr.btns.infoFr
labelframe $infoFrame -text "Count Info"
pack $infoFrame -side top -fill x -expand 1 -pady 5 -padx 2
frame $infoFrame.fr0
frame $infoFrame.fr1
frame $infoFrame.fr2
pack $infoFrame.fr0 $infoFrame.fr1 $infoFrame.fr2 \
-side left -fill both -expand 1
set ind 0
foreach c [concat $slow $fast] {
set frInd [expr $ind % 3]
set labels(count,$c) [label $infoFrame.fr$frInd.l_$c -text $c -bg white]
pack $infoFrame.fr$frInd.l_$c -side top -fill x
incr ind
}
wm title . $title
return $toglwin
}
proc init {} {
global MIN_FRAMES MIN_SECONDS
global w h
global conf
global slow fast
global max_powers max_count_slow max_count_fast
global font_style
# Figure out primitive counts for each run of each test type
catch { unset ::combo_hash }
foreach item [recurse_combos $max_powers] {
set ::combo_hash($item) [list]
}
set combos [lsort -integer [array names ::combo_hash]]
foreach item $combos {
set i [expr int($item)]
if { $i <= $max_count_slow } {
lappend slow $i
}
if { $i > $max_count_slow && $i <= $max_count_fast } {
lappend fast $i
}
}
# Choose drawing area size to match counts
set h [expr int([lindex $combos end])]
set w $h
# Do the standard init stuff, including command line processing,
# window creation, and so on
array set conf [list \
"title" "Tcl3D demo: Triangle Slammer OpenGL Benchmark" \
"width" $w \
"height" $h \
"geometry" "${w}x${h}" \
"frames" 10 \
"seconds" 1 \
]
set toglwin [init_opengl $conf(title) $w $h]
# Reduce indirections in inner loops
set MIN_FRAMES $conf(frames)
set MIN_SECONDS $conf(seconds)
# Let user know what's going on
show_user_message
# Change projection to integer-pixel ortho
glMatrixMode GL_PROJECTION
glOrtho 0 [expr $w +1] 0 [expr $h +1] -1 1
glMatrixMode GL_MODELVIEW
# Load font for graph labels
set retVal [catch { $toglwin loadbitmapfont $::fontName } font_style]
if { $retVal != 0 } {
set font_style [$toglwin loadbitmapfont]
}
# Make sure GL state is consistent for VA and DL creation
start_frame
# Create vertex arrays and display lists outside timing loop
init_vertex_arrays
init_display_lists
# Clean up GL state
end_frame
}
# Cleanup procedure needed only, when this script is used from
# the presentation framework.
proc Cleanup {} {
uplevel #0 unset max_powers
uplevel #0 unset slow
uplevel #0 unset fast
uplevel #0 unset va_types
uplevel #0 unset dl_types
uplevel #0 unset testTemplates
uplevel #0 unset labels
uplevel #0 unset stats
uplevel #0 unset total
uplevel #0 unset max
uplevel #0 unset tests
uplevel #0 unset vas
uplevel #0 unset dls
uplevel #0 unset conf
uplevel #0 unset combo_hash
$::stopwatch -delete
}
proc ExitProg {} {
exit
}
# Main app
init
Reset
OUT "Benchmarks: "
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
PrintInfo [tcl3dOglGetInfoString]
if { [file tail [info script]] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then start animation.
update
set ::startStop 1
StartStopAnimation
}
|
