Tpett - Tcl Proc Evaluator/Timer/Tester

Directions to find it at [Stu]

[Stu] - 2007/10/18 Created this page. As a testament to Tcl and this Wiki, this program took about a day to write initially and a few more hours to finish off a quickie 0.1 version. Pretty good since I hadn't done any gui programming in quite some time (years?) and had never really used a [canvas]. Getting the gui to [grid] properly took maybe 20% of the time - grrr. 
----
From the help:

"Tpett is for to test and graph Tcl proc performance, allowing for simple proc performance comparisons."

Screenshot:

[http://img514.imageshack.us/img514/5868/tpettchrscrub4.gif]


The distribution files contain the source and some examples but for you masochistic types, here's the source code (some of it is not pretty, especially the graphing code which is not quite right in the head. You've been warned):

 #! /bin/sh
 # \
 exec tclsh "$0" ${1+"$@"}
 package require Tk
 
 # Tpett - Tcl Proc Evaluator/Timer/Tester
 # 0.1
 # October 2007
 # Stuart Cassoff
 # With lots of help from the Tcler's Wiki
 #
 
 namespace eval tpett {
        variable cfg
        variable results
 
        set cfg(prog) {Tpett}
        set cfg(name) {Tcl Proc Evaluator/Timer/Tester}
        set cfg(ver) {0.1}
        set cfg(date) {October 2007}
        set cfg(author) {Stuart Cassoff}
        set cfg(license) {BSD}
        set cfg(smooth) 1
        set cfg(title) {}
        set cfg(xaxistitle) {}
        set cfg(colors) [list cornsilk gold goldenrod burlywood coral2 chartreuse cyan brown green blue white papayawhip bisque]
        set cfg(procs) {}
 
        array set results {}
 }
 
 proc tpett::sourcefile {what fn} {
        variable gui
        variable cfg
        $gui($what) delete 1.0 end
        set f [open $fn r]; $gui($what) insert end [read $f]; close $f
 }
 proc tpett::loadfile {what} {
        rename ::proc ::tpett::tpettproc 
        rename ::tpett::_proc ::proc 
        set fn [tk_getOpenFile -title [expr {$what eq {pt} ? {To Test} : {Run Test}}]]
        rename ::proc ::tpett::_proc
        rename ::tpett::tpettproc ::proc
        if {$fn ne {}} {
                sourcefile $what $fn
        }
 }
 
 proc tpett::setagoodexample {} {
        variable gui
 
        $gui(pt) delete 1.0 end
        $gui(pt) insert end {proc toupper {string} {
         return [string toupper $string]
 }
 proc tolower {string} {
         return [string tolower $string]
 }
 proc totitle {string} {
         return [string totitle $string]
 }
 proc tonothing {string} {}
 }
 
        $gui(tt) delete 1.0 end
        $gui(tt) insert end {title "String Command Tests"
 xaxistitle "Input String Size"
 set times 1000
 foreach p [getprocs] {
         for {set i 10} {$i <= 100} {incr i 10} {
                 set data [string repeat Aa $i]
                 set size [string length $data]
 
                 test $p $data $size $times
         }
 }
 }
         evaltext_pt
         evaltext_tt
 }
 
 proc tpett::setinfo {} {
        variable cfg
        variable gui
        $gui(thelp) insert end [subst {$cfg(prog) - $cfg(name)
 $cfg(ver)
 $cfg(date)
 $cfg(author)
 License: $cfg(license)
 
 $cfg(prog) is for to test and graph Tcl proc performance,
 allowing for simple proc performance comparisons.
 
 Put procs to test in "To Test". Click "Eval".
 Put test code in "Run Test". Click "Eval".
 
 When "To Test" code is evaluated, $cfg(prog) will automatically accumulate procs.
 Accumulated procs will show in "Procs" listbox on right.
 Double click on a proc in "Procs" listbox to select or deselect it for testing.
 
 To test, the command \[test\] must be called with the following parameters:
 procname:  Name of proc to test.
 argument:  Argument to proc. Only one argument possible now. Maybe more later.
 testpoint: Value of testpoint; ex: \[string length \$inputData\].
 times:     How many times (as in the \[time\] command) to run the proc. Optional; default: 1.
 
 The command \[getprocs\] will return a list of selected accumulated procs,
 
 The command \[title\] will set the title of the graph; ex: title "String Command Tests".
 
 The command \[xaxistitle\] will set the title of the x-axis of the graph;
 ex: xaxistitle "Input String Size".
 
 Check or uncheck "Smooth" for desired smoothiness.
 
 Click "Exit" button or press "Esc" key to exit program.
 Unplugging computer will also work.
 
 Click one of the "Load" buttons to enable loading of program data file information
 from rigid spinning disk platter, solid state storage, magnetic drum, conga drum,
 abacus, usb-connected windchimes or extraterrestrial transmission.
 
 Click "Example" button or run without args to get example usage.
 
 Run from command line:
 \$ ./tpett.tcl totest.tcl runtest.tcl
 }]
 }
 
 proc tpett::setupgui {{w {}}} {
        variable cfg
        variable gui
        set gui(cw) 600
        set gui(ch) 400
        set ns [namespace current]
 
        grid [set gui(pw) [panedwindow $w.pw]] -sticky nsew
        $gui(pw) add [canvas [set gui(cnv) $gui(pw).cnv] -width $gui(cw) -height $gui(ch) -bg black]
        $gui(pw) add [set gui(thelp) [text $gui(pw).thelp -width 10]]
        $gui(pw) sash place 0 65535 0
 
        grid ^ [set f [frame $w.f0]] -sticky ns
        grid [label $f.lh -text {<- Slide For Help}] -pady 3 -sticky nw
        grid [label $f.ll -text Procs] -sticky s
        grid [set gui(lb) [listbox $f.lb -width 2 -listvariable ${ns}::cfg(procs)]] -sticky nsew
        grid [checkbutton $f.sb -text Smooth -command ${ns}::graph -variable ${ns}::cfg(smooth)] -sticky sew
        grid [button $f.eb -text Example -command ${ns}::setagoodexample] -sticky sew
        grid [button $f.eq -text Exit -command exit] -sticky sew
 
        set tw 80
        set th 10
        grid [text [set gui(pt) $w.pt] -width $tw -height $th] -sticky nsew
        grid ^ [set f [frame $w.f1]] -sticky nsew
        grid [label $f.lt -text {To Test}] -sticky ns
        grid [button $f.plb -text Load -command [list ${ns}::loadfile pt]] -sticky sew
        grid [button $f.pb -text Eval -command ${ns}::evaltext_pt] -sticky sew
 
        set tw 80
        set th 11
        grid [text [set gui(tt) $w.tt] -width $tw -height $th] -sticky nsew
        grid ^ [set f [frame $w.f2]] -sticky nsew
        grid [label $f.lr -text {Run Test}] -sticky ns
        grid [button $f.tlb -text Load -command [list ${ns}::loadfile tt]] -sticky sew
        grid [button $f.tb -text Eval -command ${ns}::evaltext_tt] -sticky sew
 
        grid columnconfigure . 0 -weight 1
        foreach r [list 0 1 2 3 4 5] wght [list 0 1 0 1 0 1] {
                grid rowconfigure . $r -weight $wght
        }
        grid rowconfigure $w.f0 2 -weight 1
        foreach f [list 1 2] {
                grid columnconfigure $w.f$f 0 -weight 1
                grid rowconfigure $w.f$f 0 -weight 1
        }
 
        bind . <Escape> exit
        bind $gui(cnv) <Configure> ${ns}::graph
        bind .f0.lb <Double-1> [list ${ns}::procselect %W]
 
        wm title . "$cfg(prog) $cfg(ver)"
 }
 proc ::tpett::procselect {w} {
        set csc [$w itemcget [$w curselection] -foreground]
        if {$csc eq {} || $csc eq [$w cget -foreground]} {
                set fg goldenrod
                set sfg $fg
        } else {
                set fg [$w cget -foreground]
                set sfg $fg
        }
        $w itemconfigure [$w curselection] -foreground $fg -selectforeground $sfg
 }
 
 proc tpett::evaltext_pt {} {
        variable gui
        variable cfg
        set cfg(procs) {}
        eval [$gui(pt) get 1.0 end]
 }
 proc tpett::evaltext_tt {} {
        variable gui
        reset
        namespace eval [namespace current] [$gui(tt) get 1.0 end]
        graph
 }
 
 proc tpett::title {title} {
        variable cfg
        set cfg(title) $title
 }
 proc tpett::xaxistitle {title} {
        variable cfg
        set cfg(xaxistitle) $title
 }
 
 proc tpett::graph {} {
        variable cfg
        variable gui
        variable results
 
        if {[llength [array names results]]  == 0} {
                return
        }
 
        set cw [winfo width $gui(cnv)]
        set ch [winfo height $gui(cnv)]
 
        set gox 130
        set goy 70
        set gw [expr {$cw - ($gox * 2)}]
        set gh [expr {$ch - ($goy * 2)}]
 
        set ln {}
        set lx {}
        set ly {}
        foreach r [lsort -dictionary [array names results]] {
                lappend ln [lindex [split $r ,] 0]
                lappend lx [lindex [split $r ,] 1]
                lappend ly $results($r)
        }
        set minx [lindex $lx 0]
        set miny [lindex [lsort -integer $ly] 0]
        set maxx [lindex $lx end]
        set maxy [lindex [lsort -integer $ly] end]
        set scalex [expr {($gw * 1.0) / ($maxx * 1.0)}]
        set scaley [expr {($gh * 1.0) / ($maxy * 1.0)}]

        foreach n [lsort -unique $ln] c $cfg(colors) {
                set clrs($n) $c
        }
 
        $gui(cnv) delete all
 
        $gui(cnv) create text [expr {$gox + (($gw - 0) / 2)}] [expr {20}] -fill red -text $cfg(title) -font {Helvetica 16}
 
        set l {}
        set nn [lindex $ln 0]
        foreach n $ln x $lx y $ly {
                if {$nn ne $n} {
                        $gui(cnv) create line $l -fill $clrs($nn) -smooth $cfg(smooth)
                        set nn $n
                        set l {}
                }       
                lappend l [expr {$gox + int(($x - $minx) * $scalex)}] [expr {$goy + $gh - int(($y - $miny)* $scaley)}]
        }
        $gui(cnv) create line $l -fill $clrs($nn) -smooth $cfg(smooth)
 
        set bb 10
        $gui(cnv) create rectangle [expr {$gox - $bb}] [expr {$goy - $bb}] [expr {$gw + $gox + $bb}] [expr {$gh + $goy + $bb}] -outline red

        set x [expr {$gox - 16}]
        for {set i $miny} { $i <= $maxy} {set i [expr {$i + (($maxy - $miny) / 10)}]} {
                set y [expr {$gh + $goy - int(($i - $miny) * $scaley)}]
                $gui(cnv) create line $x $y [expr {$x + 5}] $y -fill red
                $gui(cnv) create text [expr {$x - 15}] $y -fill red -text $i
        }
        $gui(cnv) create text [expr {$gox - 55}] [expr {$goy + (($gh - 0) / 2)}] -fill red -text T\n\ i\nm\ne\n\n\u03bc\ns
 
        set y [expr {$gh + $goy + $bb + 2}]
        for {set i $minx} { $i <= $maxx} {set i [expr {$i + (($maxx - $minx) / 10)}]} {
                set x [expr {$gox + int(($i - $minx) * $scalex)}]
                $gui(cnv) create line $x $y $x [expr {$y + 5}] -fill red
                $gui(cnv) create text $x [expr {$y + 15}] -fill red -text $i
        }
        $gui(cnv) create text [expr {$gox + (($gw - 0) / 2)}] [expr {$y + 35}] -fill red -text $cfg(xaxistitle)
 
        set tx [expr {10}]
        set ty [expr {10}]
        set th [expr {20}]
        foreach n [lsort -unique $ln] {
                $gui(cnv) create text $tx $ty -text $n -fill $clrs($n) -anchor nw
                incr ty $th
        }
 }

 proc tpett::test {procname argument testpoint {times {1}}} {
        variable results
        set results($procname,$testpoint) [expr {int([lindex [time [list $procname $argument] $times] 0])}]
 }
 proc tpett::reset {} {
        variable results
        array unset results
        array set results {}
 }
 proc tpett::print {} {
        variable results
        parray results
 }
 proc tpett::getprocs {} {
        variable cfg
        variable gui
        set procs {}
        for {set i 0} {$i < [$gui(lb) index end]} {incr i} {
                set csc [$gui(lb) itemcget $i -foreground]
                if {$csc eq {} || $csc eq [$gui(lb) cget -foreground]} {                
                        lappend procs [$gui(lb) get $i]
                }
        }
        return $procs
 }
 
 proc tpett::usage {} {
        variable cfg
        puts "$cfg(prog) $cfg(ver): $cfg(name)"
        puts {Usage: tpett.tcl [totest.file] [runtest.file]}
 }
 
 #
 proc tpett::tpettproc {name args body} {
        if {[string range $name 0 5] ne {::tk::} && [lsearch $::tpett::cfg(procs) $name] == -1} {
                lappend ::tpett::cfg(procs) $name
        }
        ::tpett::_proc $name $args $body
 }
 rename ::proc ::tpett::_proc
 rename ::tpett::tpettproc ::proc
 #
 
 namespace eval tpett {
        setupgui
        setinfo
        if {$::argc == 0} {
                setagoodexample
        }
        if {$::argc > 2 || ($::argc >= 1 && [lsearch $::argv {-?}] != -1)} {
                usage
                exit
        }
        if {$::argc >= 1} {
                sourcefile pt [lindex $::argv 0]
        }
        if {$::argc == 2} {
                sourcefile tt [lindex $::argv 1]
                evaltext_pt
                evaltext_tt
        }
 }
 
 # EOF

<<categories>>Performance