Horseracing in Tcl

Richard Suchenwirth 2002-06-02 - After a long weekend with occasional fun projects, I finally wanted to do something in Tk too. Now here's a silly horse-racing game: ten horses (you can edit their names if you don't like my defaults) run at random speed from left to right. The first three to reach the finish are listed at the bottom. That's all. But still it was kind of fun to write, and at the usual fast Tcl speed - 2.5 hours between first design and this "delivery" version...

package require Tk
set horses {
    Blaise Gottlieb Animal Ada Alan Haskell Grace Brian John Linus
} ;# edit this list for permanent preferences
proc main {horses} {
    set c [canvas .c -bg green4 -width 500 -height 330]
    pack $c
    set n 0
    foreach horse $horses {
        set w [entry $c.e$n -textvar horse$n -width 8 -bg green3]
        set ::horse$n $horse
        $c create window 5 [expr $n*30+5] -window $w -anchor nw
        horse $c 70 [expr $n*30+14] horse$n
        lappend horsetags horse$n
        incr n
    }
    $c create line 480 0 480 330 -fill white -tag finish
    button $c.button -text Start -pady 0 -width 7 \
        -command [list start $c $horsetags]
    $c create window 5 [expr $n*30] -window $c.button -anchor nw
    label $c.winners -textvar winners -bg green3 -width 60
    $c create window 70 [expr $n*30] -window $c.winners -anchor nw
}
proc horse {c x y tag} {
    set hide [lpick {black brown white gray brown3 brown4}]
    set c1 [lpick {red yellow blue purple pink green}]
    set c2 [lpick {red yellow blue purple pink green}]
    $c create oval 0 -1 18 4 -fill $hide -outline $hide -tag $tag
    $c create line 1 12 3 0 5 12 -fill $hide -tag $tag -width 2
    $c create line 15 12 17 0 19 12 -fill $hide -tag $tag -width 2
    $c create line 16 0 20 -7 24 -5 -fill $hide -tag $tag -width 3
    # Jockey:
    $c create line 9 4 11 1 7 -1 -fill $c1 -width 2 -tag $tag
    $c create line 7 -2 10 -6 15 -3 -fill $c2 -width 2 -tag $tag
    $c create oval 9 -7 12 -10 -fill orange -outline orange -tag $tag
    $c move $tag $x $y
}
proc start {c running} {
    $c.button config -text Reset -command [list reset $c $running]
    global winners
    set winners {}
    set finish [expr [lindex [$c bbox finish] 2]+10]
    while {[llength $winners]<3} {
        set this [lpick $running]
        $c move $this [lpick {0 1 2 3}] 0
        update
        if {[lindex [$c bbox $this] 2]>$finish} {
            lappend winners [expr [llength $winners]+1]:[set ::$this]
            lremove running $this
        }
    }
}
proc reset {c tags} {
    $c.button config -text Start -command [list start $c $tags]
    foreach i $tags {
        set x [lindex [$c bbox $i] 0]
        $c move $i [expr {60-$x}] 0
    }
}
proc lpick L {lindex $L [expr int(rand()*[llength $L])]}
proc lremove {listName what} {
    upvar 1 $listName list
    set pos  [lsearch $list $what]
    set list [lreplace $list $pos $pos]
}
bind . <space> {exec wish $argv0 &; exit}
main $horses

Category Games