4 proc bench
{title script
} {
5 global benchmarks batchmode
7 set Title
[string range
"$title " 0 20]
9 set failed
[catch {time $script} res
]
11 if {!$batchmode} {puts "$Title - This test can't run on this interpreter"}
12 lappend benchmarks
$title F
14 set t
[expr [lindex $res 0] / 1000]
15 lappend benchmarks
$title $t
17 set ts
[string range
$ts [expr {[string length
$ts]-10}] end
]
18 if {!$batchmode} {puts "$Title -$ts ms per iteration"}
23 ### BUSY LOOP ##################################################################
25 proc whilebusyloop
{} {
27 while {$i < 1850000} {
34 for {set i
0} {$i < 1850000} {incr i
} {
39 ### FIBONACCI ##################################################################
45 expr {[fibonacci
[expr {$x-1}]] + [fibonacci
[expr {$x-2}]]}
49 ### HEAPSORT ###################################################################
57 proc make_gen_random
{} {
59 set params
[list IM
$IM IA
$IA IC
$IC]
60 set body
[string map
$params {
62 expr {($max * [set last
[expr {($last * IA
+ IC
) % IM
}]]) / IM
}
64 proc gen_random
{max
} $body
67 proc heapsort
{ra_name
} {
71 set ir
[expr {$n - 1}]
74 set rra
[lindex $ra [incr l
-1]]
76 set rra
[lindex $ra $ir]
77 lset ra
$ir [lindex $ra 0]
78 if {[incr ir
-1] == 0} {
84 set j
[expr {(2 * $l) + 1}]
86 set tmp
[lindex $ra $j]
88 if {$tmp < [lindex $ra [expr {$j + 1}]]} {
89 set tmp
[lindex $ra [incr j
]]
102 proc heapsort_main
{} {
107 for {set i
1} {$i <= $n} {incr i
} {
108 lappend data
[gen_random
1.0]
113 ### SIEVE ######################################################################
119 for {set i
2} {$i <= 8192} {incr i
} {
122 for {set i
2} {$i <= 8192} {incr i
} {
123 if {$flags($i) == 1} {
124 # remove all multiples of prime: i
125 for {set k
[expr {$i+$i}]} {$k <= 8192} {incr k
$i} {
135 proc sieve_dict
{num
} {
139 for {set i
2} {$i <= 8192} {incr i
} {
142 for {set i
2} {$i <= 8192} {incr i
} {
143 if {[dict get
$flags $i] == 1} {
144 # remove all multiples of prime: i
145 for {set k
[expr {$i+$i}]} {$k <= 8192} {incr k
$i} {
155 ### ARY ########################################################################
158 for {set i
0} {$i < $n} {incr i
} {
161 set last
[expr {$n - 1}]
162 for {set j
$last} {$j >= 0} {incr j
-1} {
168 for {set i
0} {$i < $n} {incr i
} {
171 set last
[expr {$n - 1}]
172 for {set j
$last} {$j >= 0} {incr j
-1} {
177 ### REPEAT #####################################################################
179 proc repeat
{n body
} {
180 for {set i
0} {$i < $n} {incr i
} {
187 repeat
{1000000} {incr x
}
190 ### UPVAR ######################################################################
192 proc myincr varname
{
199 for {set x
0} {$x < 100000} {myincr x
} {
204 ### NESTED LOOPS ###############################################################
206 proc nestedloops
{} {
211 while {[incr a
-1]} {
213 while {[incr b
-1]} {
215 while {[incr c
-1]} {
217 while {[incr d
-1]} {
219 while {[incr e
-1]} {
221 while {[incr f
-1]} {
231 ### ROTATE #####################################################################
233 proc rotate
{count
} {
235 for {set n
0} {$n < $count} {incr n
} {
236 set v
[expr {$v <<< 1}]
240 ### DYNAMICALLY GENERATED CODE #################################################
243 for {set i
0} {$i < 100000} {incr i
} {
244 set script
"lappend foo $i"
249 proc dyncode_list
{} {
250 for {set i
0} {$i < 100000} {incr i
} {
251 set script
[list lappend foo
$i]
256 ### PI DIGITS ##################################################################
260 set LEN
[expr {10*$N/3}]
263 set a
[string repeat
" 2" $LEN]
268 set i0
[expr {$LEN+1}]
269 set quot0
[expr {2*$LEN+1}]
270 for {set j
0} {$j<$N} {incr j
} {
276 set x
[expr {10*$apos + $q * [incr i
-1]}]
277 lset a
[incr pos
] [expr {$x % [incr quot
-2]}]
278 set q
[expr {$x / $quot}]
280 lset a end
[expr {$q % 10}]
281 set q
[expr {$q / 10}]
283 append result
$predigit $nines
289 append result
[expr {$predigit+1}][string map
{9 0} $nines]
294 #puts $result$predigit
297 ### EXPAND #####################################################################
300 for {set i
0} {$i < 100000} {incr i
} {
301 set a
[list a b c d e f
]
306 ### MINLOOPS ###################################################################
309 for {set i
0} {$i < 100000} {incr i
} {
311 for {set j
0} {$j < 10} {incr j
} {
312 # something of more or less real
318 ### wiki.tcl.tk/8566 ###########################################################
320 # Internal procedure that indexes into the 2-dimensional array t,
321 # which corresponds to the sequence y, looking for the (i,j)th element.
323 proc Index
{ t y i j
} {
324 set indx
[expr { ([llength $y] + 1) * ($i + 1) + ($j + 1) }]
325 return [lindex $t $indx]
328 # Internal procedure that implements Levenshtein to derive the longest
329 # common subsequence of two lists x and y.
331 proc ComputeLCS
{ x y
} {
333 for { set i
-1 } { $i < [llength $y] } { incr i
} {
336 for { set i
0 } { $i < [llength $x] } { incr i
} {
338 for { set j
0 } { $j < [llength $y] } { incr j
} {
339 if { [string equal
[lindex $x $i] [lindex $y $j]] } {
340 set lastT
[Index
$t $y [expr { $i - 1 }] [expr {$j - 1}]]
341 set nextT
[expr {$lastT + 1}]
343 set lastT1
[Index
$t $y $i [expr { $j - 1 }]]
344 set lastT2
[Index
$t $y [expr { $i - 1 }] $j]
345 if { $lastT1 > $lastT2 } {
357 # Internal procedure that traces through the array built by ComputeLCS
358 # and finds a longest common subsequence -- specifically, the one that
359 # is lexicographically first.
361 proc TraceLCS
{ t x y
} {
363 set i
[expr { [llength $x] - 1 }]
364 set j
[expr { [llength $y] - 1 }]
365 set k
[expr { [Index
$t $y $i $j] - 1 }]
366 while { $i >= 0 && $j >= 0 } {
367 set im1
[expr { $i - 1 }]
368 set jm1
[expr { $j - 1 }]
369 if { [Index
$t $y $i $j] == [Index
$t $y $im1 $jm1] + 1
370 && [string equal
[lindex $x $i] [lindex $y $j]] } {
371 lappend trace xy
[list $i $j]
374 } elseif
{ [Index
$t $y $im1 $j] > [Index
$t $y $i $jm1] } {
393 # list::longestCommonSubsequence::compare --
395 # Compare two lists for the longest common subsequence
398 # x, y - Two lists of strings to compare
399 # matched - Callback to execute on matched elements, see below
400 # unmatchedX - Callback to execute on unmatched elements from the
401 # first list, see below.
402 # unmatchedY - Callback to execute on unmatched elements from the
403 # second list, see below.
409 # Whatever the callbacks do.
411 # The 'compare' procedure compares the two lists of strings, x and y.
412 # It finds a longest common subsequence between the two. It then walks
413 # the lists in order and makes the following callbacks:
415 # For an element that is common to both lists, it appends the index in
416 # the first list, the index in the second list, and the string value of
417 # the element as three parameters to the 'matched' callback, and executes
420 # For an element that is in the first list but not the second, it appends
421 # the index in the first list and the string value of the element as two
422 # parameters to the 'unmatchedX' callback and executes the result.
424 # For an element that is in the second list but not the first, it appends
425 # the index in the second list and the string value of the element as two
426 # parameters to the 'unmatchedY' callback and executes the result.
430 unmatchedX unmatchedY
} {
431 set t
[ComputeLCS
$x $y]
432 set trace [TraceLCS
$t $x $y]
433 set i
[llength $trace]
435 set indices
[lindex $trace [incr i
-1]]
436 set type
[lindex $trace [incr i
-1]]
437 switch -exact -- $type {
440 eval lappend c
$indices
441 lappend c
[lindex $x [lindex $indices 0]]
447 lappend c
[lindex $x $indices]
453 lappend c
[lindex $y $indices]
461 proc umx
{ index value
} {
464 append xlines
"< " $value \n
468 proc umy
{ index value
} {
471 append ylines
"> " $value \n
475 proc matched
{ index1 index2 value
} {
480 if { [info exists lastx
] && [info exists lasty
] } {
481 #puts "[expr { $lastx + 1 }],${index1}c[expr {$lasty + 1 }],${index2}"
482 #puts -nonewline $xlines
484 #puts -nonewline $ylines
485 } elseif
{ [info exists lastx
] } {
486 #puts "[expr { $lastx + 1 }],${index1}d${index2}"
487 #puts -nonewline $xlines
488 } elseif
{ [info exists lasty
] } {
489 #puts "${index1}a[expr {$lasty + 1 }],${index2}"
490 #puts -nonewline $ylines
492 catch { unset lastx
}
493 catch { unset xlines
}
494 catch { unset lasty
}
495 catch { unset ylines
}
498 # Really, we should read the first file in like this:
499 # set f0 [open [lindex $argv 0] r]
500 # set x [split [read $f0] \n]
502 # But I'll just provide some sample lines:
504 proc commonsub_test
{} {
506 for { set i
0 } { $i < 20 } { incr i
} {
507 lappend x a r a d e d a b r a x
510 # The second file, too, should be read in like this:
511 # set f1 [open [lindex $argv 1] r]
512 # set y [split [read $f1] \n]
514 # Once again, I'll just do some sample lines.
517 for { set i
0 } { $i < 20 } { incr i
} {
518 lappend y a b r a c a d a b r a
521 compare
$x $y matched umx umy
522 matched
[llength $x] [llength $y] {}
525 ### MANDEL #####################################################################
527 proc mandel
{xres yres infx infy supx supy
} {
528 set incremx
[expr {double
($supx-$infx)/$xres}]
529 set incremy
[expr {double
($supy-$infy)/$yres}]
531 for {set j
0} {$j < $yres} {incr j
} {
532 set cim
[expr {$infy+$incremy*$j}]
534 for {set i
0} {$i < $xres} {incr i
} {
538 set cre
[expr {$infx+$incremx*$i}]
539 while {$counter < 255} {
540 set dam
[expr {$zre*$zre-$zim*$zim+$cre}]
541 set zim
[expr {2*$zim*$zre+$cim}]
543 if {$zre*$zre+$zim*$zim > 4} break
551 ### RUN ALL ####################################################################
553 if {[string compare
[lindex $argv 0] "-batch"] == 0} {
555 set argv
[lrange $argv 1 end
]
557 set ver
[lindex $argv 0]
559 bench
{[while] busy loop
} {whilebusyloop
}
560 bench
{[for] busy loop
} {forbusyloop
}
561 bench
{mini loops
} {miniloops
}
562 bench
{fibonacci
(25)} {fibonacci
25}
563 bench
{heapsort
} {heapsort_main
}
564 bench
{sieve
} {sieve
10}
565 bench
{sieve
[dict
]} {sieve_dict
10}
566 bench
{ary
} {ary
100000}
567 bench
{ary
[dict
]} {ary_dict
100000}
568 bench
{repeat
} {use_repeat
}
569 bench
{upvar} {upvartest
}
570 bench
{nested loops
} {nestedloops
}
571 bench
{rotate
} {rotate
100000}
572 bench
{dynamic code
} {dyncode
}
573 bench
{dynamic code
(list)} {dyncode_list
}
574 bench
{PI digits
} {pi_digits
}
575 bench
{expand
} {expand
}
576 bench
{wiki.tcl.
tk/8566} {commonsub_test
}
577 bench
{mandel
} {mandel
60 60 -2 -1.5
1 1.5}
581 if {[catch {info patchlevel
} ver
]} {
582 set ver Jim
[info version
]
585 puts [list $ver $benchmarks]