Pocket Space Invaders
Richard Suchenwirth 2005-09-30 - This is a version of Jos Decoster's Space Invaders tweaked to run well on a PocketPC (HTC Magician in my case).
package require Tk
set about {Space Invaders
by Jos DeCoster 2005
PocketPC port by R. Suchenwirth
Left/right to move, Up/Down to shoot
}
namespace eval ::si {
variable cstat -1
variable ccnt
variable clvl 0
variable cscore 0
variable cbln 0
variable cpath
variable cv_w 240
variable cv_h 270
variable cafter -1
variable font {Helvetica 16}
}
proc ::si::init_cv { lvl } {
variable cpath
variable cv
variable cv_w
variable cv_h
variable catt_x 10
variable catt_y 10
variable catt_r 7
variable catt_c 7
variable catt_w 15
variable catt_h 15
variable catt_ix 25
variable catt_iy 25
variable catt_sx 10
variable catt_sy 10
variable csh_w 30
variable csh_h 15
variable csh_sx 10
variable cbl_iy -10
variable cbl_r 3
variable cbll {}
variable csh_id
variable cstat 0
variable ccnt 0
variable cafter -1
variable cbln
if { [info exists cv] && [winfo exists $cv] } {
::destroy $cv
}
set cv [canvas $cpath -width $cv_w -height $cv_h -bg black]
pack $cv -side bottom
focus $cv
set nat 0
for { set r 0 } { $r < $catt_r} { incr r } {
for { set c 0 } { $c < $catt_c } { incr c } {
set x0 [expr {$catt_x + $c*$catt_ix}]
set x1 [expr {$x0 + $catt_w}]
set y0 [expr {$catt_y + $r*$catt_iy}]
set y1 [expr {$y0 + $catt_h}]
set t [format "att_%d_%d" $r $c]
$cv create rect $x0 $y0 $x1 $y1 -tag [list att $t] -fill yellow
incr nat
set rr [expr {int((20+$lvl) * rand())}]
if { $rr > 20 } {
$cv create rect $x0 $y0 $x1 $y1 -tag [list att $t] -fill cyan
incr nat
if { $rr > 25 } {
$cv create rect $x0 $y0 $x1 $y1 -tag [list att $t] -fill green
incr nat
if { $rr > 30 } {
$cv create rect $x0 $y0 $x1 $y1 -tag [list att $t] \
-fill purple
incr nat
if { $rr > 35 } {
$cv create rect $x0 $y0 $x1 $y1 -tag [list att $t] \
-fill blue
incr nat
}
}
}
}
}
}
set cbln [expr {$cbln + round($nat * 1.4)}]
set cvw2 [expr {$cv_w / 2}]
set shw2 [expr {$csh_w / 2}]
set x0 [expr {$cvw2 - $shw2}]
set y0 [expr {$cv_h - 1}]
set x1 [expr {$cvw2 + $shw2}]
set y1 $y0
set x2 $cvw2
set y2 [expr {$cv_h - $csh_h}]
set csh_id [$cv create polygon $x0 $y0 $x1 $y1 $x2 $y2 -tag sh -fill red]
bind $cv <Left> [list ::si::step_sh l]
bind $cv <Right> [list ::si::step_sh r]
bind $cv <KeyRelease-Down> [list ::si::start_bl]
bind $cv <KeyRelease-Up> [list ::si::start_bl]
}
proc ::si::step_sh { dir } {
variable cv
variable cv_w
variable csh_sx
variable cstat
if { $cstat != 0 } {
return
}
foreach {mx my Mx My} [$cv bbox sh] { break }
if { $dir == "l" } {
if { [expr {$mx - $csh_sx}] > 0 } {
$cv move sh -$csh_sx 0
}
} else {
if { [expr {$Mx + $csh_sx}] < $cv_w } {
$cv move sh $csh_sx 0
}
}
}
proc ::si::step_att { } {
variable cv
variable cv_w
variable cv_h
variable catt_w
variable catt_sx
variable catt_sy
variable cstat
set dx 0
set dy 0
set bbox [$cv bbox att]
if { [llength $bbox] } {
foreach {mx my Mx My} $bbox { break }
if { $My > $cv_h } {
set cstat 1
} elseif { $catt_sx < 0 } {
if { [expr {$mx + $catt_sx}] < 0 } {
set dy $catt_sy
set catt_sx [expr {-$catt_sx}]
} else {
set dx $catt_sx
}
} else {
if { $Mx > ($cv_w - $catt_w - $catt_sx) } {
set dy $catt_sy
set catt_sx [expr {-$catt_sx}]
} else {
set dx $catt_sx
}
}
}
$cv move att $dx $dy
}
proc ::si::step_bl { } {
variable cv
variable cbl_iy
$cv move bl 0 $cbl_iy
}
proc ::si::start_bl { } {
variable cv
variable cbl_r
variable cbll
variable cstat
variable cbln
if { $cstat != 0 || $cbln <= 0 } {
return
}
foreach {mx my Mx My} [$cv bbox sh] { break }
set x [expr {($mx+$Mx)/2}]
set y [expr {$my - $cbl_r}]
set x0 [expr {$x - $cbl_r}]
set x1 [expr {$x + $cbl_r}]
set y0 [expr {$y - $cbl_r}]
set y1 [expr {$y + $cbl_r}]
set id [$cv create rect $x0 $y0 $x1 $y1 -tag bl -fill orange]
$cv raise $id
lappend cbll $id
incr cbln -1
}
proc ::si::detect_col { } {
variable cv
variable cbll
variable csh_id
variable cstat
variable cscore
variable cbln
set nbll {}
foreach bli $cbll {
set bb [$cv bbox $bli]
if { [lindex $bb 3] < 0 } continue
set il [eval $cv find overlapping $bb]
set col 0
for { set idx [expr {[llength $il]-1}] } { $idx >= 0 } { incr idx -1 } {
set i [lindex $il $idx]
if { $i != $bli } {
$cv delete $i $bli
incr cscore 10
incr col
break
}
}
if { !$col } {lappend nbll $bli}
}
set cbll $nbll
set il [eval $cv find overlapping [$cv bbox sh]]
foreach i $il {
if { $i != $csh_id } {
$cv delete $csh_id
set cstat 3
return
}
}
set bbox [$cv bbox att]
if { [llength $bbox] == 0 } {
set cstat 2
return
}
if { ($cbln <= 0) && ([llength $cbll] == 0) } {set cstat 4}
}
proc ::si::loop { } {
variable cstat
variable ccnt
variable clvl
variable cafter
variable cv
variable cv_w
variable cv_h
variable ngame
variable font
incr ccnt
if { $clvl >= 50 || $ccnt == (50-$clvl) } {
::si::step_att
set ccnt 0
}
::si::step_bl
::si::detect_col
switch -exact $cstat {
0 {set cafter [after 10 ::si::loop]}
1 {
$cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] \
-text "Game over ...\nAttackers at bottom." \
-font $font -fill white
update
$ngame configure -text "New game" -command ::si::new_game
}
2 {
$cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] \
-text "Level $clvl\ncompleted!" -font $font \
-fill white
update
after 1000
incr clvl
::si::init_cv $clvl
set cafter [after 10 ::si::loop]
}
3 {
$cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] \
-text "Game over ...\nYou were hit by attacker." \
-font $font -fill white
update
$ngame configure -text "New game" -command ::si::new_game
}
4 {
$cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] \
-text "Game over ...\nYou ran out of bullets." \
-font $font -fill white
update
$ngame configure -text "New game" -command ::si::new_game
}
}
}
proc ::si::start { } {
variable cpath
variable cstat
variable cv
variable cv_w
variable cv_h
variable ngame
expr srand([pid])
set tf [frame .tf]
set lf [frame .lf]
set llabel [label $lf.llabel -text "Level"]
set ltext [label $lf.ltext -textvariable ::si::clvl -bg white]
set blabel [label $lf.blabel -text "Bullets"]
set btext [label $lf.btext -textvariable ::si::cbln -bg white]
set slabel [label $lf.slabel -text "Score"]
set stext [label $lf.stext -textvariable ::si::cscore -bg white]
set info [button $lf.? -text ? -command {tk_messageBox -message $::about}]
set ngame [button $lf.ngame -text "New game" -command ::si::new_game]
set x [button $lf.x -text X -command exit]
grid $llabel $ltext $blabel $btext $slabel $stext $info $ngame $x
pack $tf $lf -side bottom
set cpath $tf.cv
set cv [canvas $cpath -width $cv_w -height $cv_h -bg black]
pack $cv
focus $cv
$cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] -text "Space\nInvaders" \
-font "Helvetica 24 bold" -fill white
set cstat -1
}
proc ::si::new_game {} {
variable cafter
variable ngame
if { $cafter >= 0 } {after cancel $cafter}
variable cstat 0
variable clvl 0
variable cscore 0
variable cbln 0
$ngame configure -text Pause -command ::si::pause
::si::init_cv 0
::si::loop
}
proc ::si::pause { } {
variable cafter
variable ngame
if { $cafter >= 0 } {after cancel $cafter}
$ngame configure -text Resume -command ::si::resume
}
proc ::si::resume { } {
variable ngame
variable cstat
if { $cstat == 0 } {
$ngame configure -text Pause -command ::si::pause
::si::loop
}
}
#--------------------------------------------------------
::si::start
wm geometry . 240x300+0+0
bind . <Return> {exec wish $argv0 &; exit}