[http://mini.net/files/carracing.jpg]

[Richard Suchenwirth] 2002-10-20 - I've had weekends without fun
projects, but I prefer those with... This time I've experimented with
directed motion, where a canvas object, a compound of several items,
moves (and rotates) in a given direction and
speed. The object I chose is a very simplified race car, where you can
see intended changes of direction by the angle of the front wheels
(a tractor would have served as well ;-) You can steer with the <Left>
and <Right> cursor keys, and change speed with the <Up>/<Down> keys.
Hitting the space bar stops immediately, also if a car touches the
canvas borders (which causes a spectacular "explosion"), but still you
can maneuver yourself in reverse gear (<Down>) out of the problem.

The canvas features a simple race track implemented as a very thick,
smoothened grey line (which gets an outline by superimposing it on a
slightly wider line) , and the cars. No match for commercial
racing games, of course - but it was a nice little challenge for a
Sunday evening. And, as usual, I put it on the Wiki in the hope that
others will come up with ideas to refine it... A first idea was to
add a second car (easy, as the car code is sort of object-oriented), controlled
by other keybindings (a s w y) - but it's hard enough for one player to
keep a single car on the track, so best have two players. Collision detection
is missing yet. And what else could one add: [Snack] sound.. lap
counting.. Anyway, I hope you enjoy it!

 namespace eval car {variable maxSteer 0.25 cars ""}
 
 proc car::new {name c color {keys {<Left> <Right> <Up> <Down>}}} {
    variable cars
    lappend cars $name
    interp alias {} $name {} car::dispatch $name
    namespace eval $name {
        variable angle 0  frontangle 0  speed 0
    }
    namespace eval $name [list variable canvas $c]
    interp alias {} $name: {} namespace eval ::car::$name
    $c create line 44 55 66 55 -tag $name -width 2
    $c create line 44 80 66 80 -tag $name -width 3
    $c create poly 51 45 48 87 62 87 59 45 -fill $color -tag $name
    wheel $name $c 44 55 left$name
    wheel $name $c 66 55 right$name
    wheel $name $c 44 80
    wheel $name $c 66 80
    $c create poly 52 67 52 73 58 73 58 67 -smooth 1 -fill white \
        -tag $name ;# driver's helmet
    foreach key $keys action {
        {steer +.04} {steer -.04} {accelerate +1} {accelerate -1}
    } {
        bind . $key [concat $name $action]
    }
 }
 proc car::dispatch {name cmd args} {eval ::car::$cmd $name $args}
 
 proc car::wheel {name c x y {tags ""}} {
    set dx 3; set dy 6
    set x0 [expr {$x - $dx}]
    set y0 [expr {$y - $dy}]
    set x1 [expr {$x + $dx}]
    set y1 [expr {$y + $dy}]
    $c create poly $x0 $y0 $x0 $y1 $x1 $y1 $x1 $y0 -fill black\
        -tag [lappend tags $name]
 }

 proc car::accelerate {names amount} {
    if {$names == "all"} {variable cars; set names $cars}
    foreach name $names {
        if $amount {
            if {[$name: set speed]>-1 || $amount > 0} {
                $name: incr speed $amount
            }
        } else {$name: set speed 0 ;# emergency stop}
    }
 }
 proc car::steer {name amount} {
    variable maxSteer
    set fa [$name: set frontangle]
    if {abs([$name: set angle] - ($fa  + $amount)) < $maxSteer} {
        $name: set frontangle [expr {$fa + $amount}]
        canvas'rotate [set ${name}::canvas] left$name $amount
        canvas'rotate [set ${name}::canvas] right$name $amount
    }
 }
 proc car::move {} {
    variable cars
    set title TclRacing
    foreach name $cars {
        set c [$name: set canvas] ;# always the same, though...
        set mean [expr {([$name: set angle]+[$name: set frontangle])/2.}]
        set speed [$name: set speed]
        set amount [expr {($mean - [$name: set angle])*$speed/5.}]
        canvas'rotate $c $name $amount
        $name: set angle [expr {[$name: set angle] + $amount}]
        $name: set frontangle [expr {[$name: set frontangle] + $amount}]
        set dx [expr {-$speed * sin([$name: set angle])}]
        set dy [expr {-$speed * cos([$name: set angle])}]
        $c move $name $dx $dy
        foreach {x0 y0 x1 y1} [$c bbox $name] break
        if {$x0<0 || $y0<0 || $x1>[$c cget -width] || $y1>[$c cget -height]} {
            crash $name ;# went over canvas borders
        }
        lappend title $name: [expr {$speed*10}] mph
    }
    #wm title . $title
 }
 proc car::crash name {    
    if {[set ${name}::speed] > 3} {
        set c [set ${name}::canvas]
        $c create oval [$c bbox $name] -fill white -outline white\
            -stipple gray12 -tag cloud$name
        set center [canvas'center $c $name]
        foreach color {yellow orange red brown black} {
            after 250
            $c itemconfig cloud$name -fill $color -outline $color \
            -stipple gray12    ;# -stipple doesn't work on Win95
            eval $c scale cloud$name $center 1.4 1.4
            update idletasks
        }
        after 250
        $c delete cloud$name
    }
    set ${name}::speed 0 ;# in any case, stop that thing
 }
 #-------- Generally useful routines:
 proc canvas'center {w tag} {
    foreach {x0 y0 x1 y1} [$w bbox $tag] break
    list [expr {($x0 + $x1) / 2.}] [expr {($y0 + $y1) / 2.}]
 }
 proc canvas'rotate {w tag angle} {
    foreach {xm ym} [canvas'center $w $tag] break
    foreach item [$w find withtag $tag] {
        set coords {}
        foreach {x y} [$w coords $item] {
            set rad [expr {hypot($x-$xm, $y-$ym)}]
            set th  [expr {atan2($y-$ym, $x-$xm)}]
            lappend coords [expr {$xm + $rad * cos($th - $angle)}]
            lappend coords [expr {$ym + $rad * sin($th - $angle)}]
        }
        $w coords $item $coords
    }
 }
 proc every {ms body} {eval $body; after $ms [info level 0]}
 
 #-------------------- test and demo:
 pack [canvas .c -width 600 -height 400 -bg darkgreen]
 .c create text 300 200 -text TclRacing \
    -font {Helvetica 64 {bold italic}} -fill green4
 set track {45 45 300 45 560 45 560 360 45 360 45 45}
 .c create line $track -fill bisque -width 85 -smooth 1 ;# background
 .c create line $track -fill grey -width 75 -smooth 1   ;# race track
 .c create line 300 5 300 80 -fill yellow ;# finish line
 car::new Ferrari .c red                  ;# default: cursor keys
 .c move  Ferrari 0 100
 car::new BMW     .c blue {a s w y}       ;# other keys for second car
 .c move  BMW     -35 100
 bind . <space> {car::accelerate all 0}
 every 50       {car::move}

 bind . <Escape> {exec wish $argv0 &; exit}
 bind . ? {console show}

----
[Tcl/Tk games] | [Arts and crafts of Tcl-Tk programming]