** summary **
[nedbrek] - This page will document the development of a simple game, similar
to the old games "Moon Lander" and "Hey! Taxi!". [ZB]03.10.2008. It was "Space
Taxi"
** Description **
The code will be presented piecemeal, in the history. (Please comment in the
history based on what type of changes added - "added $feature", "fixed bug",
"added comments")
It can also be used to demonstrate simple physics (gravity/acceleration,
velocity, and position).
It's amazing how much more fun it is when you add left and right thrust!
That's 22 (base, no comments, no blanks) to 35 lines of code (with X thrust)!
** Changes **
[HE] 2008-10-03: Added the following:
* Bugfix second line: set ::gravY 0 => set ::gravX 0
* grouped some initialisation inside a proc
* New start with key n
* detect hard crash (>=5) or soft land (<5)
* refreshtime set in global variable ::afterTime and default to 500
[ZB] Introduced "else"... prevents event-looping after the game has been ended already
[HE] 2008-10-12: With [ZB]'s change the game cannot started again with key n.
I moved
======
# start the game event loop
eventLoop
======
at the end of the code in the proc new. Now the game can started again with key
n.
[ZB] 2008-10-19 Isn't it nicer with "real lander"? ;)
[HE] 2008-10-20 The lander lands outside the canvas ([ZB] It was because the
moon dust is very soft, so the lander partially digged in itself while landing
;). Added a groundline.
----
[ZB] 2009-04-05
* major change: separated event loops. First one especially for "sprite"
movement, the second one exclusively as "main game loop" (reading controls,
gravity, etc.). Such way we've got smooth movement of our "lander"
* added sprite for "wreck" (not especially fancy, but looks out like debris,
anyway)
* added "reverse thrust" (down)
* added restart with space bar (more comfortable restart with left thumb, if
you've got both hands on the keyboard)
* added "quit game " with Escape
* some additional sanitization of the code
[JAG] 2009-04-05 The code below is currently broken. Look for "groundline" in
the code and notice that the canvas line command is incomplete.
[ZB] - thanks, fixed.
----
[ZB] 2009-04-11
* added landscape
* added fuel counter
* added lives counter
* safe landing requires: a) Touchdown on landing area (thick black line) ...while having: b) X-velocity < 4, c) Y-velocity < 6
* score counting: 500 points for safe landing + 10 pts for every unit of fuel saved - 1 pt for every second of mission duration (when mission has been completed). When incomplete: -100 pts for every wreck (3 lives)
* there can be a wind (horizontal force), not just gravity (vertical one)
* better collision detection
* several other changes / code sanitization
----
[HE] 2009-04-13: Some changes I made:
* now the program do not start directly after loading
* now the program do not end after losing all lives
* key n starts a new game. key space starts a new approach for a landing
* state messages are set with procedure msgDisplay for easier management (for example: to display the text in the middle of the playground)
* some values are defined outside the code for easier changes
* inside a game the scores of all approaches for a landing are added now (before every approach are reseting the soore)
* avoiding to change the size of the window
[PYK] 2012-12-09: removed [update]. Added start message. Space key is only
bound when a game is in progress.
----
[Jeff Smith] 2019-07-20 : Fifty years ago today! Below is an online demo using [CloudTk]
1969-07-20 : Neil Armstrong - “'''Houston''', Tranquility Base here. '''The Eagle has landed'''”
Unfortunately this script produces the below error when holding the key so no [Moon Lander] demo today!
======
divide by zero
while executing
"expr {10 / $interval)
(procedure "movementLoop line 22)
invoked from within
"movementLoop .c taxi"
("after" script)
======
[Jeff Smith] 2020-08-25 : This demo still produces the above error but runs "Moon Lander" in an Alpine Linux Docker Container. It is a 27.4MB image which is made up of Alpine Linux + tclkit + Moon-Lander.kit + + libx11 + libxft + fontconfig + ttf-linux-libertine. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.
<<inlinehtml>>
<iframe height="32500" width="4200" src="https://cloudtk-app.tcl-lang.org/cloudtk/VNC?session=new&Tk=Moon-Lander" allowfullscreen></iframe>
<<inlinehtml>>
----
** Code **
======
# http://wiki.tcl.tk/21673
package require Tk
set ::taxiID 0 ; # canvas item id for our lander/taxi rectangle
set ::afterTime 300 ; # refreshtime
set ::lives 3 ;# Lives
set flying no ;# lander isn't flying yet
set config(fuel) 20 ;# fuel value to use
set config(wind) 1 ;# wind value to use
set config(gravity) 2 ;# gravity value to use
set config(gameStarted) no ;# if no then proc game isn't execute
set ::next {}
# HE: To get the Messages more in the middle
proc msgDisplay { canvasName msg color} {
global msgID
catch {$canvasName delete $msgID}
set ch [$canvasName cget -height]
set cw [$canvasName cget -width]
set msgID [$canvasName create text [expr {$cw / 2}] [expr {$ch / 2}] -text $msg -fill $color]
return $msgID
}
proc welcome {} {
set msg {Press @CONTINUE@"n" to @START@}
set continue {}
set start start
if {$::config(gameStarted)} {
set continue "space to continue or "
set start restart
}
set msg [string map [list @CONTINUE@ $continue @START@ $start] $msg]
msgDisplay .c $msg yellow
}
proc gameover {} {
bind . <Key-space> { game .c }
set ::config(gameStarted) no
msgDisplay .c {Game Over} white
after idle {
after 1500
welcome
}
}
proc gameCreate { canvasName } {
global wind gravity roomID la ground
global config
set ch [$canvasName cget -height]
set cw [$canvasName cget -width]
# gravity (Y direction) and ev. wind (X direction) - constant
set wind $config(wind)
set gravity $config(gravity)
# The landscape
set ground [$canvasName create rectangle 0 [expr {$ch - 10}] $cw $ch -fill brown4 -outline brown4 \
-tag "ground"]
# The landing area
set la [$canvasName create line 0 [expr {$ch - 12}] 100 [expr {$ch - 12}] -fill black -width 3 \
-tag "land_here"]
$canvasName move $la 120 0
# We can add handful of stars then
for {set ii 0} {$ii < 100} {incr ii} {
set rxpos [expr {round(rand() * $cw)}]
set rypos [expr {round(rand() * ($ch - 15))}]
$canvasName create line $rxpos $rypos [expr {$rxpos + 1}] $rypos -fill white -width 1 \
-tag "nothing"
}
# Room name
set roomID [$canvasName create text 20 10 -text "Earth" -fill green1]
welcome
}
proc game { canvasName } {
after cancel $::next
bind . <Key-space> { game .c }
global lives score startTimer mlID elID roomID msgID taxiID sprite1 la ground
global fuel flying crashed velX velY startTimer
global config
set fuel $config(fuel); # Fill the tank up (also belongs to "room description" - but done always)
if {!$config(gameStarted)} {
#new game
set score 0
set lives 3
}
set config(gameStarted) yes
# current lander velocity in the X/Y directions
set velX 1
set velY 1
set startTimer 0
if { [info exists mlID] } { after cancel $mlID }
if { [info exists elID] } { after cancel $elID }
# message delete (if exists)
if { [info exists msgID] } {
$canvasName delete $msgID
unset msgID
}
# Out of landers? Exit...
if { $lives == 0 } {
gameover
return
}
# (Still) alive? Create new lander
if { [info exists taxiID] } {
$canvasName delete $taxiID
}
set taxiID [$canvasName create image 10 10 -image $sprite1 -anchor nw -tags taxi]
$canvasName coords taxi 80 10
msgDisplay .c "Get ready" yellow
after 1000 [list run $canvasName $msgID]
}
proc run {canvasName msgID} {
set flying yes ; # Make it flying
set crashed no ; # It's new!
$canvasName delete $msgID
set startTimer [clock seconds]
# start the game event loops
movementLoop $canvasName "taxi"
mgl
}
# callback for thruster
proc thrust { direction } {
global fuel velY velX flying
if { ! $flying } { return }
if { $direction eq "up" || $direction eq "left" } {
set velDiff -5
} else {
set velDiff 5
}
if { $direction eq "up" || $direction eq "down" } {
set whichVel "velY"
} else {
set whichVel "velX"
}
if { $fuel } {
incr fuel -1
incr $whichVel $velDiff
}
}
proc onTheMove { canv vehicle } {
global flying crashed velY velX la ground
set coords [$canv coords $vehicle]
set x1 [lindex $coords 0]
set x2 [expr {$x1 + [image width [$canv itemcget $vehicle -image]]}]
set y1 [lindex $coords 1]
set y2 [expr {$y1 + [image height [$canv itemcget $vehicle -image]]}]
set collision [$canv find overlapping $x1 $y1 $x2 $y2]
if { $la in $collision || $ground in $collision } {
set flying no
if { $ground in $collision || ($velY > 5) || (abs($velX) > 3) } {
set crashed yes
} else {
set crashed no
}
return no
} else {
set flying yes
return yes
}
}
# Separate event loop especially for smooth "lander" movement
proc movementLoop { canv vehicle } {
global afterTime flying crashed velX velY mlID
if { $velX == 0 } { set velX 1 }
if { $velY == 0 } { set velY 1 }
# No speed = 0! Would be to easy (there's no speed=0 while flying; you're
# always on the move), and protection against "div by 0 error"
# Speed=1 -> 1px/100ms, 2 -> 2px/100ms (=1px/50ms) etc.
set baseInterval 100
# $interval not shorter than 10ms!
if { abs($velY) >= abs($velX) } {
set interval [expr {abs($baseInterval / $velY)}]
set xStep [expr {$velX * 1.0 / abs($velY)}]
set yStep [expr {($velY >= 0) ? 1 : -1}]
} else {
set interval [expr {abs($baseInterval / $velX)}]
set yStep [expr {$velY * 1.0 / abs($velX)}]
set xStep [expr {($velX >= 0) ? 1 : -1}]
}
if { $interval < 10 } {
set coeff [expr {10 / $interval}]
set yStep [expr {round($yStep * $coeff)}]
set xStep [expr {round($xStep * $coeff)}]
set interval 10
}
if { [onTheMove $canv $vehicle] } {
$canv move $vehicle $xStep $yStep
set mlID [after $interval movementLoop $canv $vehicle]
}
}
# Main Game Loop
proc mgl {} {
# check for the taxi being destroyed
if {$::taxiID == 0} { return }
set coords [.c coords taxi] ; # find the x1 y1 x2 y2 coords for the taxi
if { $::flying } {
incr ::velX $::wind
incr ::velY $::gravity
set ::elID [after $::afterTime [list after idle mgl]]
} else {
if { $::crashed } {
.c delete $::taxiID
set ::taxiID [.c create image [lindex $coords 0] [lindex $coords 1] -image $::sprite2 \
-anchor nw -tags taxi]
after idle {
msgDisplay .c "Crashed" red
incr ::lives -1
incr ::score -100
set ::next [after 1500 {
if {$::lives > 0} {
welcome
} else {
gameover
}
}]
}
} else {
incr ::score [expr {500 + $::fuel*10 - ([clock seconds] - $::startTimer)}]
msgDisplay .c "Landed" green
}
}
}
### GUI
# main frame
pack [frame .fVel] -side top
# current Y velocity
pack [label .fVel.lLX -text "X-Vel: " -justify left] -side left
pack [label .fVel.lVX -textvariable velX -width 3 -justify right] -side left
pack [label .fVel.lLY -text "Y-Vel: " -justify left] -side left
pack [label .fVel.lVY -textvariable velY -width 3 -justify right] -side left
pack [label .fVel.f1 -text "Fuel: " -justify left] -side left
pack [label .fVel.f2 -textvariable fuel -width 2 -justify right] -side left
pack [label .fVel.l1 -text "Lives: " -justify left] -side left
pack [label .fVel.l2 -textvariable lives -justify right] -side left
pack [label .fVel.s1 -text "Score: " -justify left] -side left
pack [label .fVel.s2 -textvariable score -width 5 -justify right] -side left
# Main playing area.
pack [canvas .c -background blue4] -side top
# HE: Don't resize
wm resizable . 0 0
# sprite1 - "lander", sprite2 - "wrecked lander"
set ::sprite1 [image create photo -data {
R0lGODlhEAAQAMIDAAAAACIiIszMzP///4aGhgAAAEJCQv///yH5BAEAAAcALAAAAAAQABAA
AANQeHrR3isGMYQlgpTIqL2ZJnkfRojKZKxsiwaGec6nsXWyTb9ZqNO3ySnzm90OBUHMUSDE
jgtDAGjgKAobLBYJvXa5HKakcZwaU8CFFrpWJAAAOw==}]
set ::sprite2 [image create photo -data {
R0lGODlhEgASAKEBAAAAAP///////////yH5BAEKAAIALAAAAAASABIAAAI9lI+py+0PYwIU
ILtA2PQqDQadYGGGxomceaXoO1WiXH2zSs3TXIV1e+NxWjkVTnTIgZZKpPL1wpV61CqlAAA7}]
# allow the player to thrust
bind . <Up> { thrust up }
bind . <Down> { thrust down }
bind . <Left> { thrust left }
bind . <Right> { thrust right }
bind . <Key-n> { set ::config(gameStarted) no ;game .c }
bind . <Escape> exit
# HE: Auskommentiert damit Spiel nicht sofort startet
#game ".c"
gameCreate .c
======
----
[Moon Lander screen.png]
[gold]
----
<<categories>> Games | Animation | Example | Tk