#!/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.5
 package require Tk  8.5

 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 ]
     lassign $ray rx1 ry1 rx2 ry2
     lassign $box bx1 by1 bx2 by2
     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 ] } {
                 lassign $l dx dy
                 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 ] } {
                 lassign $l dy dx
                 lappend result \
                     [ expr { $dx + $rx1 } ] [ expr { $dy + $ry1 } ]
             }
         }
     }
     ## .
     set result
 }

 proc ::shoot::util::intersect::ray-keyed-boxes { ray pairs } {
     lassign $ray rx ry
     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 } {
         lassign [coords-offset $x $y [random-circle $r]] ox oy
         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 }
     lassign [ item-center $c $id ] x y
     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
         lassign [ item-center $c shooter ] x y
         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 ]
     lassign $ray rx ry

     ## 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
     lassign [ intersect-ray-keyed-boxes $ray $bboxes ] c-id c-x c-y c-rho
     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
         lassign [ $c bbox $id ] x1 y1 x2 y2
         if { $y2 > ${shooter-y} } {
             after idle [ list shooter-target-ground $c $id ]
         }
     }

     ## create new ones
     if { [ array size targets ] < 32
          && rand () > 0.95 } {
         lassign [ $c coords boundary ] bx1 by1 bx2 by2
         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

     lassign [ $wc coords boundary ] bx1 by1 bx2 by2

     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