Artifact Content
Not logged in

Artifact 53b62ad7dac6c148902b40886c0c5ed7ac38d8af:


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