dogs.tcl

set dogNames {Abby Angel Annie Bailey Bailey Bandit Baxter Bear Beau Bella Belle Bentley Boomer \
Brandy Bruno Buddy Buster Casey Casey Charlie Chloe Coco Cody Cooper Daisy Dakota Dakota Dixie \
Duke Emma Ginger Gizmo Gracie Gus Harley Heidi Henry Holly Honey Hunter Jack Jackson Jake Jasmine \
Joey Katie Lady Lexi Lilly Lily Lola Louie Lucky Lucy Luke Lulu Luna Madison Maggie Max Maximus \
Mia Milo Missy Molly Murphy Oliver Oscar Penny Pepper Princess Riley Rocco Rocky Romeo Rosie Roxie \
Roxy Ruby Rudy Rusty Sadie Sam Samantha Sammy Samson Sandy Sasha Shadow Shelby Sophie Sparky Stella \
Teddy Toby Tucker Winston Zeus Zoe Zoey}

proc sortDogs {dogs} {
    set pop [llength $dogs]
    # first split the dogs into groups of 5 and race them
    # then take the winners of each group and race them
    # and so on until we know the fastest dog

    puts "#-------------STAGE 1----------------#"
    puts "#----------RACE ALL DOGS-------------#"

    set topDog [rankDogs $dogs]

    puts ""
    puts "Top Dog: [dogString $topDog]"
    puts "#------------------------------------#"

    # the dogs are now roughly sorted in a tree structure
    # we need to "zip" the tree together into a single thread
    # that represents the order of the dogs

    puts "#---------------STAGE 2--------------#"
    puts "#--------SORT THESE BITCHES----------#"

    set fastestDog $topDog
    set sortedDogs {}
    while 1 {

        puts ""
        puts "Determining dogs to race..."
        # find the next 5 dogs and race them
        set dogsToRace [dogsToRace $fastestDog]
        puts "dogs found. They are:"
        foreach dog $dogsToRace {
            set slowerDogs {}
            foreach slowerDog $rank($dog) {lappend slowerDogs [dogString $slowerDog]}
            switch -- $slowerThan($dog) {
            0 {
                puts "[dogString $dog] is not known to be faster than any other dogs"
            }
            1 {
                puts "[dogString $dog] is faster than [lindex $slowerDogs 0]"
            }
            default {
                puts "[dogString $dog] is faster than [join $slowerDogs ", "] and [expr {$slowerThan($dog)-1}] other dogs"
            }
            }
        }

        set dogs [race5Dogs $dogsToRace]

        set lastDog $fastestDog
        foreach dog $dogs {
            set newRank {}
            foreach slowerDog $rank($lastDog) {
                if {[lsearch $dogs $slowerDog]<0} {
                    lappend newRank $slowerDog
                }
            }
            lappend newRank $dog
            set rank($lastDog) $newRank

            set lastDog $dog
        }

        while {[llength $rank($fastestDog)]==1} {
            lappend sortedDogs $fastestDog
            set fastestDog [lindex $rank($fastestDog) 0]
            if {$rank($fastestDog)=={}} {
                lappend sortedDogs $fastestDog
                puts "took $::raceCount races"
                foreach dog $sortedDogs {puts "[incr i]. [dogString $dog]"}
                return $sortedDogs
            }
        }

        # recalculate slowerThan
        foreach dog [lreverse [lrange $dogs 0 end-1]] {
            set slowerThan($dog) 0
            foreach slowerDog $rank($dog) {
                incr slowerThan($dog)
                incr slowerThan($dog) $slowerThan($slowerDog)
            }
        }

        set sortedDogStrings {}
        foreach dog $sortedDogs {
            lappend sortedDogStrings "[dogString $dog]"
        }
        puts "Sorted [expr {[llength $sortedDogs]+1}] dogs so far: [join $sortedDogStrings " > "] > [dogString $fastestDog]"
    }
}

proc dogsToRace {fastestDog} {
    upvar rank rank
    upvar slowerThan slowerThan

    set dogs {}
    set fastestDogs {}
    while {[llength $dogs]<5} {

        if {[llength $dogs]+[llength $rank($fastestDog)]>5} {
            while {[llength $dogs]<5} {
                set maxDepth -1
                set bestDog {}
                foreach dog $rank($fastestDog) {
                    if {$slowerThan($dog)>$maxDepth} {
                        set maxDepth $slowerThan($dog)
                        set bestDog $dog
                    }
                }
                lappend dogs $bestDog
            }
            break
        } elseif {$rank($fastestDog)!={}} {
            set dogs [concat $dogs $rank($fastestDog)]
        }

        set dogsAdded 0
        foreach dog $rank($fastestDog) {
            if {$rank($dog) != {}} {
                lappend fastestDogs [list $dog $slowerThan($dog)]
                set dogsAdded 1
            }
        }
        if {!$dogsAdded} break

        set fastestDogs [lsort -index end -integer -decreasing $fastestDogs]
        set fastestDog [lindex [lindex $fastestDogs 0] 0]
        set fastestDogs [lrange $fastestDogs 1 end]
    }

    return $dogs
}

proc rankDogs {dogs} {
    upvar rank rank
    upvar slowerThan slowerThan

    set noOfDogs [llength $dogs]
    if {$noOfDogs>25} {
        set leaders {}
        for {set p 0} {$p<5} {incr p} {
            set from [expr {($noOfDogs*$p)/5}]
            set to [expr {($noOfDogs*($p+1))/5 - 1}]
            lappend leaders [rankDogs [lrange $dogs $from $to]]
        }
        set sortedDogs [race5Dogs $leaders]
        set index 5
    } elseif {$noOfDogs>5} {
        set leaders {}
        for {set from 0; set to 4} {$from<$noOfDogs} {incr from 5; incr to 5} {
            lappend leaders [rankDogs [lrange $dogs $from $to]]
        }
        set sortedDogs [race5Dogs $leaders]
        set index [llength $leaders]
    } else {
        set sortedDogs [race5Dogs $dogs]
        set rank([lindex $sortedDogs end]) {}
        set slowerThan([lindex $sortedDogs end]) 0
        set index $noOfDogs
    }

    foreach dog [lreverse [lrange $sortedDogs 0 end-1]] {
        set slowerDog [lindex $sortedDogs [incr index -1]]
        incr slowerThan($dog)
        incr slowerThan($dog) $slowerThan($slowerDog)
        lappend rank($dog) $slowerDog
    }

    return [lindex $sortedDogs 0]
}

proc randomDogs {howManyDogs} {
    global dogNames

    set dogs {}
    array set usedNames {}

    while {[llength $dogs]<$howManyDogs} {
        set dogName [lindex $dogNames [expr {int(rand()*[llength $dogNames])}]]
        if {[info exists usedNames($dogName)]} continue
        set usedNames($dogName) 1

        set speed [expr {rand()}]
        lappend dogs [list $dogName $speed]
    }

    return $dogs
}

proc dogString {dog} {
    lassign $dog name speed
    return "$name ([format %.1f [expr {$speed*100}]])"
}

proc race5Dogs { dogs } {
    global raceCount
    incr raceCount
    puts "race #$raceCount:"
    foreach dog $dogs {lappend racers [dogString $dog]}
    puts "[join $racers " v "]"
    puts ""

    set sortedDogs [lsort -real -decreasing -index end $dogs]

    puts "result:"
    set rank 0
    foreach dog $sortedDogs {puts "[incr rank]. [dogString $dog]"}
    puts ""

    return $sortedDogs
}

set raceCount 0
set allDogs [randomDogs 25]
sortDogs $allDogs