#!/usr/local/bin/wish

# 
# Copyright 1999 Thomas A. Fine
# Permission is granted to destribute whole without restrictions.
# Permission is granted to destribute in part so long as this notice
# is included.
#

#set RANDFILE ~/tcl/rnd.1-20x1000
set RANDFILE {| perl -e "srand(time+$$); for ($i=0; $i<1000; ++$i) { print int(rand(20))+1, '\n'; }" }

frame .top
pack .top -fill x

button .top.quit -text Quit -command exit
pack .top.quit -side right

button .top.restart -text Restart -command "set restart 1"
pack .top.restart -side right

set smartbombs 1
set missed 0
set totaldead 0
set debriskills 0
set shotkills 0
set onplanekills 0

label .top.smart -textvar smartbombs; pack .top.smart -side left
label .top.lsmart -text "SB    "; pack .top.lsmart -side left

label .top.lmiss -text "Escaped:"; pack .top.lmiss -side left
label .top.miss -textvar missed; pack .top.miss -side left -padx 2
label .top.ldead -text "Dead:"; pack .top.ldead -side left
label .top.dead -textvar totaldead; pack .top.dead -side left -padx 2
label .top.lshot -text "Shot:"; pack .top.lshot -side left
label .top.shot -textvar shotkills; pack .top.shot -side left -padx 2
label .top.ldebris -text "Debris:"; pack .top.ldebris -side left
label .top.debris -textvar debriskills; pack .top.debris -side left -padx 2
label .top.lonplane -text "Onplane:"; pack .top.lonplane -side left
label .top.onplane -textvar onplanekills; pack .top.onplane -side left -padx 2

canvas .canvas -bg white -width 600 -height 500
pack .canvas -side bottom

update

set PI 3.14159265
set PI_2 [expr $PI/2.0]
set WD [winfo width .canvas]
set canonx [expr $WD/2]
set canony [winfo height .canvas]
set canonang $PI
set keybd(movecanonleft) 0
set keybd(movecanonright) 0
set keybd(shoot) 0
set keybd(smartbomb) 0
set shots ""
set planes ""
set paras ""
set debris ""
set planeinfo(last) 0
set parainfo(last) 0
set paraspace 3
set shotmod 3
set shotcount 0
set objmod 30
set objcount 0
set shotspddiv 2.5
set restart 0
set notdead 1
set paused 0
set sbthresh 500

.canvas create oval [expr $canonx-10] [expr $canony-10] \
		    [expr $canonx+10] [expr $canony+10] \
		    -fill darkgrey -tag canonbase
.canvas create line $canonx $canony \
	    [expr $canonx+int(30*sin($canonang))] \
	    [expr $canony+int(30*cos($canonang))] \
	    -width 3 -tag canon

bind .canvas <c> "set waiting 1"
bind .canvas <q> exit
bind .canvas <Escape> { set paused [expr abs($paused-1)] }
bind .canvas <Left> "set keybd(movecanonleft) 1"
bind .canvas <KeyRelease-Left> "set keybd(movecanonleft) 0"
bind .canvas <Right> "set keybd(movecanonright) 1"
bind .canvas <KeyRelease-Right> "set keybd(movecanonright) 0"
bind .canvas <Motion> "canonat %x %y"
#bind .canvas <space> "set keybd(shoot) 1"
#bind .canvas <KeyRelease-space> "set keybd(shoot) 0"
bind .canvas <space> "set keybd(smartbomb) 1"
#bind .canvas <KeyRelease-space> "set keybd(smartbomb) 0"

focus .canvas

if [info tclversion]<8.0 {
  set file  [open $RANDFILE r]
  while {[gets $file line]>-1} {
    lappend randlist $line
  }
  close $file
  #set ri 0
  #try to set ri to a "random" number so we don't get same pattern each time
  #when the random file is used (wish we had PID!)
  #scan [winfo id .] %x ri
  set ri [exec sh -c "echo $$"]
  set ri [expr $ri%1000]
} else {
  for {set i 0} {$i<1000} {incr i} {
    lappend randlist [expr int(rand()*20)+1]
  }
  set ri 0
}

proc getrand {} {
  global randlist ri
  set ret [lindex $randlist $ri]
  if [incr ri]>=1000 {
    set ri 0
  }
  return $ret
}

