I played around with the program a bit. The SUB 'FadePal' seems to work now.
Looks a little different than playing the original in DOS.
I haven't found a solution for the ADLIB sound.
So I changed the original to play all the sounds in a row with a 2 second pause.
Run the program in the DOSBOX and record the sound in Windows at the same time.
Then everything is broken down into small sounds (OGG) and added back to the top of the game.
In the ZIP file I have added the sounds and the include files.
QB-Invader-Sound-Include.7z (Size: 2.25 MB / Downloads: 72)
Code: (Select All)
'Program : QB Invaders
'Version : Ver 1.1 for Qbasic
'Type : Shareware
'Revised : 4/29/97
'Author : Tim Truman
'Address : NET -TimTruman@aol.com, AOL-TimTruman
'
'Copyright(c) 1997 Nocturnal Creations
'
'Feel free to use any routines or code found this program in your own
'as long as you credit Tim Truman as the contributer. Graphics and sounds
'are property of Tim Truman and may not be used.
'
'I just ask that you do not distribute this source code program or
'modify and recompile the program for reasons other than personal use.
'
'You are not obligated... however if you like QB Invaders, or plan to use
'code from it, please register by sending a small amount of money to :
'Tim Truman
'110 Homestead Ave.
'Springfield, MA 01151
'USA
'
'-------------------
'Info & Requirements
'-------------------
'Graphics for this program were made using SPRITE 2.0.
'Adlib sound effects were made using FX.
'Requires a VGA.
'Recommend 386 or higher processor, and a sound card.
'
'-------------------
'Running QBInvaders * Important read this ! *
'-------------------
'Playing under DOS:
' Type qbasic /run qbinvade.
'
'Playing under WIN 3.1 and WIN 95 :
' Use the File Manager and double click on the MSDOS shortcut.
' Why?
' Some key combinations are reserved to windows like ALT-SPACE
' combo used by this program. Using the MSDOS shortcut realeases
' this key combo for Qbasic, preventing program errors.
'
'-------------------
' Program options
'-------------------
' (1) Change the 'UseFX' variable to false for PC speaker sounds.
' (2) Change the 'Hard' variable to true for harder gameplay.
' (3) Two graphics set are available.
DefInt A-Z
Type hues ' define the type for hues
red As Integer ' red component
grn As Integer ' green component
blu As Integer ' blue component
End Type
Type sprite
x As Integer 'current alien location
y As Integer '
lx As Integer 'last alien location
ly As Integer '
w As Integer 'width of image
h As Integer 'height of image
dir As Integer 'referenced for movement
health As Integer 'aliens well being
sseg As Integer 'segment of alien char
tile As Integer 'offset to frame
ltile As Integer 'for erase
hit As Integer 'check for a hit before moving
End Type
Type highscores 'type for highscores
rank As String * 3 'rank
dat As String * 8 'date
nam As String * 25 'name
lines As String * 4 'lines
score As String * 6 'score
End Type
DECLARE SUB clearbuffer ()
DECLARE SUB DoAliens ()
DECLARE SUB DoAlienBombs ()
DECLARE SUB DoCollisions ()
DECLARE SUB DocommandShip ()
DECLARE SUB EndToDos ()
DECLARE SUB DoHighScores ()
DECLARE SUB Dolevel ()
DECLARE SUB DoScore (points)
DECLARE SUB DoGunShot ()
DECLARE SUB DoGunshot2 ()
DECLARE SUB DoGunner ()
DECLARE SUB DoGameEnd ()
DECLARE SUB FadePal (fc%, lc%, level%, mode%)
DECLARE SUB GetReady ()
DECLARE SUB InitGameStart ()
DECLARE SUB Initlevel ()
DECLARE SUB Intro ()
DECLARE SUB Mouse (argument)
DECLARE SUB p5x7font (x, y, text$, colour)
DECLARE SUB playsfx (fx&)
DECLARE SUB PalRegInfo (reg, red, grn, blu, mode)
DECLARE SUB Pfont (text$, x, y, colour)
DECLARE SUB ShowHighScores (score() AS highscores, mode)
DECLARE SUB soundfx (fx)
DECLARE SUB stay (Millisecs!)
DECLARE SUB TitleScreen ()
DECLARE FUNCTION CheckFiles ()
DECLARE FUNCTION DoExplode (x, y)
DECLARE FUNCTION DropFileList (filename$)
DECLARE FUNCTION Fileexists (filename$)
DECLARE FUNCTION GetFileName$ (filespec$)
DECLARE FUNCTION InputText$ (xcur%, ycur%, length%)
DECLARE FUNCTION returnevent ()
DECLARE FUNCTION TimeIsUp (n, tsecs!)
'mapped key values
Const up = -72
Const Down = -80
Const Left = -75
Const Right = -77
Const Eight = 56
Const Two = 50
Const Enter = 13
Const Esc = 27
Const space = 32
Const letterc = 99
'mouse
Const leftclick = 1
Const rightclick = 2
'other
Const true = 1
Const false = 0
Common Shared Maxx, Maxy, event, font(), pal() As hues
Common Shared sprites(), elmPerSpr, NewAlienFrame, spriteheight, spritewidth
Common Shared alien() As sprite, numberofaliens, AliensInPLay, movealiens
Common Shared AliensPerCol, AliensPerRow, alienvelx, AlienVely, TimeToStep!
Common Shared AlienStartX, AlienStartY, AlienStepX, AlienStepY
Common Shared abomb() As sprite, Numberofbombs, AbombInterval!, Abombvel
Common Shared gunner As sprite, gunnerlives
Common Shared gunner2 As sprite, gunnerlives2
Common Shared gunnerMaxx, GunnerMinx, numplayers, gunnervel
Common Shared gunshot As sprite, GunShotVel
Common Shared cship As sprite, headisup
Common Shared shield() As sprite, NumberofShields
Common Shared Barrier() As sprite
Common Shared level, gamescore&, UseFX, Hard
Cls
'Dim Shared c$(8) 'FM register information for 9 channels
'c$(0) = "&hB0&h20&h23&h40&h43&h60&h63&h80&h83&hA0&HBD&HC0&HE0&HE3&hB0"
'c$(1) = "&hB1&h21&h24&h41&h44&h61&h64&h81&h84&hA1&HBD&HC1&HE1&HE4&hB1"
'c$(2) = "&hB2&h22&h25&h42&h45&h62&h65&h82&h85&hA2&HBD&HC2&HE2&HE5&hB2"
'c$(3) = "&hB3&h28&h2B&h48&h4B&h68&h6B&h88&h8B&hA3&HBD&HC3&HE8&HEB&hB3"
'c$(4) = "&hB4&h29&h2C&h49&h4C&h69&h6C&h89&h8C&hA4&HBD&HC4&HE9&HEC&hB4"
'c$(5) = "&hB5&h2A&h2D&h4A&h4D&h6A&h6D&h8A&h8D&hA5&HBD&HC5&HEA&HED&hB5"
'c$(6) = "&hB6&h30&h33&h50&h53&h70&h73&h90&h93&hA6&HBD&HC6&HF0&HF3&hB6"
'c$(7) = "&hB7&h31&h34&h51&h54&h71&h74&h91&h94&hA7&HBD&HC7&HF1&HF4&hB7"
'c$(8) = "&hB8&h32&h35&h52&h55&h72&h75&h92&h95&hA8&HBD&HC8&HF2&HF5&hB8"
'Dim Shared sfx$(25) 'dim array to hold 26 sounds
'Open ".\qbinvade.sfx" For Input As #1 'open the .SFX file
'For sfxnum% = 0 To 25 'first to last
'Input #1, sfx$(sfxnum%) 'load sound into string
'Next 'next sound
'Close #1 'close the file
Common Shared sound1&, sound2&, sound3&, sound4&, sound5&, sound6&, sound7&, sound8&, sound9&
'Load Sound neu ============================
Dim buffer As String: buffer = LoadSoundData1$
sound1& = _SndOpen(buffer, "memory")
buffer = LoadSoundData1$
sound1 = _SndOpen(buffer, "memory")
buffer = LoadSoundData2$
sound2& = _SndOpen(buffer, "memory")
buffer = LoadSoundData3$
sound3& = _SndOpen(buffer, "memory")
buffer = LoadSoundData4$
sound4& = _SndOpen(buffer, "memory")
buffer = LoadSoundData5$
sound5& = _SndOpen(buffer, "memory")
buffer = LoadSoundData6$
sound6& = _SndOpen(buffer, "memory")
buffer = LoadSoundData7$
sound7& = _SndOpen(buffer, "memory")
buffer = LoadSoundData8$
sound8& = _SndOpen(buffer, "memory")
buffer = LoadSoundData9$
sound9& = _SndOpen(buffer, "memory")
buffer = LoadSoundData10$
sound10& = _SndOpen(buffer, "memory")
Screen 13 'set video mode
_FullScreen
Maxx = 319 'store screen size
Maxy = 199 'ditto
Out &H60, &HF3 'inform keyboard port
stay (500) 'let hardware settle
Out &H60, 0 'fast typematic rate with min delay
bucket = TimeIsUp(7, -1) 'set up timers
stay (1) 'initilaize delay routine
ReDim pal(255) As hues 'array for palette
Def Seg = VarSeg(pal(0)) 'point to it
BLoad ".\default.pal", 0 'load it
Out &H3C8, 0 'inform VGA
For c = 0 To 255 'entire palette
Out &H3C9, pal(c).red 'send red component
Out &H3C9, pal(c).grn 'send green component
Out &H3C9, pal(c).blu 'send blue component
Next 'next attribute
Dim font(127, 4, 6) 'DIM array for fonts
Def Seg = VarSeg(font(0, 0, 0)) 'Point to it
BLoad ".\qbinvade.fnt", 0 'Load 'em in
' Unremark image file to load. ********** Choose graphics. *************
'filename$ = "atari.spr"
filename$ = ".\qbinvade.spr"
Cls
Filesize& = 12877 'File size
bytes = (Filesize& - 7) \ 2 - 1 'BSAVE & BLOAD use 7 bytes
Dim sprites(bytes) 'dim the sprite array
Def Seg = VarSeg(sprites(0)) 'point to it
BLoad filename$, 0 'load the sprite file
spritewidth = sprites(0) \ 8 'get image width
spriteheight = sprites(1) 'get image height
elmPerSpr = ((spritewidth * spriteheight) \ 2) + 3 ' elements in one image
Randomize Timer 'seed randomizer
UseFX = true 'true 'set to false for PC speaker
Hard = false 'set to true for harder gameplay
TitleScreen 'start intro
InitGameStart 'init game varaibles/screen
Do 'level loop
level = level + 1 'increment level
Initlevel 'display graphics
GetReady 'tell user game is ready
Do 'game loop
event = returnevent 'get events
If event = Esc Then EndToDos 'user wants out
DoAlienBombs
DoAliens
If TimeIsUp(3, 15) Then cship.health = true 'time appearance of command ship
DocommandShip
DoCollisions
DoGunner
DoGunShot
Loop Until AliensInPLay = 0
Loop
'data to reconstruct qbinvader.scr in the event it is erased
Data 1,4/11/97,Timothy Truman,2000
Data 2,4/11/97,John Denesha,2000
Data 3,4/11/97,David Pastore,2000
Data 4,4/11/97,John Matias,2000
Data 5,4/11/97,Mike Eberts,1500
Data 6,4/11/97,Bonnie Soffan,1500
Data 7,4/11/97,Patty Effilo,1500
Data 8,4/11/97,Kelsi Donahue,1450
Data 9,4/11/97,Sabrina McIntosh,1450
Data 10,4/11/97,Colleen Wise,1450
Data 11,4/11/97,Michelle Poules,1300
Data 12,4/11/97,Dominic Amato,1300
Data 13,4/11/97,Bobby Barkett,1300
Data 14,4/11/97,Tracy Truman,1200
Data 15,4/11/97,Chris Hitas,1200
' Visit this FTP for my latest programs and utilities :
' members.aol.com/TimTruman
Sub clearbuffer 'clear keyboard buffer
Def Seg = &H40 'point to low memory
Poke &H1A, Peek(&H1C) 'point head to tail
End Sub
Sub DoAlienBombs
For ab = 1 To Numberofbombs 'do alien bombs
If abomb(ab).health = false Then 'new one set up
If TimeIsUp(2, AbombInterval!) Then 'time has passed
For a = 1 To numberofaliens
If alien(a).health Then 'wide scan for gunner
If alien(a).x < gunner.x Or alien(a).x > gunner.x - gunner.w Then
AlienUnder = false 'assume alien under
For m = 1 To AliensPerCol 'next row down
lookunder = (a + (AliensPerRow * m)) 'calc down one
If lookunder <= numberofaliens Then 'Alien there ?
If alien(lookunder).health = 1 Then AlienUnder = true 'This one can't fire
End If
Next
If AlienUnder = false Then
maybe = Rnd * 12 'this one is possible
If maybe > 1 And maybe < 6 Then 'use 'em
abomb(ab).health = alien(a).health 'set up Bomp
abomb(ab).x = alien(a).x + alien(a).w / 2 'ditto
abomb(ab).y = alien(a).y + alien(a).h 'ditto
abomb(ab).lx = abomb(ab).x 'ditto
abomb(ab).ly = abomb(ab).y 'ditto
Exit For 'Outa here
End If
'narrow scan
If alien(a).x >= gunner.x And alien(a).x < gunner.x + gunner.w Then
If maybe <> 0 Then 'use 'em
abomb(ab).health = alien(a).health 'set up Bomp
abomb(ab).x = alien(a).x + alien(a).w / 2 'ditto
abomb(ab).y = alien(a).y + alien(a).h 'ditto
abomb(ab).lx = abomb(ab).x 'ditto
abomb(ab).ly = abomb(ab).y 'ditto
Exit For 'outa here
End If
End If
End If
End If
End If
Next 'check next alien
End If
ElseIf abomb(ab).health = true Then 'animate it
Line (abomb(ab).lx, abomb(ab).ly)-(abomb(ab).lx, abomb(ab).ly + abomb(ab).h), 0
abomb(ab).y = abomb(ab).y + Abombvel + Hard 'adjust bomb y
If abomb(ab).y > Maxy Then 'it's off screen
abomb(ab).health = 0 'Kill it
Else 'still visible
Line (abomb(ab).x, abomb(ab).y)-(abomb(ab).x, abomb(ab).y + abomb(ab).h), 138
abomb(ab).lx = abomb(ab).x: abomb(ab).ly = abomb(ab).y 'for erase
_Delay .005
End If
End If
Next
End Sub
Sub DoAliens
Static dir, ctr1
If TimeIsUp(1, TimeToStep!) Then 'Move aliens ?
For a = 1 To numberofaliens 'look for live aliens
If alien(a).health Then 'got one
CountEm = CountEm + 1 'count em in
If dir = 1 Then 'going left
alien(a).x = alien(a).x - alienvelx 'adjust x position
If alien(a).x <= alienvelx Then dflag = true 'drop em ?
If dflag And CountEm = AliensInPLay Then 'wait for every x adjust
For b = 1 To numberofaliens 'drop em all at once
If alien(b).health Then alien(b).y = alien(b).y + AlienVely
Next 'next one
dflag = false: dir = 0 'did drop; change direction
End If
ElseIf dir = 0 Then 'going right
alien(a).x = alien(a).x + alienvelx 'adjust x position
If alien(a).x > Maxx - alien(a).w - alienvelx Then dflag = true ' drop ?
If dflag And CountEm = AliensInPLay Then 'wait for every x adjust
For b = 1 To numberofaliens 'drop em all at once
If alien(b).health Then alien(b).y = alien(b).y + AlienVely
Next 'next
dflag = false: dir = 1 'did drop; change direction
End If
End If
End If
Next
CountEm = 0 'reset
movealiens = true 'update screen
End If
Do: Loop Until (Inp(&H3DA) And 8) 'wait for VGA retrace
If movealiens = true Then
For a = numberofaliens To 1 Step -1 'start at bot
If alien(a).health And (alien(a).hit = false) Then 'got a live one
Put (alien(a).lx, alien(a).ly), sprites(elmPerSpr * 20), PSet 'erase last
alien(a).tile = (alien(a).tile + elmPerSpr) Mod NewAlienFrame 'calc ani frame
alien(a).tile = alien(a).tile + alien(a).sseg 'calc alien
Put (alien(a).x, alien(a).y), sprites(alien(a).tile), PSet 'Put it
alien(a).lx = alien(a).x: alien(a).ly = alien(a).y 'for erase
alien(a).ltile = alien(a).tile 'ditto
End If
Next
If UseFX = 1 Then
ctr1 = (ctr1 + 1) Mod 2
If ctr1 Then playsfx (sound2&) Else playsfx (sound8&)
Else
soundfx (1)
End If
movealiens = false 'done
End If
End Sub
Sub DoCollisions
'--* do collisions
'--* check for collisions between aliens and gunshots using a bounding box
For b = 1 To numberofaliens
If alien(b).health = 1 And gunshot.health = 1 Then
If gunshot.y >= alien(b).y And gunshot.y <= alien(b).y + alien(b).h Then
If gunshot.x >= alien(b).x And gunshot.x <= alien(b).x + alien(b).w Then
Put (alien(b).lx, alien(b).ly), sprites(alien(b).ltile) 'erase old
Line (gunshot.lx, gunshot.ly)-(gunshot.lx, gunshot.ly + gunshot.h), 0
'soundfx (4)
If UseFX = 1 Then
playsfx (sound4&)
Else
soundfx (4)
End If
alien(b).health = 0
gunshot.health = 0
AliensInPLay = AliensInPLay - 1 'one less alien
row = ((b - 1) \ (AliensPerRow)) + 1
points = 5 * Abs(row - (AliensPerRow + 1))
DoScore (points)
Exit For
End If
End If
End If
Next
'--* check for collisions between alien bombs and barriers
For ab = 1 To Numberofbombs
For b = 1 To 2
If abomb(ab).health Then
If abomb(ab).y > Barrier(b).y And abomb(ab).y < Barrier(b).y + spriteheight Then
If abomb(ab).x >= Barrier(b).x And abomb(ab).x <= Barrier(b).x + spritewidth Then
abomb(ab).health = 0
Line (abomb(ab).lx, abomb(ab).ly)-(abomb(ab).lx, abomb(ab).ly + abomb(ab).h), 0
End If
End If
End If
Next
Next
'--* check for collisions between alien bombs and gunner
For ab = 1 To Numberofbombs
If abomb(ab).health = 1 Then
If abomb(ab).x > (gunner.x + 4) And abomb(ab).x < (gunner.x + gunner.w - 4) Then
If abomb(ab).y >= gunner.y And abomb(ab).y <= gunner.y Then
abomb(ab).health = 0
gunner.health = 0
Line (abomb(ab).lx, abomb(ab).ly)-(abomb(ab).lx, abomb(ab).ly + abomb(ab).h), 0
End If
End If
End If
Next
'--* bombs against gunshots
For ab = 1 To Numberofbombs
If abomb(ab).health = 1 And gunshot.health Then
If abomb(ab).x = gunshot.x Then
If abomb(ab).y >= gunshot.y And abomb(ab).y <= gunshot.y + gunshot.h Then
abomb(ab).health = 0
gunshot.health = 0
Line (abomb(ab).lx, abomb(ab).ly)-(abomb(ab).lx, abomb(ab).ly + abomb(ab).h), 5
Line (gunshot.x, gunshot.y)-(gunshot.x, gunshot.y + gunshot.h), 0, BF 'ditto
'_Delay 1
If UseFX = true Then
playsfx (sound4&)
Else
soundfx (3)
End If
End If
End If
End If
Next
'--* alienbombs against shields
For s = 1 To NumberofShields
For ab = 1 To Numberofbombs
If abomb(ab).x > shield(s).x And abomb(ab).x < shield(s).x + shield(s).w Then
If abomb(ab).y >= shield(s).y And abomb(ab).y <= shield(s).y + shield(s).h Then
If Point(abomb(ab).x, abomb(ab).y + abomb(ab).h + 1) > 0 Then
Line (abomb(ab).x, abomb(ab).y)-(abomb(ab).x, abomb(ab).y + abomb(ab).h + 1), 0
PSet (abomb(ab).x + (Rnd * -2), abomb(ab).y + abomb(ab).h + 1), 0
PSet (abomb(ab).x + (Rnd * 2), abomb(ab).y + abomb(ab).h + 1), 0
abomb(ab).health = 0
End If
End If
End If
Next
Next
'--* gunshots against shields
For s = 1 To NumberofShields
If gunshot.x > shield(s).x And gunshot.x < shield(s).x + shield(s).w Then
If gunshot.y >= shield(s).y And gunshot.y <= shield(s).y + shield(s).h Then
If Point(gunshot.x, gunshot.y - 1) > 0 Then
Line (gunshot.x, gunshot.y - 1)-(gunshot.x, gunshot.y + gunshot.h), 0
gunshot.health = 0
End If
End If
End If
Next
'--* gunshots against command ship
If cship.health And gunshot.health Then
If gunshot.y < cship.y + spriteheight Then
If gunshot.x > cship.x And gunshot.x < cship.x + spritewidth Then
If headisup Then
gunnerlives = gunnerlives + 1
If UseFX = true Then
playsfx (sound7&)
Else
soundfx (7)
End If
Else
If UseFX = true Then
playsfx (sound6&)
Else
soundfx (6)
End If
End If
cship.health = 0
gunshot.health = 0
Line (gunshot.x, gunshot.y)-(gunshot.x, gunshot.y + gunshot.h), 0, BF 'ditto
'_Delay 1
DoScore (50)
End If
End If
End If
For a = 1 To numberofaliens
If alien(a).y + alien(a).h >= gunner.y Then
If UseFX = true Then
playsfx (sound9&)
Else
soundfx (5)
End If
clearbuffer
Do: Loop Until returnevent
DoGameEnd
End If
Next
End Sub
Sub DocommandShip
Static initialize, startframe, xstart, dir, frame, framedir, counter
If cship.health Then
If Not initialize Then
startframe = (24 * elmPerSpr) 'calc start frame
cship.x = 300 'set start coridinates
cship.y = 1 'ditto
For xerase = 1 To 300 Step 20 'clear top of screen
Put (xerase, 1), sprites(20 * elmPerSpr), PSet
Next
' soundfx (8) 'make command ship noise
If UseFX = true Then
playsfx (sound3&)
Else
soundfx (8)
End If
initialize = Not initialize 'don't do this again
End If
_Delay .005
If TimeIsUp(5, 3) Then 'soundfx (8) 'time sound effect
If UseFX = true Then
playsfx (sound3&)
Else
soundfx (8)
End If
End If
Put (cship.lx, cship.y), sprites(20 * elmPerSpr), PSet 'clear spot
Put (cship.x, cship.y), sprites(startframe + (frame * elmPerSpr)), PSet
If framedir = 0 Then 'add to last frame
If TimeIsUp(4, 1.1) Then frame = (frame + 1) Mod 6 'time frames
If frame = 5 Then 'extra life hitting this frame
headisup = true 'raise flag
framedir = 1 'reverse frame direction
End If
Else 'subtract from last frame
If TimeIsUp(4, 1.1) Then
frame = (frame - 1) 'time frames
headisup = false 'drop flag
End If
If frame = 0 Then framedir = 0 'reverse frame direction
End If
cship.lx = cship.x 'save for erase
counter = (counter + 1) Mod 3 'slow down ship movement
If counter = 2 Then cship.x = cship.x - 1 'move ship
If cship.x <= 1 Then cship.health = false 'ship reached left limit
ElseIf cship.health = false Then 'ship has gone off screen
If initialize Then
Put (cship.x, 1), sprites(20 * elmPerSpr), PSet 'remove ship
bitbucket = TimeIsUp(3, 0) 'reset timers
bitbucket = TimeIsUp(4, 0) 'ditto
bitbucket = TimeIsUp(5, 0) 'ditto
initialize = Not initialize 'to re-initialize ship
framedir = 0 'reset frame direction
DoScore (0) 'redraw score and lives
End If
End If
End Sub
Function DoExplode (x, y)
Static frame
ExplodeFrame = elmPerSpr * 17 'point to Explosion frames
DoExplode = false
Put (x, y), sprites(ExplodeFrame + (frame * elmPerSpr)), PSet ' dislplay it
If TimeIsUp(3, .4) Then 'time each frame
Put (x, y), sprites(ExplodeFrame + ((frame + 1) * elmPerSpr)), PSet ' dislplay it
frame = (frame + 1) Mod 3 'calc next frame
If frame = 0 Then DoExplode = true 'Did all frames
End If
End Function
Sub DoGameEnd
FadePal 16, 255, 60, 1
p5x7font 125, 90, "Game Over", 30
'Pfont "Game Over", 125, 90, 90
'playsfx (sfx$(10))
FadePal 16, 255, 60, 0
If UseFX = true Then 'make hit noise
playsfx (sound9&)
Else
soundfx (9)
End If
_Delay .005
Do: Loop Until returnevent
DoHighScores
'CHAIN "qbinvade.exe"
End
End Sub
Sub DoGunner
If gunner.health Then
'kbyte3 = _KeyHit
Def Seg = &H0 'point to low memory
kbyte1 = Peek(&H417) 'get keyboard byte status
kbyte2 = Peek(&H418) 'ditto
'If kbyte3 = 19712 Then
If _KeyDown(19712) Then
gunner.x = gunner.x + gunnervel 'move gunner
End If
If (kbyte1 And &H4) Then 'left ctrl key
gunner.x = gunner.x + gunnervel 'move gunner 'check Ctrl key
End If
'If kbyte3 = 19200 Then
If _KeyDown(19200) Then
gunner.x = gunner.x - gunnervel 'move gunner
End If
If (kbyte1 And &H8) Then 'alt key
gunner.x = gunner.x - gunnervel 'move gunner
End If
If gunner.x > gunnerMaxx Then gunner.x = gunnerMaxx 'keep gunner in bounds
If gunner.x < GunnerMinx Then gunner.x = GunnerMinx 'ditto
If gunner.x <> gunner.lx Then 'gunner moved ?
Put (gunner.lx, gunner.ly), sprites(gunner.ltile) 'erase old
gunner.tile = ((gunner.tile + elmPerSpr) Mod NewAlienFrame) + gunner.sseg
Put (gunner.x, gunner.y), sprites(gunner.tile), PSet 'draw new
gunner.lx = gunner.x: gunner.ly = gunner.y 'for erase
gunner.ltile = gunner.tile 'ditto
End If
Else 'gunner got hit
If UseFX = true Then 'make hit noise
playsfx (sound6&)
Else
soundfx (2)
End If
Do
clearbuffer 'clear key buffer
If DoExplode(gunner.x, gunner.y) Then 'show all frames ?
Do: clearbuffer: Loop Until TimeIsUp(3, .7) 'wait a bit so user can get ready
gunnerlives = gunnerlives - 1 'less one gun
DoScore (0) 'redraw gun count
If gunnerlives = 0 Then DoGameEnd 'any more guns ?
For ab = 1 To Numberofbombs 'yes, then reset alien bombs
abomb(ab).health = 0 'kill bomb and remove it from screen
Line (abomb(ab).x, abomb(ab).y)-(abomb(ab).x, abomb(ab).y + abomb(ab).h), 0
Next 'next alien bomb
gunner.health = 1 'reset gunner health
Put (gunner.x, gunner.y), sprites(gunner.tile), PSet 'put on screen
End If
Loop Until gunner.health = 1 ' all done
End If
End Sub
Sub DoGunShot
Static colour
If gunshot.health = false Then 'Do gun shot
If event = space Then 'fire shot ?
gunshot.x = gunner.x + (gunner.w / 2) 'calc pos
gunshot.y = gunner.y - 1
gunshot.health = 1 'give it life
gunshot.lx = gunner.x 'for erase
gunshot.ly = gunner.y 'ditto
If UseFX Then playsfx (sound1&)
End If
ElseIf gunshot.health = true Then 'animate it
PSet (gunshot.lx, gunshot.ly), 0 'erase last
Line -(gunshot.lx, gunshot.ly + gunshot.h), 0, BF 'ditto
gunshot.y = gunshot.y - GunShotVel 'move shot
If cship.health Then
If gunshot.y < 1 Then gunshot.health = 0 'it's off screen
Else
If gunshot.y < spriteheight + 1 Then gunshot.health = 0
End If
If gunshot.health Then
colour = ((colour + 1) Mod 16) + 48
PSet (gunshot.x, gunshot.y), 0 'draw new
Line -(gunshot.x, gunshot.y + gunshot.h), colour 'ditto
gunshot.lx = gunshot.x: gunshot.ly = gunshot.y 'for erase
_Delay .005
End If
End If
End Sub
Sub DoHighScores
fc = 199
Dim score(1 To 16) As highscores
filespec$ = "qbvaders.scr"
Open filespec$ For Random As #1 Len = 46 'open high score file
For n = 1 To 15 'first to last
Get #1, n, score(n) 'load it in
Next n 'next entry
Close #1 'close the file
If Val(score(1).score) = 0 Then 'did file exist
Open filespec$ For Random As #1 Len = 46 'create file
For n = 1 To 15 'first to last
Read a$, b$, c$, d$ 'read in data
score(n).rank = a$ 'store it
score(n).dat = b$ 'ditto
score(n).nam = c$ 'ditto
score(n).score = d$ 'ditto
Put #1, n, score(n) 'write it
Next n 'next entry
Close #1 'close file
End If
Temp$ = LTrim$(Str$(gamescore&)) 'convert to clean string
addpad = 6 - Len(Temp$) 'calc padding
gamescor$ = Temp$ + String$(addpad, 32) 'add it
For rank = 1 To 15 'find players rank
If gamescore& > Val(score(rank).score) Then 'make the list ?
madelist = true 'setflag
For bump = 14 To rank Step -1 'sort it
score(bump + 1).dat = score(bump).dat 'bump ahead
score(bump + 1).nam = score(bump).nam 'ditto
score(bump + 1).score = score(bump).score 'ditto
Next 'bump next
month$ = Mid$(Date$, 1, 2) 'get month
day$ = Mid$(Date$, 4, 2) 'get day
year$ = Mid$(Date$, 9, 2) 'get year
format$ = month$ + "/" + day$ + "/" + year$ 'format the date
score(rank).dat = format$ 'store it
score(rank).nam = Space$(14) 'blank name
score(rank).score = gamescor$ 'store gamescore
ShowHighScores score(), 1 'print the list
y = (rank * 10) + 26 'calc y
score(rank).nam = InputText$(93 + 8, y, 199) 'enter name
Open filespec$ For Random As #1 Len = 46 'open file to save
For n = 1 To 15 'first to last
Put #1, n, score(n) 'write entry
Next 'next entry
Close #1 'close file
Exit For 'all done
End If
Next
If madelist = false Then ShowHighScores score(), 0
End Sub
Sub Dolevel
Select Case level
Case 1 To 5
AlienStartY = (level * 7) + 20
alienvelx = 1
TimeToStep! = .5
Case 6 To 11
AlienStartY = 18
alienvelx = (level - 6) + 1
TimeToStep! = .5
Case 12
AlienStartY = 21
alienvelx = alienvelx - 2
Case 13 To 17
AlienStartY = ((level - 14) * 7) + 20
alienvelx = ((level - 14) + 1)
TimeToStep! = .5
Case 18 To 24
AlienStartY = ((level - 18) * 7) + 20
alienvelx = ((level - 18) + 2)
TimeToStep! = .5
Case 25
AlienStartY = ((level - 25) * 7) + 20
alienvelx = 7
Case 26
AlienStartY = ((level - 26) * 7) + 20
alienvelx = 1
TimeToStep! = .5
level = 1
End Select
End Sub
Sub DoScore (points)
Static lgunnerlives, lTimeToStep!
Select Case AliensInPLay
Case 1: TimeToStep! = .01: If level = 25 Then TimeToStep! = 0!
Case 4: TimeToStep! = .09
Case 5 To 8: TimeToStep! = .15
Case 9 To 22: TimeToStep! = .25
Case 23 To 42: TimeToStep! = .5
End Select
If lTimeToStep! <> TimeToStep! Then
Select Case AliensInPLay
Case 1: alienvelx = alienvelx + 4
Case 4: alienvelx = alienvelx + 1
Case 9 To 22: alienvelx = alienvelx + 1
End Select
End If
lTimeToStep! = TimeToStep!
startframe = (30 * elmPerSpr) 'point to start of score frames
xscore = 1: yscore = 1
xstep = 20
gamescore& = gamescore& + points
If cship.health = false Then
onedigit = (gamescore& \ 1) Mod 10
tendigit = (gamescore& \ 10) Mod 10
hdigit = (gamescore& \ 100) Mod 10
tdigit = (gamescore& \ 1000) Mod 10
ttdigit = (gamescore& \ 10000) Mod 10
Put (xscore, yscore), sprites(startframe + (ttdigit * elmPerSpr)), PSet
Put (xscore + xstep, yscore), sprites(startframe + (tdigit * elmPerSpr)), PSet
Put (xscore + (xstep * 2), yscore), sprites(startframe + (hdigit * elmPerSpr)), PSet
Put (xscore + (xstep * 3), yscore), sprites(startframe + (tendigit * elmPerSpr)), PSet
Put (xscore + (xstep * 4), yscore), sprites(startframe + (onedigit * elmPerSpr)), PSet
'gunnerlives = 10
For lives = 1 To 10
If lives >= gunnerlives Then
Put (280 - gx, yscore), sprites(elmPerSpr * 20), PSet
Else
Put (280 - gx, yscore), sprites(gunner.tile), PSet
End If
gx = gx + xstep
Next
End If
End Sub
Sub EndToDos
Dim buffer(1000)
x1 = 130
x2 = 190
y1 = 90
y2 = 102
Get (x1, y1)-(x2, y2), buffer()
Line (x1, y1)-(x2, y2), 120, BF
Line (x1, y1)-(x2, y2), 123, B
p5x7font x1 + 3, y1 + 3, "Quit? (y/n)", 1
Do
event = returnevent
Select Case event
Case 89, 121
Exit Do
Case 78, 110
Put (x1, y1), buffer(), PSet
Exit Sub
End Select
Loop
'zero out adlib regs incase of hanging sounds
' For sfx = 11 To 19 'sounds effects 11 through 19 zero out all channels
' If UesFX Then playsfx (sfx$(sfx))
' Next
Width 80
Screen 0, 0, 0
End
End Sub
Sub FadePal (fc, lc, level, mode)
'Dim savepal(255) As hues
'For attrib = 0 To 255
'savepal(attrib).red = pal(attrib).red 'save pal to restore
'savepal(attrib).grn = pal(attrib).grn 'ditto
'savepal(attrib).blu = pal(attrib).blu 'ditto
'Next
If mode Then 'fade in
For value = 0 To level 'bring 'em all up
Out &H3C8, fc 'tell video card to get ready
For attrib = fc To lc 'first color to last color
'If pal(attrib).red >= savepal(attrib).red Then pal(attrib).red = pal(attrib).red + 1
'If pal(attrib).grn >= savepal(attrib).grn Then pal(attrib).grn = pal(attrib).grn + 1
'If pal(attrib).blu >= savepal(attrib).blu Then pal(attrib).blu = pal(attrib).blu + 1
If pal(attrib).red < 255 Then pal(attrib).red = pal(attrib).red + 1
If pal(attrib).grn < 255 Then pal(attrib).grn = pal(attrib).grn + 1
If pal(attrib).blu < 255 Then pal(attrib).blu = pal(attrib).blu + 1
'If pal(attrib).red > 255 Then pal(attrib).red = 255
'If pal(attrib).grn > 255 Then pal(attrib).grn = 255
'If pal(attrib).blu > 255 Then pal(attrib).blu = 255
Out &H3C9, pal(attrib).red 'send red component
Out &H3C9, pal(attrib).grn 'send green component
Out &H3C9, pal(attrib).blu 'send blue component
Next attrib
'_Delay .002
stay (50)
clearbuffer
Next value
Else 'fade out
'ReDim savepal(255) As hues
'For attrib = 0 To 255
'savepal(attrib).red = pal(attrib).red 'save pal to restore
'savepal(attrib).grn = pal(attrib).grn 'ditto
'savepal(attrib).blu = pal(attrib).blu 'ditto
'Next
For value = 0 To level
Out &H3C8, fc 'tell video card to get ready
For attrib = fc To lc 'first color to last color
If pal(attrib).red > 0 Then pal(attrib).red = pal(attrib).red - 1
If pal(attrib).grn > 0 Then pal(attrib).grn = pal(attrib).grn - 1
If pal(attrib).blu > 0 Then pal(attrib).blu = pal(attrib).blu - 1
Out &H3C9, pal(attrib).red 'send red component
Out &H3C9, pal(attrib).grn 'send green component
Out &H3C9, pal(attrib).blu 'send blue component
Next attrib
'_Delay .002
stay (50)
clearbuffer
Next value
End If
End Sub
Sub GetReady
Do
clearbuffer
Loop Until TimeIsUp(7, 1) 'wait a bit so user can get ready
clearbuffer
x1 = 130
y1 = 80
Do
If TimeIsUp(5, .4) Then toggle = Not toggle
If toggle Then
p5x7font x1, y1, "Get Ready", 0
p5x7font x1, y1 + 8, "Wave " + Str$(level), 0
Else
p5x7font x1, y1, "Get Ready", 90
p5x7font x1, y1 + 8, "Wave " + Str$(level), 90
End If
If TimeIsUp(6, 4) Then Exit Do
Loop Until returnevent = space
p5x7font x1, y1, "Get Ready", 0
p5x7font x1, y1 + 8, "Wave " + Str$(level), 0
End Sub
Sub InitGameStart
'--* set up aliens
AliensPerRow = 6 'eight max
If Hard Then AliensPerRow = 8
AliensPerCol = 6 'six max
numberofaliens = (AliensPerRow * AliensPerCol)
AliensInPLay = numberofaliens
Dim alien(AliensInPLay) As sprite 'need storage
AlienStepX = 35 'spaceing
AlienStepY = 20 'ditto
AlienStartX = 35 'position
AlienStartY = 20
alienvelx = 2 'velocity
AlienVely = AlienStepY / 2 'ditto
Cornerx = AlienStartX 'for adding steps
Cornery = AlienStartY 'ditto
AlienEndX = (AlienStepX * AliensPerRow) + AlienStartX 'calc end column
NewAlienFrame = (elmPerSpr * 2) 'to skip animation frames
'--*set up gunner 1
gunnerlives = 6
gunnerMaxx = Maxx - (20 * 4) 'set limits of movement
GunnerMinx = (20 * 3) 'ditto
GunnerY = Maxy - 14 'placement
gunnervel = 1 'velocity
gunner.x = gunnerMaxx - 18 'start position
gunner.y = Maxy - 14 'ditto
gunner.lx = gunner.x - 1 'force update
gunner.ly = gunner.y 'ditto
gunner.w = spritewidth 'gunner width
gunner.h = spriteheight 'gunner height
gunner.health = 1 'set health
gunner.sseg = elmPerSpr * 14 'pointer to image
gunner.tile = elmPerSpr * 14 'offset to frame
gunner.ltile = elmPerSpr * 14 'for erase
'--* set up gunshots
gunshot.w = 1
gunshot.h = 4
gunshot.health = 0
GunShotVel = 2
'--* set up alien bombs
Numberofbombs = 3
Dim abomb(Numberofbombs) As sprite
For ab = 1 To Numberofbombs
abomb(ab).w = 1
abomb(ab).h = 4
abomb(ab).health = 0
Next
Abombvel = 1
AbombInterval! = .2
'--* set up shields
NumberofShields = 3
Dim shield(NumberofShields) As sprite
shield(1).x = 80
shield(1).y = 170
shield(2).x = 150
shield(2).y = 170
shield(3).x = 220
shield(3).y = 170
For s = 1 To NumberofShields
shield(s).w = 20
shield(s).h = 14
Next
'--* set up barriers
Dim Barrier(2) As sprite
Barrier(1).x = GunnerMinx - spritewidth
Barrier(1).y = GunnerY
Barrier(1).tile = elmPerSpr * 12
Barrier(2).x = gunnerMaxx + spritewidth
Barrier(2).y = GunnerY
Barrier(2).tile = elmPerSpr * 13
Put (Barrier(1).x, Barrier(1).y), sprites(Barrier(1).tile), PSet
Put (Barrier(2).x, Barrier(2).y), sprites(Barrier(2).tile), PSet
DoScore (0) 'display score
End Sub
Sub Initlevel
Dolevel
'--* reset alien bombs
For ab = 1 To Numberofbombs 'Do alien bombs
abomb(ab).health = 0 'reset em
Line (abomb(ab).lx, abomb(ab).ly)-(abomb(ab).lx, abomb(ab).ly + abomb(ab).h), 0
Line (abomb(ab).x, abomb(ab).y)-(abomb(ab).x, abomb(ab).y + abomb(ab).h), 0
Next
'--* reset barriers
Put (shield(1).x, shield(1).y), sprites(elmPerSpr * 21), PSet
Put (shield(2).x, shield(2).y), sprites(elmPerSpr * 22), PSet
Put (shield(3).x, shield(3).y), sprites(elmPerSpr * 23), PSet
'--* reset gunner1
Put (gunner.x, gunner.y), sprites(20 * elmPerSpr), PSet
gunner.x = gunnerMaxx - 18
gunner.lx = gunner.x
Put (gunner.x, gunner.y), sprites(gunner.tile), PSet
'--* reset aliens
AliensInPLay = numberofaliens
movealiens = true 'so aliens appear
Cornerx = AlienStartX 'for adding steps
Cornery = AlienStartY 'ditto
AlienEndX = (AlienStepX * AliensPerRow) + AlienStartX 'calc end column
NewAlienFrame = (elmPerSpr * 2) 'to skip animation frames
NextChar = 0
NextFrame = 0
For a = 1 To numberofaliens 'initilaize aliens
alien(a).x = Cornerx 'position
alien(a).y = Cornery 'ditto
alien(a).lx = Cornerx 'ditto
alien(a).ly = Cornery 'ditto
alien(a).w = spritewidth 'size
alien(a).h = spriteheight 'ditto
alien(a).dir = 1 'walk towards left
alien(a).health = 1 'make alive
alien(a).sseg = NextChar 'pointer to images
alien(a).tile = NextChar 'offset to frame
alien(a).ltile = NextChar 'for erase
NextFrame = (NextFrame + elmPerSpr) Mod NewAlienFrame 'calc next frame
Cornerx = Cornerx + AlienStepX 'next column
If Cornerx = AlienEndX Then 'last in row
Cornerx = AlienStartX 'reset column
Cornery = Cornery + AlienStepY 'next row
NextChar = NextChar + (NewAlienFrame) 'next char
End If
Next
End Sub
Function InputText$ (xcur, ycur, length)
PalRegInfo 255, red, 0, 0, 1 'define cursor color
Dim Edit$(length) 'DIM array to edit
ele = 1 'set first element
Dim background(35, length + 2) 'DIM array to save background
Get (xcur, ycur)-(xcur + 6, ycur + 8), background(35, 1) 'GET background
p5x7font xcur, ycur, "_", 255 'init curser
clearbuffer 'clear the keybuffer
Do
Do 'event loop
event = returnevent 'anything happen ?
If dir = 0 Then 'strobe cursor
red = red + 1: If red > 62 Then dir = 1 'ditto
Else 'ditto
red = red - 1: If red < 10 Then dir = 0 'ditto
End If 'ditto
Palette 255, (65536 * blu) + (256 * grn) + red 'ditto
Loop Until event 'back for event
Select Case event
Case Esc: Exit Do 'do Esc
Case Enter: Exit Do 'do enter
Case 1 To 7, 9 To 126 'do regular keys
event$ = Chr$(event) 'convert for printing
If ele < length Then 'stay in bounds
Put (xcur, ycur), background(35, ele), PSet
p5x7font xcur, ycur, Chr$(event), 191 'print font
Edit$(ele) = event$ 'in case of backspace
Select Case event$ 'adjust kern
Case "i": xcur = xcur + 2 'ditto
Case "j": xcur = xcur + 5 'ditto
Case "l": xcur = xcur + 2 'ditto
Case "r": xcur = xcur + 5 'ditto
Case ".": xcur = xcur + 3 'ditto
Case "(": xcur = xcur + 3 'ditto
Case ")": xcur = xcur + 3 'ditto
Case "'": xcur = xcur + 2 'ditto
Case "!": xcur = xcur + 2 'ditto
Case Else: xcur = xcur + 6 'ditto
End Select
ele = ele + 1 'advance to next element
Get (xcur, ycur)-(xcur + 6, ycur + 8), background(35, ele)
p5x7font xcur, ycur, "_", 255 'print cursor
End If
Case Backspace, Left 'do backspace
If ele > 1 Then
Put (xcur, ycur), background(35, ele), PSet 'restore background
ele = ele - 1 'move to previous element
Select Case (Edit$(ele)) 'adjust kern
Case "i": xcur = xcur - 2 'ditto
Case "j": xcur = xcur - 5 'ditto
Case "l": xcur = xcur - 2 'ditto
Case "r": xcur = xcur - 5 'ditto
Case ".": xcur = xcur - 3 'ditto
Case "(": xcur = xcur - 3 'ditto
Case ")": xcur = xcur - 3 'ditto
Case "'": xcur = xcur - 2 'ditto
Case "!": xcur = xcur - 2 'ditto
Case Else: xcur = xcur - 6 'ditto
End Select
Put (xcur, ycur), background(35, ele), PSet
p5x7font xcur, ycur, "_", 255 'print cursor
Edit$(ele) = Chr$(space) 'clear element
End If
End Select
Loop
For n = 1 To length - 1 'put elements into a string
If Edit$(n) = "" Then Edit$(n) = Chr$(space) 'replace nulls
Temp$ = Temp$ + Edit$(n) 'create string
Next n
InputText$ = Temp$ 'return the string
End Function
Sub p5x7font (x, y, text$, colour)
length = Len(text$) 'get characters to print
If length = 0 Then Exit Sub 'check length
For char = 0 To length - 1 'print loop
piece$ = Mid$(text$, char + 1, 1) 'look at each piece of string
aski = Asc(piece$) 'assign it's ASCII value
Select Case (piece$) 'adjust lower case
Case "g": kerny = kerny + 2 'ditto
Case "j": kerny = kerny + 2 'ditto
Case "p": kerny = kerny + 2 'ditto
Case "q": kerny = kerny + 2 'ditto
Case "y": kerny = kerny + 2 'ditto
End Select
For ybit = 0 To 6 'top to Bottom
For xbit = 0 To 4 'left to right
If font(aski, xbit, ybit) = 1 Then 'set bits only
PSet (x + xbit + kernx, y + ybit + kerny), colour 'PSET data
End If
Next
Next
Select Case (piece$) 'kern adjusment
Case "i": kernx = kernx + 2 'ditto
Case "j": kernx = kernx + 5 'ditto
Case "l": kernx = kernx + 2 'ditto
Case "r": kernx = kernx + 5 'ditto
Case ".": kernx = kernx + 3 'ditto
Case "(": kernx = kernx + 3 'ditto
Case ")": kernx = kernx + 3 'ditto
Case "'": kernx = kernx + 2 'ditto
Case "!": kernx = kernx + 2 'ditto
Case Else: kernx = kernx + 6 'ditto
End Select
kerny = 0 'reset
Next
End Sub
Sub PalRegInfo (reg, red, grn, blu, mode)
Select Case mode
Case 0 'get individual palette register
Out &H3C7, reg 'tell video card which register
red = Inp(&H3C9) 'get red component
grn = Inp(&H3C9) 'get green component
blu = Inp(&H3C9) 'get blue component
Case 1 'set individual palette register
Out &H3C8, reg 'tell video card which register to change
Out &H3C9, red 'send red component
Out &H3C9, grn 'send green component
Out &H3C9, blu 'send blue component
End Select
End Sub
Sub Pfont (text$, x, y, colour)
Def Seg = &HFFA6
For piece = 1 To Len(text$)
address = (8 * Asc(Mid$(text$, piece))) + 14
For hl = 0 To 7
mask = Peek(address + hl) * 128
Line (x + kernx, y + hl)-(x + 8 + kernx, y + hl), colour, , mask
Next
kernx = kernx + 8
Next
'x = 0
Def Seg
End Sub
Sub playsfx (sfx&)
'plays an sfx$ that is sent to it.
'sub expects the c$() array (channel info) to be global
' chan% = Val(Mid$(sfx$, 61, 4))
' For in = 1 To 60 Step 4
' reg$ = Mid$(c$(chan%), in, 4): reg% = Val(reg$)
' dat$ = Mid$(sfx$, in, 4): dat% = Val(dat$)
' Out &H388, reg%: For d% = 1 To 6: b% = Inp(&H388): Next
' Out &H389, dat%: For d% = 1 To 35: b% = Inp(&H388): Next
' Next
_SndPlay sfx&
End Sub
Function returnevent
kee$ = InKey$
If kee$ <> "" Then
If Len(kee$) = 1 Then
keycode = Asc(kee$)
Else
keycode = -Asc(Right$(kee$, 1))
End If
End If
returnevent = keycode
End Function
Sub ShowHighScores (score() As highscores, mode)
fc = 199
Cls
FadePal 16, 255, 23, 1
alien = Int(Rnd * 12)
For x = 1 To 300 Step 20
For y = 1 To 186 Step 14
Put (x, y), sprites(elmPerSpr * alien), PSet
Next
Next
FadePal 16, 255, 23, 0
p5x7font 96, 17, "Invader Hall of Fame", 191
p5x7font 96, 16, "Invader Hall of Fame", 29
placey = 35
shadow = 1
For a = 1 To 15
p5x7font 20 + 8 - shadow, placey + shadow, score(a).rank, 19
p5x7font 38 + 8 - shadow, placey + shadow, score(a).dat, 19
p5x7font 93 + 8 - shadow, placey + shadow, score(a).nam, 19
p5x7font 240 + 8 - shadow, placey + shadow, score(a).score, 19
p5x7font 20 + 8, placey, score(a).rank, 191
p5x7font 38 + 8, placey, score(a).dat, 29
p5x7font 93 + 8, placey, score(a).nam, 191
p5x7font 240 + 8, placey, score(a).score, 29
placey = placey + 10 ' drop y to a new line
Next a
If mode Then Exit Sub
Do
If TimeIsUp(6, 120) Then Exit Do
event = returnevent
Loop Until event
End Sub
Sub soundfx (fx)
Select Case fx
Case 1 'step sound
Sound 60, .1
Case 2 'gunner hit
For freq! = 160 To 60 Step -10
duration! = freq! / 100
Sound freq!, duration!
Next
Case 3 'alien bomb hiting gunshot
Sound 1160, .1
Case 4 ' gunshot hit alien
Play "MB" + "O0" + "L64" + "A" + "B" + "C" + "B" + "C" + "A"
Case 5
For freq! = 200 To 60 Step -8
stay (10)
Sound freq!, .1
Next
Case 6 'hit command ship
Play "MB" + "O1" + "L20" + "G" + "G" + "G "
Case 7
'hit command ship with head up
Play "MB" + "O2" + "L30" + "C" + "D" + "E " + "F"
Case 8
play$ = "C" + "D" + "E" + "F" + "G" + "F" + "E" + "D"
Play "MB" + "O0" + "L40" + play$
Case 9
For z% = -20 To 193
Sound 425 - z% * 2, .2
Next z%
'For z = 166 To 299 Step 6
'Sound 340 - z, 1
'Next z
'Play "MBO3T128MNL4C<G8>C<G8F8G8E16F16G16A16B16>C16D16C1"
End Select
End Sub
DefSng A-Z
Sub stay (Millisecs!)
Static Syspeed&, Time2
If Syspeed& Then ' First time here -get relative system speed
If Millisecs Then ' Start Delay loop
factor& = (Syspeed& * Millisecs) \ 55 'num of loops needed
If factor& < 1 Then Exit Sub
Do ' delay loop
factor& = factor& - 1 ' Sub the num of loops
Loop Until Time2 = Peek(&H6C) Or factor& = 0 ' make loop same as below
End If
Else ' Relative system speed processed here
Def Seg = &H40
Time1 = Peek(&H6C)
Do
Time2 = Peek(&H6C) ' get another
Loop Until Time1 <> Time2 ' loop until new clock tick
Do ' start here at new clock tick
Syspeed& = Syspeed& - 1 ' Count the number of times looped
Loop Until Time2 <> Peek(&H6C) Or Syspeed& = 0 'make same as loop above
Time2 = 1255
Syspeed& = Abs(Syspeed&) 'cant use this neg -reverse it
End If
End Sub
DefInt A-Z
Function TimeIsUp (n, tsecs!)
' Poll this function to check for passage of time. When the amount of
' time in tsecs has passed timeisup() returns TRUE, otherwise the function
' returns false.
' Initialize this routine with tsecs! = -1 and n = to the number
' of timers to set up.
Static getclock(), oldtsecs!(), Time1!()
If tsecs! = -1 Then ' initialize timers
Dim getclock(n)
Dim oldtsecs!(n)
Dim Time1!(n)
End If
If tsecs! <> oldtsecs!(n) Then getclock(n) = 0
If getclock(n) = 0 Then
Time1!(n) = Timer
getclock(n) = 1
oldtsecs!(n) = tsecs!
Else
If Abs(Timer - Time1!(n)) >= tsecs! Then
TimeIsUp = 1
getclock(n) = 0
Else
TimeIsUp = 0
End If
End If
End Function
Sub TitleScreen
text$ = "QB Invaders"
For alien = 0 To 7 Step 2 'select alien to pull title
If Int(Rnd * 11) = 5 Then Exit For
Next
For x = 300 To 95 Step -1
counter = (counter + 1) Mod 6
If counter = 2 Then frame = (frame + 1) Mod 2
Put (lx, 90), sprites(elmPerSpr * 20), PSet 'erase last
p5x7font lx + 20, 90, text$, 0
event = returnevent
If event Then Exit For
Put (x, 90), sprites((alien + frame) * elmPerSpr), PSet
p5x7font x + 20, 90, text$, 155
lx = x
_Delay .05
Do: Loop Until Inp(&H3DA) And 8 'wait for VGA retrace
Next
Put (95, 90), sprites((alien + frame) * elmPerSpr), PSet
_Delay 1
event = 0
If event = 0 Then FadePal 40, 200, 60, 1
p5x7font 95 + 20, 90, text$ + " Ver 1.0", 155
p5x7font 78, 120, "Atari graphics by John Denesha", 155
p5x7font 69, 130, "Other graphics by Timothy Truman", 187
p5x7font 79, 140, "Program Author Timothy Truman", 187
p5x7font 59, 160, "Copyright (c) 1997 Nocturnal Creations", 170
_Delay 1
If event = 0 Then FadePal 40, 200, 60, 0
If event = 0 Then FadePal 40, 200, 60, 1
p5x7font 65, 40, "Use right and left keys to move", 154
p5x7font 100, 50, "Use Space bar to fire", 154
p5x7font 130, 60, "Esc to Quit", 154
_Delay 1
If event = 0 Then FadePal 40, 200, 60, 0
Do
Do: Loop Until Inp(&H3DA) And 8 'wait for VGA retrace
If TimeIsUp(3, 1) Then cship.health = true
DocommandShip
event = returnevent
If event = Esc Then
EndToDos
event = 0
End If
Loop Until event
cship.health = false
Cls
End Sub
'$INCLUDE: '.\Unbenannt1.bm'
'$INCLUDE: '.\Unbenannt2.bm'
'$INCLUDE: '.\Unbenannt3.bm'
'$INCLUDE: '.\Unbenannt4.bm'
'$INCLUDE: '.\Unbenannt5.bm'
'$INCLUDE: '.\Unbenannt6.bm'
'$INCLUDE: '.\Unbenannt7.bm'
'$INCLUDE: '.\Unbenannt8.bm'
'$INCLUDE: '.\Unbenannt9.bm'
'$INCLUDE: '.\Unbenannt10.bm'
