Version 8 of Car racing in Tcl
Updated 2002-12-09 11:36:27
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
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 -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...
Tcl/Tk games | Arts and crafts of Tcl-Tk programming Category Games