proc canonat {x y} {
  global canonx canony canonang PI PI_2 paused
  if $paused return
  set dx [expr $x-$canonx]
  set dy [expr $y-$canony]
  set mag [expr sqrt($dx*$dx+$dy*$dy)]
  set dx [expr $dx/$mag];
  #set dy [expr $dy/$mag];
  set canonang [expr acos($dx)+$PI_2]
  if ($canonang>($PI+$PI_2-0.2)) { set canonang [expr $PI+$PI_2-0.2] }
  if ($canonang<($PI_2+0.2)) { set canonang [expr $PI_2+0.2] }

  .canvas coords canon $canonx $canony \
	    [expr $canonx+int(30*sin($canonang))] \
	    [expr $canony+int(30*cos($canonang))]
}

proc canonleft {} {
  global canonx canony canonang PI PI_2
  set canonang [expr $canonang+0.05]
  if ($canonang>($PI+$PI_2-0.2)) {
    set canonang [expr $canonang-0.05]
  }

  .canvas coords canon $canonx $canony \
	    [expr $canonx+int(30*sin($canonang))] \
	    [expr $canony+int(30*cos($canonang))]
}

proc canonright {} {
  global canonx canony canonang PI PI_2
  set canonang [expr $canonang-0.05]
  if ($canonang<($PI_2+0.2)) {
    set canonang [expr $canonang+0.05]
  }

  .canvas coords canon $canonx $canony \
	    [expr $canonx+int(30*sin($canonang))] \
	    [expr $canony+int(30*cos($canonang))]
}

proc shoot {} {
  global shots canonx canony shotinfo canonang shotspddiv
  set x [expr $canonx+int(30*sin($canonang))]
  set y [expr $canony+int(30*cos($canonang))]
  set id [.canvas create rectangle $x $y [expr $x+1] [expr $y+1]]
  #set id [.canvas create oval [expr $x-5] [expr $y-5] [expr $x+5] [expr $y+5]]
  lappend shots $id
  set shotinfo($id,dx) [expr ($x-$canonx)/$shotspddiv]
  set shotinfo($id,dy) [expr ($y-$canony)/$shotspddiv]
}

proc makeplane {} {
  global planes planeinfo WD
  set id plane[incr planeinfo(last)]
  set y [expr [getrand]*4+20]
  #set planeinfo($id,numpara) [expr [getrand]%8]
  set planeinfo($id,numpara) [getrand]
  if [expr [getrand]%2] {
    set planeinfo($id,dx) [expr [getrand]%7+1]
    .canvas create line 0 0 -50 0 -60 -10 -width 10 -tags $id
    .canvas move $id 0 $y
  } else {
    set planeinfo($id,dx) [expr 0-([getrand]%7+1)]
    .canvas create line 0 0 50 0 60 -10 -width 10 -tags $id
    .canvas move $id $WD $y
  }
  set planeinfo($id,dy) 0
  set planeinfo($id,dropfr) [expr (20/abs($planeinfo($id,dx)))*[getrand]+5]
  set planeinfo($id,hits) 0
  lappend planes $id
}

proc moveplane {id} {
  global planeinfo paraspace WD
  .canvas move $id $planeinfo($id,dx) $planeinfo($id,dy)
  set cords [.canvas coords $id]
  if ($planeinfo($id,dx)<0)&&([lindex $cords 4]<0) {
    deleteplane $id
    return
  }
  if ($planeinfo($id,dx)>0)&&([lindex $cords 4]>$WD) {
    deleteplane $id
    return
  }
  if [incr planeinfo($id,dropfr) -1]==0 {
    if $planeinfo($id,numpara) {
      if ($planeinfo($id,dx)<0) {
	set x [expr [lindex $cords 0]+25]
	if ($x>$WD) {   #don't create before on screen
	  incr planeinfo($id,dropfr) 1
	  return
	} elseif ($x<0) {   #don't create after off screen
          set planeinfo($id,numpara) 0
          return
        }
      } else {
	set x [expr [lindex $cords 0]-25]
	if ($x<0) {   #don't create before on screen
	  incr planeinfo($id,dropfr) 1
	  return
	} elseif ($x>$WD) {   #don't create after off screen
          set planeinfo($id,numpara) 0
          return
        }
      }
      set y [expr [lindex $cords 1]+5]
      makepara $x $y
      incr planeinfo($id,numpara) -1
      set planeinfo($id,dropfr) $paraspace
    }
  }
}

