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" "$@" ### 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 [ 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 ---- [Category Games]