Car racing in Tcl
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 - see Playing OO), controlled by other keybindings (a s w y on German keyboard, or a s w z on US) - 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
lassign [$c bbox $name] x0 y0 x1 y1
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
}
}
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} {
lassign [$w bbox $tag] x0 y0 x1 y1
list [expr {($x0 + $x1) / 2.}] [expr {($y0 + $y1) / 2.}]
}
proc canvas'rotate {w tag angle} {
lassign [canvas'center $w $tag] xm ym
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 -capstyle round ;# background
.c create line $track -fill grey -width 75 -smooth 1 -capstyle round ;# 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}The screenshot (Win2k) shows a crack in the road on the left side. This does not occur in Win95, and has to do with -capstyle attributes - setting them "round" when drawing the track gives a seamless tarmac.
Heh, the playability in this game is so off it's quite a challenge to play ;-) Btw. take a look at the old DOS game "Slicks'n'Slides". Absolutely brilliant. Would give anything to have a Linux GPLed version of that game with network code.
--Setok
This is far too advanced for so few lines of code to be of natural origin. I suspect Satanic influence. -FW - RS: no Satan involved - this is just how Tcl is...
The graphics and the cars look cool. But, I recommend that the steering return to center after you release the keys, like in a real car. Then the cars would be easier to control
TV Little short of wonderful, I have the two cars each running their own circle taking up 13 % of the processor time, which is well spent. Like little atoms. I have nothing to add. Yet.
(little later) Oops, it seems the solving of the differential motion equation by an approximated, as it seems non symmetrical difference eq, approximation, the circles are not circles in the end, one car just went of the screen...
AvL To solve this, one might "merge" this prog with my drive.tcl [L1 ]. While mine has exact calculation of the position after each time-step (and thus the car goes around in circles for very long time without drifting off), it would surely benefit from the nice "environment" (track, look of cars) that can be found here :-)
Wouldn't it be right to log races altogether?