proc makepara {x y} {
  global paras parainfo
  set id para[incr parainfo(last)]
  .canvas create line $x $y $x [expr $y+7] -width 2 -tags $id
  .canvas create line [expr $x-5] [expr $y+3] [expr $x+5] [expr $y+3] -width 2 -tags $id
  .canvas create line $x [expr $y+7] [expr $x-4] [expr $y+10] -width 2 -tags $id
  .canvas create line $x [expr $y+7] [expr $x+4] [expr $y+10] -width 2 -tags $id
  .canvas create oval [expr $x-3] [expr $y-4] [expr $x+1] [expr $y+0] -tags $id
  set parainfo($id,dx) 0
  set parainfo($id,dy) 2
  lappend paras $id
}

proc movepara {id} {
  global parainfo missed
  .canvas move $id $parainfo($id,dx) $parainfo($id,dy)
  set bbox [.canvas bbox $id]
  if [lindex $bbox 1]>[winfo height .canvas] {
    deletepara $id
    incr missed
  }
}

proc moveshot {id} {
  global shotinfo shots WD
  set cords [.canvas coords $id]
  if [lindex $cords 0]<0 { deleteshot $id; return }
  if [lindex $cords 0]>$WD { deleteshot $id; return }
  if [lindex $cords 1]<0 { deleteshot $id; return }
  if [lindex $cords 1]>[winfo height .canvas] { deleteshot $id; return }
  set collide [eval .canvas find overlapping $cords]
  if [llength $collide] {
    foreach obj $collide {
      if $obj==$id continue
      if [string compare [.canvas itemcget $obj -tags] canon]==0 continue
      hitobject $obj 1
      deleteshot $id
      return
    }
  }
  .canvas move $id $shotinfo($id,dx) $shotinfo($id,dy)
}

proc makedebris {x y radius life} {
  global debris debrisinfo
  set id [.canvas create rectangle $x $y [expr $x+$radius] [expr $y+$radius] -fill black -tags debris]
  lappend debris $id
  set debrisinfo($id,dx) [expr [getrand]/4.0-2.5]
  set debrisinfo($id,dy) [expr [getrand]/4.0-2.5]
  set debrisinfo($id,fr) $life
}

proc movedebris {id} {
  global debrisinfo debris
  if [incr debrisinfo($id,fr) -1]<=0 { deletedebris $id; return }
  set cords [.canvas coords $id]
  set collide [eval .canvas find overlapping $cords]
  if [llength $collide] {
    foreach obj $collide {
      if $obj==$id continue
      if [string compare [.canvas itemcget $obj -tags] canon]==0 continue
      if [string compare [.canvas itemcget $obj -tags] debris]==0 continue
      hitobject $obj 0
      deletedebris $id
      return
    }
  }
  .canvas move $id $debrisinfo($id,dx) $debrisinfo($id,dy)
}

proc deleteshot {id} {
  global shotinfo shots
  .canvas delete $id
  unset shotinfo($id,dx)
  unset shotinfo($id,dy)
  set i [lsearch -exact $shots $id]
  set shots [lreplace $shots $i $i]
}

proc deleteplane {id} {
  global planeinfo planes totaldead onplanekills smartbombs sbthresh
  .canvas delete $id
  if [incr totaldead $planeinfo($id,numpara)]>$sbthresh {
    incr smartbombs
    incr sbthresh 500
  }
  incr onplanekills $planeinfo($id,numpara)
  unset planeinfo($id,dx)
  unset planeinfo($id,dy)
  unset planeinfo($id,numpara)
  unset planeinfo($id,dropfr)
  unset planeinfo($id,hits)
  set i [lsearch -exact $planes $id]
  set planes [lreplace $planes $i $i]
}

proc deletepara {id} {
  global parainfo paras
  .canvas delete $id
  unset parainfo($id,dx)
  unset parainfo($id,dy)
  set i [lsearch -exact $paras $id]
  set paras [lreplace $paras $i $i]
}

proc deletedebris {id} {
  global debrisinfo debris
  .canvas delete $id
  unset debrisinfo($id,dx)
  unset debrisinfo($id,dy)
  set i [lsearch -exact $debris $id]
  set debris [lreplace $debris $i $i]
}

