Updated 2007-06-27 12:45:15 by LV

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}

Category Games