tests/tcl/8.4/src/heapsort.tcl

#!/usr/local/bin/tclsh
# $Id: heapsort.tcl,v 1.1 2004/01/03 13:12:13 davidw Exp $
# http://www.bagley.org/~doug/shootout/
# sped up by Miguel Sofer's function generator

# END COMMENT
set IM 139968
set IA   3877
set IC  29573

set last 42

proc make_gen_random {} {
    global IM IA IC
    set params [list IM $IM IA $IA IC $IC]
    set body [string map $params {
        global last
        expr {($max * [set last [expr {($last * IA + IC) % IM}]]) / IM}
    }]
    proc gen_random {max} $body
}

proc heapsort {ra_name} {
    upvar 1 $ra_name ra
    set n [llength $ra]
    set l [expr {$n / 2}]
    set ir [expr {$n - 1}]
    while 1 {
        if {$l} {
            set rra [lindex $ra [incr l -1]]
        } else {
	    set rra [lindex $ra $ir]
	    lset ra $ir [lindex $ra 0]
	    if {![incr ir -1]} {
                lset ra 0 $rra
		break
            }
        }
	set i $l
	set j [expr {(2 * $l) + 1}]
        while {$j <= $ir} {
	    set tmp [lindex $ra $j]
	    if {$j < $ir} {
		if {$tmp < [lindex $ra [expr {$j + 1}]]} {
		    set tmp [lindex $ra [incr j]]
		}
	    }
            if {$rra >= $tmp} {
		break
	    }
	    lset ra $i $tmp
	    incr j [set i $j]
        }
        lset ra $i $rra
    }
}

proc main {} {
    global argv
    set n [lindex $argv 0]
    make_gen_random

    set data {}
    for {set i 1} {$i <= $n} {incr i} {
	lappend data [gen_random 1.0]
    }
    heapsort data
    puts [format "%.10f" [lindex $data end]]
}

main