Updated 2016-04-27 20:11:14 by gold

It could be observed very quickly, that Tcl/Tk is suitable to program games as well -- just look at the Tcl/Tk games page, or check out the references of Category Games.

Last year, I've tried to implement a simple arcade/action game in Tcl/Tk. The objective of the game is fairly simple: shot everything you've see floating in the sky, thus raising your score. Beware: every missed object fallen on the ground decreases your HP, and every shot increases the temperature of your laser gun, which needs the time to cool off.

Recently, I've revised the code and adjusted the appearance, but it's still implemented not just the right way, and the game process is rather boring. There're a lot of hard-coded values, which could be made configurable (with some presets like difficulty levels.) However, I've decided to release it anyway. May be it would be useful for someone.
 #!/bin/sh
 ### shooter-1.tk --- A Simple Arcade/Action Game  -*- Tcl -*-
 ## $Id: 16305,v 1.1 2006-08-21 18:00:34 jcw Exp $

 ## the next line restarts using tclsh \
 exec tclsh "$0" "[email protected]"

 ### Copyright (C) 2005, 2006 Ivan Shmakov

 ## Permission to copy this software, to modify it, to redistribute it,
 ## to distribute modified versions, and to use it for any purpose is
 ## granted, subject to the following restrictions and understandings.

 ## 1.  Any copy made of this software must include this copyright notice
 ## in full.

 ## 2.  I have made no warrantee or representation that the operation of
 ## this software will be error-free, and I am under no obligation to
 ## provide any services, by way of maintenance, update, or otherwise.

 ## 3.  In conjunction with products arising from the use of this
 ## material, there shall be no use of my name in any advertising,
 ## promotional, or sales literature without prior written consent in
 ## each case.

 ### Code:

 package require Tcl 8.4
 package require Tk  8.4

 namespace eval ::shoot { }

 ### UI Configuration

 foreach { pattern value } {
     *Background                 "NavyBlue"
     *Foreground                 "Wheat"
     *HighlightBackground        "NavyBlue"
     *HighlightColor             "SkyBlue"
     *left.relief                "flat"
     *left.buttons.relief        "flat"
     *left.buttons.Button.relief "groove"
     *left.buttons.new.text      "New"
     *left.buttons.pause.text    "Pause"
     *left.buttons.quit.text     "Quit"
     *left.status.relief         "groove"
     *left.status.Label.anchor   "se"
     *left.status.health.text    "HP"
     *left.status.score.text     "SC"
     *left.status.heat.text      "HT"
     *shooting.relief            "flat"
     *shooting.canvas.relief     "flat"
     *shooting.canvas.cursor     "target"
     *shooting.canvas.width      "384"
     *shooting.canvas.height     "512"
 } {
     option add $pattern $value "startupFile"
 }
 unset pattern value

 . configure -background [ option get . background Background ]

 ### Miscellaneous utility functions
 namespace eval ::shoot::util {
     namespace export \
         random-flat-int random-circle \
         coords-circle coords-offset coords-star
 }

 ## Random Numbers

 proc ::shoot::util::random-flat-int { a b } {
     ## .
     expr { int ($a + ($b - $a) * rand ()) }
 }

 proc ::shoot::util::random-circle { r } {
     set ri [ expr { - $r } ]
     while { 1 } {
         set x [ random-flat-int $ri $r ]
         set y [ random-flat-int $ri $r ]
         if { hypot ($x, $y) <= $r } {
             ## .
             return [ list $x $y ]
         }
     }
     error "unreachable"
 }

 ## Simple geometric calculations

 proc ::shoot::util::coords-circle { x y r } {
     ## .
     list \
         [ expr { $x - $r } ] [ expr { $y - $r } ] \
         [ expr { $x + $r } ] [ expr { $y + $r } ]
 }

 proc ::shoot::util::coords-offset { dx dy coords } {
     set result [ list ]
     foreach { x y } $coords {
         lappend result \
             [ expr { $x + $dx } ] [ expr { $y + $dy } ]
     }
     ## .
     set result
 }

 proc ::shoot::util::coords-star { x y } {
     ## .
     coords-offset $x $y {
         -4 0  -1 +1  0 +4  +1 +1  +4 0  +1 -1  0 -4  -1 -1
     }
 }

 ### Ray vs. Boundary Box intersections
 namespace eval ::shoot::util::intersect {
     namespace export ray-keyed-boxes
 }

 proc ::shoot::util::intersect::ray-0-seg { idx dy sx sy1 sy2 } {
     if { $idx * $sx < 0 } return
     set y [ expr { $dy * $idx * $sx } ]
     if { $y < $sy1 || $y > $sy2 } return
     ## .
     list $sx $y
 }

 proc ::shoot::util::intersect::ray-box { ray box } {
     set result [ list ]
     foreach { rx1 ry1 rx2 ry2 } $ray break
     foreach { bx1 by1 bx2 by2 } $box break
     set rdx [ expr { $rx2 - $rx1 } ]
     set rdy [ expr { $ry2 - $ry1 } ]
     set bdx1 [ expr { $bx1 - $rx1 } ]
     set bdx2 [ expr { $bx2 - $rx1 } ]
     set bdy1 [ expr { $by1 - $ry1 } ]
     set bdy2 [ expr { $by2 - $ry1 } ]
     if { $rdx != 0 } {
         set irdx [ expr { 1. / $rdx } ]
         foreach bdx [ list $bdx1 $bdx2 ] {
             set l [ ray-0-seg $irdx $rdy $bdx $bdy1 $bdy2 ]
             if { [ llength $l ] } {
                 foreach { dx dy } $l break
                 lappend result \
                     [ expr { $dx + $rx1 } ] [ expr { $dy + $ry1 } ]
             }
         }
     }
     if { $rdy != 0 } {
         set irdy [ expr { 1. / $rdy } ]
         foreach bdy [ list $bdy1 $bdy2 ] {
             set l [ ray-0-seg $irdy $rdx $bdy $bdx1 $bdx2 ]
             if { [ llength $l ] } {
                 foreach { dy dx } $l break
                 lappend result \
                     [ expr { $dx + $rx1 } ] [ expr { $dy + $ry1 } ]
             }
         }
     }
     ## .
     set result
 }

 proc ::shoot::util::intersect::ray-keyed-boxes { ray pairs } {
     foreach { rx ry } $ray break
     foreach { id box } $pairs {
         foreach { x y } [ ray-box $ray $box ] {
             set rho [ expr { hypot ($x - $rx, $y - $ry) } ]
             if { ! [ info exists c-rho ]
                  || $rho < ${c-rho} } {
                 set c-x $x
                 set c-y $y
                 set c-id $id
                 set c-rho $rho
             }
         }
     }

     if { ! [ info exists c-rho ] } return

     ## .
     list ${c-id} ${c-x} ${c-y} ${c-rho}
 }

 ### FIXME: the following is to be improved

 namespace import \
     ::shoot::util::coords-circle \
     ::shoot::util::coords-offset \
     ::shoot::util::coords-star \
     ::shoot::util::random-circle

 interp alias \
     { } intersect-ray-keyed-boxes \
     { } ::shoot::util::intersect::ray-keyed-boxes

 ## Canvas Utility

 proc item-center { c tagOrId } {
     set n 0
     set xs 0
     set ys 0
     foreach item [ $c find withtag $tagOrId ] {
         foreach { x y } [ $c coords $item ] {
             set xs [ expr { $xs + $x } ]
             set ys [ expr { $ys + $y } ]
             incr n
         }
     }
     if { $n == 0 } { return }
     set m [ expr { 1. / $n } ]

     ## .
     list [ expr { $m * $xs } ] [ expr { $m * $ys } ]
 }

 proc on-canvas { c x y args } {
     eval $args [ list [ $c canvasx $x ] [ $c canvasy $y ] ]
 }

 ## User Interface

 proc make-buttons-column { w buttons } {
     frame $w
     grid columnconfigure $w { 0 } -weight 1
     foreach { name command } $buttons {
         set b ${w}.${name}
         button $b -command $command
         grid $b -sticky new
     }
 }

 proc make-values-column { w pairs } {
     frame $w
     grid columnconfigure $w { 1 } -weight 1
     ## .
     foreach { wn varn } $pairs {
         set t2 ${w}.${wn}
         set t1 ${t2}val
         label $t1 -textvariable $varn
         label $t2
         grid $t2 -sticky ws
         grid ^ $t1 -sticky ews
     }
 }

 ## The Canvas

 proc make-shooting { w } {
     frame $w
     set c $w.canvas
     grid rowconfigure $w { 0 } -weight 1
     grid columnconfigure $w { 0 } -weight 1
     canvas $c
     bind $c <Motion> [ list on-canvas $c %x %y shooter-orient $c ]
     bind $c <1> [ list shooter-shoot $c ]
     bind $c <2> [ list on-canvas $c %x %y make-simple-target $c ]
     grid $c -sticky news
     ## .
     return
 }

 proc setup-shooting-background { c } {
     set cw [ $c cget -width ]
     set ch [ $c cget -height ]

     set dark [ expr { int (2. / 3. * $ch) } ]

     $c create rectangle \
         0 0 $cw $ch \
         -tags { boundary } \
         -width 0

     $c create rectangle \
         0 0 $cw $dark \
         -tags { background background-dark } \
         -fill gray10 \
         -width 0

     set gradient [ expr { $dark < 12 ? $dark : 12 } ]
     set v-mult   [ expr { 1. / $gradient * ($ch - $dark) } ]
     set c-mult   [ expr { 1. / ($gradient - 1) } ]
     set r* 127
     set g* 127
     set b* 191
     set g  [ expr { 1. / 1.6 } ]
     for { set i 0 } { $i < $gradient } { incr i } {
         set y1 [ expr { $dark + int (${v-mult} * $i) } ]
         set y2 [ expr { $dark + int (${v-mult} * ($i + 1)) } ]
         set value [ expr { pow (${c-mult} * $i, $g) } ]
         set color \
             [ format "\#%02x%02x%02x" \
                   [ expr { int (${r*} * $value) } ] \
                   [ expr { int (${g*} * $value) } ] \
                   [ expr { int (${b*} * $value) } ] ]
         $c create rectangle \
             0 $y1 $cw $y2 \
             -tags { background background-gradient } \
             -fill $color \
             -width 0
     }

     $c lower background boundary

     ## .
     return
 }

 ## Sparks

 proc make-sparks { c r x y { n 7 } } {
     global sparks
     for { } { $n > 0 } { incr n -1 } {
         foreach { ox oy } \
             [ coords-offset $x $y [ random-circle $r ] ] \
             break
         set id \
             [ $c create poly \
                   [ coords-star $ox $oy ] \
                   -tags spark \
                   -outline Yellow -fill White ]
         set sparks($id) [ expr { int (13 * rand ()) + 3 } ]
     }
 }

 proc spark-delete { c id } {
     global sparks
     if { ! [ info exists sparks($id) ] } \
         return
     $c delete $id
     unset sparks($id)
 }

 ## Targets

 proc make-simple-target { c x y } {
     global targets
     set score [ expr { int (3 + 7 * rand ()) } ]
     set radius [ expr { int (5 + $score) } ]
     set id \
         [ $c create oval [ coords-circle $x $y $radius ] \
               -tags target \
               -fill Red ]
     set targets($id) $score
 }

 proc target-shot { c id } {
     global targets
     set varn targets($id)
     if { ! [ info exists $varn ] } \
         return
     foreach { x y } [ item-center $c $id ] break
     make-sparks $c 3 $x $y
     $c delete $id
     set score [ set $varn ]
     unset $varn
     ## .
     set score
 }

 ## Laser Beams

 proc make-beam { c ttl args } {
     global beams
     set beams([ eval $c create line $args ]) $ttl
 }

 proc beam-delete { c id } {
     global beams
     set varn beams($id)
     if { ! [ info exists $varn ] } \
         return
     $c delete $id
     unset $varn
 }

 ## The Shooter

 proc shooter-create { c } {
     global shooter-radius
     global shooter-x
     global shooter-y

     $c create arc \
         [ coords-circle ${shooter-x} ${shooter-y} ${shooter-radius} ] \
         -start 0 -extent 180 \
         -fill gray80 \
         -tags [ list shooter shooter-base ]
     $c create line \
         ${shooter-x} \
         [ expr { ${shooter-y} - .5 * ${shooter-radius} } ] \
         ${shooter-x} \
         [ expr { ${shooter-y} - ${shooter-radius} } ] \
         -width 3 \
         -tags [ list shooter shooter-gun ]
     $c raise shooter-gun shooter-base
 }

 proc shooter-dead? { c } {
     global shooter-health
     expr { ${shooter-health} <= 0 }
 }

 proc shooter-orient { c x y } {
     global game-paused
     global shooter-radius
     global shooter-x
     global shooter-y

     if { ${game-paused}
          || [ shooter-dead? $c ]
          || $y >= ${shooter-y} } \
         return

     set dx [ expr { $x - ${shooter-x} } ]
     set dy [ expr { $y - ${shooter-y} } ]
     set dr [ expr { hypot ($dx, $dy) } ]
     set mult \
         [ expr { ($dr < 1e-3) ? 0 : (${shooter-radius} / $dr) } ]

     $c coords shooter-gun \
         [ expr { ${shooter-x} + .5 * $mult * $dx } ] \
         [ expr { ${shooter-y} + .5 * $mult * $dy } ] \
         [ expr { ${shooter-x} + $mult * $dx } ] \
         [ expr { ${shooter-y} + $mult * $dy } ]
 }

 proc shooter-target-ground { c id } {
     if { ! [ string length \
                  [ set damage [ target-shot $c $id ] ] ]
          || [ shooter-dead? $c ] } {
         ## .
         return
     }

     global shooter-health
     global shooter-radius

     if { [ incr shooter-health [ expr { - $damage } ] ] <= 0 } {
         set shooter-health 0
         foreach { x y } [ item-center $c shooter ] break
         after idle [ list make-sparks $c ${shooter-radius} $x $y 131 ]
         after idle [ list $c delete shooter ]
     }
 }

 proc shooter-shoot { c } {
     global game-paused
     global shooter-heat
     global shooter-heat-inc
     global shooter-heat-max

     ## check for overheat, etc.
     if { ${game-paused}
          || [ shooter-dead? $c ]
          || (${shooter-heat}
              > ${shooter-heat-max} - ${shooter-heat-inc}) } \
         return
     incr shooter-heat ${shooter-heat-inc}

     ## get the ray
     set ray [ $c coords shooter-gun ]
     foreach { rx ry } $ray break

     ## get the bboxes
     global shooter-y
     global targets
     set bboxes \
         [ list scene-boundary [ $c coords boundary ] ]
     foreach id [ array names targets ] {
         lappend bboxes $id [ $c bbox $id ]
     }

     ## find closest intersection
     foreach { c-id c-x c-y c-rho } \
         [ intersect-ray-keyed-boxes $ray $bboxes ] \
         break
     if { ! [ info exists c-id ] } {
         ## NB: no values returned, should not happen
         return
     }

     ## draw some laser beam
     make-beam $c [ expr { int (3 + 3 * rand ()) } ] \
         $rx $ry ${c-x} ${c-y} \
         -tags beam -fill Red

     ## increase the score
     if { [ string equal ${c-id} scene-boundary ] } \
         return
     global shooter-score
     incr shooter-score [ target-shot $c ${c-id} ]
 }

 ## Animation

 proc animate-shooter { c } {
     if { [ shooter-dead? $c ] } \
         return

     ## cool the weapon
     global shooter-heat
     if { ${shooter-heat} > 0 } {
         incr shooter-heat -1
     }

     return
 }

 proc animate-beams { c } {
     global beams

     foreach id [ array names beams ] {
         set new [ incr beams($id) -1 ]
         if { $new < 0 } {
             after idle [ list beam-delete $c $id ]
         } else {
             after idle \
                 [ list $c itemconfigure $id \
                       -fill [ expr { ($new % 2)
                                      ? "Red" : "Black" } ] ]
         }
     }
 }

 proc animate-sparks { c } {
     global sparks
     set dy 2
     foreach id [ array names sparks ] {
         set dx [ expr { 4 * (rand () - .5) } ]
         $c move $id $dx $dy
         if { [ incr sparks($id) -1 ] < 0 } {
             after idle [ list spark-delete $c $id ]
         }
     }
 }

 proc animate-targets { c } {
     global targets
     global shooter-y

     ## animate existing targets
     set dy 3
     foreach id [ array names targets ] {
         set dx [ expr { 6 * (rand () - .5) } ]
         $c move $id $dx $dy
         foreach { x1 y1 x2 y2 } [ $c bbox $id ] \
             break
         if { $y2 > ${shooter-y} } {
             after idle \
                 [ list shooter-target-ground $c $id ]
         }
     }

     ## create new ones
     if { [ array size targets ] < 32
          && rand () > 0.95 } {
         foreach { bx1 by1 bx2 by2 } [ $c coords boundary ] \
             break
         make-simple-target $c \
             [ expr { $bx1 + ($bx2 - $bx1) * rand () } ] $by1
     }

     return
 }

 proc animate { c { delay 100 } } {
     animate-shooter $c
     animate-beams $c
     animate-sparks $c
     animate-targets $c

     ## schedule next update
     global animate-id
     global game-paused
     if { ! ${game-paused} } {
         set animate-id \
             [ after $delay [ list animate $c $delay ] ]
     } else {
         set animate-id ""
     }
 }

 ## Main

 proc game-new { wc } {
     global animate-id
     if { [ info exists animate-id ]
          && [ string length ${animate-id} ] } {
         after cancel ${animate-id}
     }
     set animate-id ""

     global sparks
     global targets

     array unset sparks
     array set sparks [ list ]

     array unset targets
     array set targets [ list ]

     $wc delete all
     setup-shooting-background $wc

     global beams
     array unset beams
     array set beams [ list ]

     global shooter-health
     global shooter-heat
     global shooter-heat-inc
     global shooter-heat-max
     global shooter-score

     set shooter-health 100
     set shooter-heat 0
     set shooter-heat-inc 15
     set shooter-heat-max 100
     set shooter-score 0

     foreach { bx1 by1 bx2 by2 } \
         [ $wc coords boundary ] \
         break

     global shooter-radius
     global shooter-x
     global shooter-y

     set shooter-radius 31
     set shooter-x [ expr { .5 * ($bx2 + $bx1) } ]
     set shooter-y $by2

     global game-paused
     set game-paused 1
     after idle [ list shooter-create $wc ]
     after idle [ list game-pause-toggle $wc ]

     return
 }

 proc game-pause-toggle { wc } {
     global game-paused
     if { ${game-paused} } {
         set game-paused 0
         after idle [ list animate $wc ]
     } else {
         set game-paused 1
     }
 }

 set w .
 set wl .left
 set wb $wl.buttons
 set wt $wl.status
 set ws .shooting
 set wc $ws.canvas

 set game-paused 1

 grid rowconfigure $w { 0 } -weight 1
 grid columnconfigure $w { 0 } -weight 0
 grid columnconfigure $w { 1 } -weight 1

 frame $wl
 grid $wl -row 0 -column 0 -sticky news
 grid rowconfigure $wl 1 -weight 1

 make-buttons-column $wb \
     [ list \
           new   [ list game-new $wc ] \
           pause [ list game-pause-toggle $wc ] \
           quit  [ list destroy $w ] ]
 grid $wb -row 0 -column 0 -sticky new

 make-values-column $wt {
     health ::shooter-health
     score  ::shooter-score
     heat   ::shooter-heat
 }
 grid $wt -row 2 -column 0 -sticky new

 make-shooting $ws
 grid $ws -row 0 -column 1 -sticky news

 ### Emacs stuff
 ## Local variables:
 ## fill-column: 72
 ## indent-tabs-mode: nil
 ## ispell-local-dictionary: "english"
 ## mode: outline-minor
 ## outline-regexp: "###\\|proc"
 ## End:
 ## LocalWords:  
 ### shooter-1.tk ends here

Screenshots Section

figure 1.

gold added pix