package require Tk
cd [file dirname [info script]]

option add *Text.font "Courier 18 bold"
option add *Text.height 10
option add *Text.width 50

proc init {} {

    wm title . "Tcl $::tcl_patchLevel timings"
    # Interface for comparing run speeds of different snippets of code
    eval destroy [winfo children .]
    label .l1 -textvariable ::one -fg red -font {courier 16 bold}
    text .t1 -yscrollcommand {.v1 set} \
	    -xscrollcommand {.h1 set}
    scrollbar .v1 -orient vert -command {.t1 yview}
    scrollbar .h1 -orient horiz -command {.t1 xview}

    label .l2 -textvariable ::two -fg red -font {courier 16 bold}
    text .t2 -yscrollcommand {.v2 set} \
	    -xscrollcommand {.h2 set}
    scrollbar .v2 -orient vert -command {.t2 yview}
    scrollbar .h2 -orient horiz -command {.t2 xview}

    label .l3 -textvariable ::status -fg red -font {courier 16 bold}

    frame .f
    button .f.b -text "Run" -command runTests
    button .f.b1 -text "Edit extras" -command showExtraStuff
    button .f.b2 -text "Load One" -command {loadFile .t1}
    button .f.b3 -text "Load Two" -command {loadFile .t2}
    button .f.b4 -text "Exit" -command exit

    frame .f.spinbox
    label .f.spinbox.l -text "Iterations:"
    entry .f.spinbox.s -textvariable ::iterations

    # grid text boxes
    grid .l1 -sticky nw
    grid .t1 .v1 -sticky nsew
    grid .h1 -sticky ew
    grid .l2 -sticky nw
    grid .t2 .v2 -sticky nsew
    grid .h2 -sticky ew
    grid .l3 -sticky nw

    # grid results box
    pack .f.spinbox.l -side left
    pack .f.spinbox.s -side left -expand yes -fill x
    grid .f -sticky nsew
    pack .f.spinbox .f.b .f.b1 .f.b2 .f.b3 .f.b4 \
	    -expand yes -fill x -side left -padx 4
    grid rowconfigure . {1 4 5} -weight 1
    grid columnconfigure . {0} -weight 1

    set ::iterations 1000
    set ::one "Sample one:"
    set ::two "Sample two:"
    set ::extras ""
    set ::status ""
}

# How to load files
proc loadFile {which} {
    set f [tk_getOpenFile]
    if { [string equal $f ""] } {
	return
    }
    set fd [open $f r]
    $which delete 1.0 end
    $which insert end [read $fd [file size $f]]
    close $fd
    return
}

# Make the "extra stuff" window
proc showExtraStuff {} {
    if {[winfo exists .t]} {
	wm deiconify .t
	raise .t
	return
    }
    toplevel .t
    text .t.t -yscrollcommand {.t.v set} -xscrollcommand {.t.h set}
    scrollbar .t.v -command {.t.t yview} -orient vert
    scrollbar .t.h -command {.t.t xview} -orient horiz
    grid .t.t -row 0 -col 0 -sticky nsew
    grid .t.v -row 0 -col 1 -sticky ns
    grid .t.h -row 1 -col 0 -sticky ew
    grid columnconfigure .t 0 -weight 1
    grid rowconfigure .t 0 -weight 1
    .t.t insert end $::extras
    wm title .t "Additional code to be sourced before timing"
    wm protocol .t WM_DELETE_WINDOW {
	set ::extras [.t.t get 1.0 end]
	destroy .t
    }
}

proc runTests {} {
    set oldCursor [. cget -cursor]
    . configure -cursor watch
    # Source extra code
    if { [catch {
	if { [winfo exists .t] } {
	    eval [.t.t get 1.0 end]
	} else {
	    eval $::extras
	}
    } msg] } {
	. configure -cursor $oldCursor
	tk_messageBox -message $msg -title "Error" -icon error -type ok
	return
    }

    # Get the scripts
    set script1 [.t1 get 1.0 end]
    set script2 [.t2 get 1.0 end]
    
    # make procs
    proc test1 {} $script1
    proc test2 {} $script2
    if { [catch test1 msg] || [catch test2 msg]} {
	tk_messageBox -message $msg -title "Error" -icon error -type ok
	. configure -cursor $oldCursor
	return
    }

    # do the timing
    set ::results ""
    foreach cmd {test1 test2} key {one two} {
	set t [clock clicks]
	for {set i 0} {$i < $::iterations} {incr i} {
	    $cmd
	}
	set t2 [clock clicks]
	if {$t < $t2} {
	    set delta [expr {$t2 - $t}]
	} else {
	    set delta [expr {$t - $t2 + 0xFFFFFFFF}]
	}
	set val [expr {double($delta)/$::iterations}]
	set data($key) $delta
	set ::$key "Sample $key:\t[format %1.3f $val]\
		microseconds/iteration"
    }
    if {$data(one) > $data(two)} {
	set perc [expr {double($data(one)) / $data(two)}]
	set ::status "Sample ONE is [format %2.3f $perc] times slower"
    } else {
	set perc [expr {100 * double($data(two) - $data(one)) / $data(two)}]
	set perc [expr {double($data(two)) / $data(one)}]
	set ::status "Sample TWO is [format %2.3f $perc] times slower"
    }
    bell; bell
    . configure -cursor $oldCursor
}

init