proc hitobject {id shot} {
  global planeinfo totaldead shotkills debriskills smartbombs sbthresh
  set idtags [lindex [.canvas itemcget $id -tags] 0]
  if [string first plane $idtags]==0 {
    if ($planeinfo($idtags,hits)==0) {
      .canvas itemconfig $idtags -fill #606060
      incr planeinfo($idtags,hits)
      return
    }
    set cords [.canvas coords $id]
    set right 0
    if $planeinfo($idtags,dx)>0 { set right 1 }
    deleteplane $idtags
    #replace with debris
    set x [lindex $cords 0]
    set y [lindex $cords 1]
    if $right {
      makedebris $x $y 7.5 15
      makedebris [expr $x-20] $y 7.5 17
      makedebris [expr $x-30] $y 7.5 18
      makedebris [expr $x-40] $y 7.5 21
      makedebris [expr $x-50] $y 7.5 23
    } else {
      makedebris $x $y 7.5 15
      makedebris [expr $x+20] $y 7.5 17
      makedebris [expr $x+30] $y 7.5 18
      makedebris [expr $x+40] $y 7.5 21
      makedebris [expr $x+50] $y 7.5 23
    }
  } elseif [string first para [.canvas itemcget $id -tags]]==0 {
    set cords [.canvas coords $id]
    if [incr totaldead]>$sbthresh {
      incr smartbombs
      incr sbthresh 500
    }
    if ($shot) {
      incr shotkills
    } else {
      incr debriskills
    }
    deletepara $idtags
    set x [lindex $cords 0]
    set y [lindex $cords 1]
    makedebris $x $y 3.5 15
    makedebris $x [expr $y+1] 3.5 19
    makedebris $x [expr $y+2] 3.5 17
    makedebris $x [expr $y+3] 3.5 20
    makedebris $x [expr $y+4] 3.5 23
    makedebris $x [expr $y+5] 3.5 25
#    makedebris [expr $x-1] $y 3 15
#    makedebris [expr $x-1] [expr $y+1] 3 19
#    makedebris [expr $x-1] [expr $y+2] 3 17
#    makedebris [expr $x-1] [expr $y+3] 3 20
#    makedebris [expr $x-1] [expr $y+4] 3 23
#    makedebris [expr $x-1] [expr $y+5] 3 25
#    makedebris [expr $x+1] $y 3 15
#    makedebris [expr $x+1] [expr $y+1] 3 19
#    makedebris [expr $x+1] [expr $y+2] 3 17
#    makedebris [expr $x+1] [expr $y+3] 3 20
#    makedebris [expr $x+1] [expr $y+4] 3 23
#    makedebris [expr $x+1] [expr $y+5] 3 25
  }
}

proc gameover {} {
  global keybd shots planes paras debris canonx canony
  set y [expr $canony-30]
  .canvas delete canon
  .canvas delete canonbase
  for {set i 0} {$i<20} {incr i} {
    makedebris [expr $canonx+[getrand]] [expr $y+[getrand]] [getrand] [getrand]
  }
}

while {1} {
  global keybd shots planes paras debris
  set waiting 0
  after 20 {
    if $keybd(movecanonleft) {
      canonleft
    } elseif $keybd(movecanonright) {
      canonright
    }
    if $keybd(smartbomb) {
      if ($smartbombs&&$notdead) {
	foreach para $paras {
	  hitobject [lindex [.canvas find withtag $para] 0] 0
	}
	incr smartbombs -1
      }
      #the smartbomb key doesn't repeat
      set keybd(smartbomb) 0
    }
    if $notdead {
      if [incr shotcount]==$shotmod {
	shoot
	set shotcount 0
      }
    } else {
      set shotcount [expr $shotmod-1]
    }
    foreach plane $planes {
      moveplane $plane
    }
    foreach para $paras {
      movepara $para
    }
    foreach shot $shots {
      moveshot $shot
    }
    foreach bit $debris {
      movedebris $bit
    }
    if [incr objcount]>=$objmod {
      if [getrand]==1 {
	makeplane
	set objcount 0
      }
    }
    if (($missed>=20)&&$notdead) {
      gameover
      set notdead 0
      set missed 0
    }
    update
    if $restart {
      .canvas delete canon
      .canvas delete canonbase
      foreach plane $planes { deleteplane $plane }
      foreach para $paras { deletepara $para }
      foreach shot $shots { deleteshot $shot }
      foreach bit $debris { deletedebris $bit }
      set missed 0
      set totaldead 0
      set debriskills 0
      set shotkills 0
      set onplanekills 0
      set restart 0
      set notdead 1
      set sbthresh 500
      set smartbombs 1
      .canvas create oval [expr $canonx-10] [expr $canony-10] \
		    [expr $canonx+10] [expr $canony+10] \
		    -fill darkgrey -tag canonbase
      .canvas create line $canonx $canony \
	    [expr $canonx+int(30*sin($canonang))] \
	    [expr $canony+int(30*cos($canonang))] \
	    -width 3 -tag canon
    }
    set waiting 1
  }
  tkwait variable waiting
  if ($paused) { tkwait variable paused }
}