package require Tk 8.4
proc main {} {
catch {
# Android only
borg screenorientation landscape
bind all <Break> exitScript
bind . <<WillEnterBackground>> exitScript
update
}
catch {
# SDL2, screen scaling and joystick support
sdltk touchtranslate 0
catch {sdltk root 450 500}
sdltk vrmode 1
sdltk screensaver off
wm attributes . -fullscreen 1
bind . <<JoystickButtonDown>> {
if {%s == 4} {
# ignore
} elseif {!$::keyStatus(FIRE)} {
set ::keyStatus(FIRE) 1
}
}
bind . <<JoystickButtonUp>> {
if {%s == 4} {
event generate .c1 <Key-q>
} elseif {%s == 1 || %s == 2} {
event generate .c1 <Key-p>
} elseif {$::keyStatus(FIRE)} {
set ::keyStatus(FIRE) 0
}
}
bind . <<JoystickMotion>> {
if {%s == 1 || %s == 3} {
if {%x > 250} {
set ::keyStatus(RIGHT) 1
set ::keyStatus(LEFT) 0
} elseif {%x < -250} {
set ::keyStatus(RIGHT) 0
set ::keyStatus(LEFT) 1
} else {
set ::keyStatus(RIGHT) 0
set ::keyStatus(LEFT) 0
}
}
}
}
# Android camera
image create photo cam
catch {
borg camera open 0
borg camera parameters preview-size 640x480 frame-rate 10
after 1000 {borg camera start}
bind . <<ImageCapture>> {imgCapture %x}
}
wm protocol . WM_DELETE_WINDOW exitScript
. configure -background black
font create BigFont -family Arial -size -20 -weight bold
font create SmallFont -family Arial -size -10 -weight bold
buildUI
bindKeys
addTraces
loadGraphics
createStars
createShip
newGame
}
proc imgCapture {flag} {
if {!$flag} {
after cancel {borg camera start}
after 1000 {borg camera start}
}
if {![borg camera image cam]} {
return
}
}
proc newGame {} {
.c1 delete withtags "continue" "gameover"
initVars
nextLevel
openingScreen
}
proc openingScreen {} {
.c1 create text 225 130 -text "Play Tk-Bugz" -fill yellow -font BigFont \
-tag "play"
.c1 create text 225 170 -text "Quit" -fill yellow -font BigFont \
-tag "quit"
.c1 bind "play" <Enter> {.c1 itemconfigure "play" -fill red}
.c1 bind "play" <Leave> {.c1 itemconfigure "play" -fill yellow}
.c1 bind "play" <1> {doGame}
.c1 bind "quit" <Enter> {.c1 itemconfigure "quit" -fill red}
.c1 bind "quit" <Leave> {.c1 itemconfigure "quit" -fill yellow}
.c1 bind "quit" <1> {exitScript}
}
proc exitScript {} {
catch {sdltk screensaver on}
.c1 delete all
destroy .c1
exit
}
proc doGame {} {
.c1 delete "play"
.c1 delete "quit"
set ::global(alive) 1
gameLoop
}
proc addTraces {} {
trace variable ::global(level) w updateText
trace variable ::global(score) w updateText
trace variable ::global(ships) w updateText
trace variable ::global(fps) w updateText
}
proc initVars {} {
set ::global(frameCount) 0
set ::global(level) 0
set ::global(marchDir) 1
set ::global(offset) 0
set ::global(score) 0
set ::global(ships) 5
set ::global(fps) [format %6.2f 0]
}
proc loadGraphics {} {
set path [file dirname [info script]]
set ::img(shotShip) [image create photo -file [file join $path shot_ship.gif]]
set ::img(shotBug) [image create photo -file [file join $path shot_bug.gif]]
set ::img(bug) [image create photo -file [file join $path bug.gif]]
set ::img(ship) [image create photo -file [file join $path ship.gif]]
set ::img(exp) [image create photo -file [file join $path explosion.gif]]
}
proc createShip {} {
.c1 delete withtag "ship"
.c1 create image 225 480 -image $::img(ship) -tag "ship"
}
proc gameLoop {} {
set gameStartTime [clock clicks -milliseconds]
set fc 0
while {$::global(alive)} {
set frameStartTime [clock clicks -milliseconds]
set frameEndTime [expr {$frameStartTime + 33}]
nextFrame
incr fc
if {!($fc % 30)} {
set fps [expr {($fc / (($nowTime - $gameStartTime) * .001))}]
set ::global(fps) [format %6.2f $fps]
}
update
set nowTime [clock clicks -milliseconds]
while {$nowTime < $frameEndTime} {
set nowTime [clock clicks -milliseconds]
}
set ::global(frameCount) $fc
}
endGame
}
proc endGame {} {
.c1 create text 225 200 -font BigFont -fill yellow \
-text "Game Over" -tag "gameover"
.c1 create text 225 250 -font BigFont -fill yellow \
-text "Click to Continue" -tag "continue"
.c1 bind "continue" <Enter> {.c1 itemconfigure "continue" -fill red}
.c1 bind "continue" <Leave> {.c1 itemconfigure "continue" -fill yellow}
.c1 bind "continue" <1> newGame
}
proc nextFrame {} {
moveStars
moveBugs
moveShots
shipEvents
findCollisions
}
proc nextLevel {} {
.c1 delete withtags "bugshot" "shipshot" "bug"
array unset ::bugs
incr ::global(level)
createBugs
}
proc updateText {array elem op} {
switch -exact $elem {
"score" {
.c1 itemconfigure "score" -text [format "%6d" $::global(score)]
}
"level" {
.c1 itemconfigure "level" -text [format "%2d" $::global(level)]
}
"ships" {
.c1 itemconfigure "ships" -text [format "%2d" $::global(ships)]
}
"fps" {
.c1 itemconfigure "fps" -text $::global(fps)
}
}
}
proc findCollisions {} {
# --- see if the ship has shot down any bugs...
foreach shot [.c1 find withtag "shipshot"] {
foreach item [eval .c1 find overlapping [.c1 bbox $shot]] {
if {[string equal "bug" [.c1 gettag $item]]} {
set points [expr {$::bugs($item,points) + (50 * $::bugs($item,dive))}]
incr ::global(score) $points
set me2 [eval .c1 create image [.c1 coords $item] -image $::img(exp)]
set me1 [eval .c1 create text [.c1 coords $item] \
-font SmallFont -fill yellow -text $points]
.c1 delete $item $shot
after 200 [list .c1 delete $me2]
after 500 [list .c1 delete $me1]
break; # --- allow a single shot to only kill a single bug...
}
}
}
# --- see if the ship has been hit by a bug or a bug shot
foreach item [eval .c1 find overlapping [.c1 bbox "ship"]] {
set tag [.c1 gettag $item]
if {[string equal $tag "bug"] || [string equal $tag "bugshot"]} {
.c1 delete $item
incr ::global(ships) -1
if {$::global(ships) <= 0} {
set ::global(alive) 0
}
}
}
# --- if no more bugs, go to next level
if {![llength [.c1 find withtag "bug"]]} {
nextLevel
}
}
proc shipEvents {} {
foreach {xloc yloc} [.c1 coords "ship"] {break}
if {$::keyStatus(LEFT) && $xloc > 20} {
.c1 move "ship" -8 0
}
if {$::keyStatus(RIGHT) && $xloc < 430} {
.c1 move "ship" 8 0
}
if {$::keyStatus(FIRE) && [llength [.c1 find withtag "shipshot"]] < 4} {
set shot [.c1 create image $xloc [expr {$yloc - 10}] -image $::img(shotShip) -tag "shipshot"]
.c1 lower $shot "ship"
set ::keyStatus(FIRE) 0
}
}
proc moveStars {} {
foreach star [.c1 find withtag "star"] {
.c1 move $star 0 4
foreach {xlow ylow xhigh yhigh} [.c1 coords $star] {break}
if {$yhigh > 500} {
.c1 move $star 0 -500
}
}
}
proc moveShots {} {
foreach shot [.c1 find withtag "bugshot"] {
.c1 move $shot 0 12
foreach {xloc yloc} [.c1 coords $shot] {break}
if {$yloc > 500} {
.c1 delete $shot
}
}
foreach shot [.c1 find withtag "shipshot"] {
.c1 move $shot 0 -14
foreach {xloc yloc} [.c1 coords $shot] {break}
if {$yloc < 0} {
.c1 delete $shot
}
}
}
proc moveBugs {} {
set level $::global(level)
foreach {shipx shipy} [.c1 coords "ship"] {break}
foreach {xlow ylow xhigh yhigh} [.c1 bbox "bug"] {break}
if {$xlow < 10} {
set ::global(marchDir) 1
}
if {$xhigh > 440} {
set ::global(marchDir) -1
}
incr ::global(offset) $::global(marchDir)
set bugList [.c1 find withtag "bug"]
foreach bug $bugList {
foreach {xloc yloc} [.c1 coords $bug] {break}
# --- return bugs home from the top of the screen
if {$::bugs($bug,return)} {
if {$yloc >= $::bugs($bug,yhome)} {
set ::bugs($bug,ym) 0
set ::bugs($bug,return) 0
.c1 coords $bug [expr {$::bugs($bug,xhome) + $::global(offset)}] $::bugs($bug,yhome)
}
}
# --- handle diving bugs
if {$::bugs($bug,dive)} {
# --- allow diving bugs to "track" ship in top half of screen
if {$yloc < 250} {
set xspeed $::bugs($bug,xm)
if {$xloc < $shipx && $xspeed < 4} {
incr ::bugs($bug,xm)
} elseif {$xloc > $shipx && $xspeed > -4} {
incr ::bugs($bug,xm) -1
}
}
# --- progressively increase the speed of the diving bugs
if {$::global(frameCount) % 10 == 0} {
set yspeed $::bugs($bug,ym)
if {$yspeed < 10} {
incr yspeed
set ::bugs($bug,ym) $yspeed
}
}
# --- if a diving bug has reached the bottom of the screen,
# send it home...
if {$yloc > 500} {
set ::bugs($bug,dive) 0
set ::bugs($bug,return) 1
set ::bugs($bug,xm) 1
.c1 coords $bug [expr {$::bugs($bug,xhome) + $::global(offset)}] 0
}
}
# --- make bugs dive occasionally
if {[llength $bugList] > 8} {
set diveFactor [expr {int(rand() * 32767) % int(1000/$level)}]
if {!$diveFactor} {
set ::bugs($bug,dive) 1
}
} else {
set ::bugs($bug,dive) 1
}
# --- make bugs shoot occasionally
set shootFactor [expr {int(rand() * 32767) % (1000 - (900 * $::bugs($bug,dive)))}]
if {!$shootFactor} {
set shot [.c1 create image $xloc $yloc -image $::img(shotBug) -tag "bugshot"]
.c1 lower $shot "ship"
}
# --- move the bugs according to all of the above
if {!$::bugs($bug,dive)} {
.c1 move $bug [expr {$::bugs($bug,xm) * $::global(marchDir)}] $::bugs($bug,ym)
} else {
.c1 move $bug $::bugs($bug,xm) $::bugs($bug,ym)
}
}
}
proc createStars {} {
.c1 delete withtag "stars"
set i 1
while {$i <= 25} {
set r [expr {int(rand() * 155) + 100}]
set g [expr {int(rand() * 155) + 100}]
set b [expr {int(rand() * 155) + 100}]
set x [expr {int(rand() * 450)}]
set y [expr {int(rand() * 500)}]
.c1 create line $x $y $x [expr {$y + 2}] -fill [format "#%02x%02x%02x" $r $g $b] -tags "star"
incr i
}
}
proc createBugs {} {
for {set y 1} {$y <= 5} {incr y} {
for {set x 1} {$x <= 10} {incr x} {
set xloc [expr {$x * 30 + 50}]
set yloc [expr {$y * 25 + 50}]
set bug [.c1 create image $xloc $yloc -image $::img(bug) -tags "bug"]
set ::bugs($bug,dive) 0
set ::bugs($bug,return) 0
set ::bugs($bug,xm) 1
set ::bugs($bug,xhome) $xloc
set ::bugs($bug,yhome) $yloc
set ::bugs($bug,ym) 0
set ::bugs($bug,points) [expr {60 - ($y * 10)}]
}
}
}
proc buildUI {} {
wm title . "Tk-Bugz"
canvas .c1 -width 450 -height 500 -bg black -highlightthickness 0 -borderwidth 0
.c1 create text 10 10 -anchor nw -text "Score:" -fill white -font SmallFont
.c1 create text 60 10 -anchor nw -tag "score" -fill white -font SmallFont
.c1 create text 200 10 -anchor nw -text "Level: " -fill white -font SmallFont
.c1 create text 250 10 -anchor nw -tag "level" -fill white -font SmallFont
.c1 create text 375 10 -anchor nw -text "Ships: " -fill white -font SmallFont
.c1 create text 425 10 -anchor nw -tag "ships" -fill white -font SmallFont
.c1 create text 10 495 -anchor sw -tag "fps" -fill white -font SmallFont
.c1 create image 225 250 -anchor center -image cam -tags "cam"
.c1 lower "cam"
pack .c1 -expand 1
bind .c1 <KeyPress-z> {set ::ship(xm) -8}
bind .c1 <KeyPress-x> {set ::ship(xm) 8}
focus .c1
}
proc bindKeys {} {
set LEFT_PRESS "<KeyPress-Left>"
set LEFT_RELEASE "<KeyRelease-Left>"
set RIGHT_PRESS "<KeyPress-Right>"
set RIGHT_RELEASE "<KeyRelease-Right>"
set FIRE_PRESS "<KeyPress-Control_L>"
set FIRE_RELEASE "<KeyRelease-Control_L>"
set ::keyStatus(LEFT) 0
set ::keyStatus(RIGHT) 0
set ::keyStatus(FIRE) 0
bind .c1 $LEFT_PRESS {set ::keyStatus(LEFT) 1}
bind .c1 $RIGHT_PRESS {set ::keyStatus(RIGHT) 1}
bind .c1 $FIRE_PRESS {set ::keyStatus(FIRE) 1}
bind .c1 $LEFT_RELEASE {set ::keyStatus(LEFT) 0}
bind .c1 $RIGHT_RELEASE {set ::keyStatus(RIGHT) 0}
bind .c1 $FIRE_RELEASE {set ::keyStatus(FIRE) 0}
bind .c1 <Key-p> {
if {[.c1 find withtag "play"] ne ""} {
doGame
} elseif {[.c1 find withtag "continue"] ne ""} {
newGame
}
}
bind .c1 <Key-q> {
if {[.c1 find withtag "quit"] ne ""} {
exitScript
} elseif {[.c1 find withtag "continue"] ne ""} {
exitScript
} else {
set ::global(alive) 0
}
}
}
main