Updated 2012-11-21 23:07:57 by pooryorick

Jos Decoster A Tcl implementation of an old DOS game.


To get 'auto fire', replace the "incr cbln -1" in ::si::start_bl with "after 10 {::si::start_bl}". With this, level 46 is as far as i can get.

Jos Decoster In a first version, shooting was bound to 'KeyPress-Space'. The kids pretty soon found out that moving to the side and holding the space bar down was the easiest way to clear a level.

MG A great little game, thanks for sharing it :) I found a bug, though - when you lose because you ran out of the bullets, the Pause button doesn't turn into a "new game" button, like it does when you lose for another reason. In the '4' part of the switch in ::si::loop, should that closing } be after the $name configure instead of after the puts where it is now?

Jos Decoster Thanks. You are right about case '4'. Fixed it in the code below.

Brian Theado - added package require Tk so it will work in a slave interpreter (i.e. Tk Game Pack)

ZB I'm wondering, why it is so carefully made all in its own namespace? Of course, there's nothing wrong with that - but, actually, what's the point? What are advantages of moving it all into own namespace?

I'm asking, because it's not an extension, neither any library - but a game, I mean: "standalone" software.

jdc Now I only have to add package provide si 1.0 and a pkgIndex.tcl file to make it an extension :-) No special reason to use namespaces here other than me prefering to use variable iso global.

PocketPC version at Pocket Space Invaders
package require Tk
namespace eval ::si {
    variable cstat -1
    variable ccnt
    variable clvl 0
    variable cscore 0
    variable cbln 0
    variable cpath
    variable cv_w 500
    variable cv_h 500
    variable cafter -1
}

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 30
    variable catt_h 30
    variable catt_ix 50
    variable catt_iy 50
    variable catt_sx 20
    variable catt_sy 30
    variable csh_w 60
    variable csh_h 30
    variable csh_sx 20
    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
    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 rectangle $x0 $y0 $x1 $y1 -tag [list att $t] -fill yellow
            incr nat
            set rr [expr {int((20+$lvl) * rand())}]
            if { $rr > 20 } {
                $cv create rectangle $x0 $y0 $x1 $y1 -tag [list att $t] -fill cyan
                incr nat
                if { $rr > 25 } {
                    $cv create rectangle $x0 $y0 $x1 $y1 -tag [list att $t] -fill green
                    incr nat
                    if { $rr > 30 } { 
                        $cv create rectangle $x0 $y0 $x1 $y1 -tag [list att $t] -fill purple
                        incr nat
                        if { $rr > 35 } {
                            $cv create rectangle $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-space> [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 > [expr {$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 oval $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

    incr ccnt

    if { $clvl >= 50 || $ccnt == [expr {50-$clvl}] } {
        ::si::step_att
        set ccnt 0
    }
    ::si::step_bl
    ::si::detect_col
    if { $cstat == 0 } {
        set cafter [after 10 ::si::loop]
    } else {
        switch -exact $cstat {
            1 { 
                $cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] -text "Game over ...\nAttackers at bottom." -font "Helvetica 24" -fill white -justify center
                update
                puts "att at bottom" 
                $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 "Helvetica 24" -fill white -justify center
                update
                after 1000
                incr clvl
                ::si::init_cv $clvl
                set cafter [after 10 ::si::loop]
                puts "all att hit" 
            }
            3 { 
                $cv create text [expr {$cv_w/2}] [expr {$cv_h/2}] -text "Game over ...\nYou were hit by attacker." -font "Helvetica 24" -fill white -justify center
                update
                puts "sh hit by att" 
                $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 "Helvetica 24" -fill white -justify center
                update
                puts "out of bl"
                $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 title [label $lf.title -text "Space Invaders"]
    grid $title -

    set llabel [label $lf.llabel -text "Level"]
    set ltext  [label $lf.ltext -textvariable ::si::clvl]
    grid $llabel $ltext

    set blabel [label $lf.blabel -text "Bullets"]
    set btext  [label $lf.btext -textvariable ::si::cbln]
    grid $blabel $btext

    set slabel [label $lf.slabel -text "Score"]
    set stext  [label $lf.stext -textvariable ::si::cscore]
    grid $slabel $stext

    set ngame [button $lf.ngame -text "New game" -command ::si::new_game]
    grid $ngame -

    pack $tf $lf -side left

    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" -fill white -justify center

    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 cafter
    variable ngame
    variable cstat

    if { $cstat == 0 } { 
        $ngame configure -text Pause -command ::si::pause
        ::si::loop
    }
}

::si::start