Skip to content

Instantly share code, notes, and snippets.

@arantius arantius/kaboom.bas
Created Oct 19, 2011

Embed
What would you like to do?
A single player "Battleship!" clone, with an AI opponent. Made for a local computer club competition.
'Ka-Boom! by Tony Lieuallen Started: April 29, 1995
COMMON LenShip, NowSpotX, NowSpotY, StilShoot
DEFINT A-Z
DECLARE SUB PlaySound (HorM$)
DECLARE SUB Instructions ()
DECLARE SUB FontNotFound ()
DECLARE SUB GraphColor (Colr)
DECLARE SUB PutShips ()
DECLARE SUB DrawGrid ()
DECLARE SUB Test (HitFlag, Direction$)
DECLARE SUB MakeOld ()
DECLARE SUB Rotate (LenShip)
DECLARE SUB GetPlace ()
DECLARE SUB IsYoursAHit ()
DECLARE SUB CpuPutShips ()
DECLARE SUB IsShipGone ()
DECLARE SUB ShowMessage (Text$)
DECLARE SUB IsGameOver ()
DECLARE SUB CpuShoot ()
DECLARE SUB BLOADFont (FlName$, FontArray(), RetCode)
DECLARE SUB FastString (Text$, FClr, x, Y, FontArray())
DECLARE SUB Delay (Ticks)
DECLARE FUNCTION Exist (FilName$)
ProgStart:
SCREEN 12
CLS
RANDOMIZE TIMER
LOCATE , , 0, 0
GraphColor 47
CONST NumHdrElem = 11
DIM SHARED HisGrid(9, 9, 2) AS INTEGER
DIM SHARED YourGrid(9, 9, 2) AS INTEGER
DIM SHARED HisHits(5) AS INTEGER
DIM SHARED YourHits(5) AS INTEGER
IF NOT Exist("DOSAPP.BIN") THEN BadFnt = BadFnt + 1
IF NOT Exist("DTCH_REG.BIN") THEN BadFnt = BadFnt + 1
IF NOT Exist("courf.BIN") THEN BadFnt = BadFnt + 1
IF NOT Exist("8514sys.BIN") THEN BadFnt = BadFnt + 1
IF NOT Exist("sseriff.BIN") THEN BadFnt = BadFnt + 1
IF BadFnt THEN FontNotFound
REDIM SHARED DosApp(1)
REDIM SHARED DtchFont(1)
REDIM SHARED CourfFont(1)
REDIM SHARED Sys8514font(1)
REDIM SHARED SseriffFont(1)
CALL BLOADFont("DOSAPP.BIN", DosApp(), RetCode)
CALL BLOADFont("DTCH_REG.BIN", DtchFont(), RetCode)
CALL BLOADFont("Courf.BIN", CourfFont(), RetCode)
CALL BLOADFont("8514sys.BIN", Sys8514font(), RetCode)
CALL BLOADFont("Sseriff.BIN", SseriffFont(), RetCode)
ERASE HisGrid, YourGrid
LINE (10, 20)-(12, 290), 1, BF: LINE (10, 20)-(282, 22), 1, BF
LINE (300, 150)-(302, 420), 1, BF: LINE (300, 150)-(572, 152), 1, BF
LINE (280, 20)-(282, 290), 1, BF: LINE (10, 290)-(282, 292), 1, BF
LINE (570, 150)-(572, 420), 1, BF: LINE (300, 420)-(572, 422), 1, BF
PAINT (40, 40), 9, 1
PAINT (340, 340), 9, 1
FOR Box = 1 TO 8
LINE (10 + (Box * 30), 20)-(12 + (Box * 30), 290), 1, BF
LINE (10, 20 + (Box * 30))-(282, 22 + (Box * 30)), 1, BF
LINE (300 + (Box * 30), 150)-(302 + (Box * 30), 420), 1, BF
LINE (300, 150 + (Box * 30))-(572, 152 + (Box * 30)), 1, BF
NEXT
PAINT (1, 1), 2, 1
FastString "My Grid", 15, 105, 300, CourfFont()
LINE (180, 300)-(180, 315), 15
LINE (180, 300)-(175, 305), 15
LINE (180, 300)-(185, 305), 15
FastString "YOUR Grid", 15, 385, 130, CourfFont()
LINE (475, 130)-(475, 145)
LINE (475, 145)-(470, 140)
LINE (475, 145)-(480, 140)
FastString "KA-Boom!!, By Tony Lieuallen", 14, 188, 435, Sys8514font()
FastString "Your Damage:", 15, 10, 325, CourfFont()
LINE (24, 344)-(194, 356), 1, B
PAINT (30, 350), 10, 1
FOR Div = 1 TO 16
LINE (24 + (Div * 10), 344)-(24 + (Div * 10), 356), 1
NEXT
FOR count = 1 TO 9
FastString STR$(count), 0, 13 + (count * 10), 348, DosApp()
NEXT
FOR count = 10 TO 17
FastString STR$(count), 0, 11 + (count * 10), 348, DosApp()
NEXT
FastString "My Damage:", 15, 10, 365, CourfFont()
LINE (24, 384)-(194, 396), 1, B
PAINT (30, 390), 10, 1
FOR Div = 1 TO 16
LINE (24 + (Div * 10), 384)-(24 + (Div * 10), 396), 1
NEXT
FOR count = 1 TO 9
FastString STR$(count), 0, 13 + (count * 10), 388, DosApp()
NEXT
FOR count = 10 TO 17
FastString STR$(count), 0, 11 + (count * 10), 388, DosApp()
NEXT
Instructions
FastString "Place your ships...", 15, 340, 50, DtchFont()
PutShips
LINE (330, 45)-(475, 70), 2, BF
MakeOld
DrawGrid
NowSpotX = 1
NowSpotY = 1
CpuPutShips
PAINT (30, 30), 4, 1
FastString "Choose where to fire...", 15, 340, 50, DtchFont()
FastString "Use the keypad as before,", 15, 340, 63, DtchFont()
FastString "and press enter to fire!", 15, 340, 76, DtchFont()
Key$ = ""
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
IF Key$ = CHR$(27) THEN SYSTEM
LINE (330, 65)-(500, 95), 2, BF
DO UNTIL GameOver
GetPlace
IF PutFlag THEN
PutFlag = 0
LINE (330, 45)-(500, 65), 2, BF
IsYoursAHit
CpuShoot
FastString "Choose where to fire...", 15, 340, 50, DtchFont()
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 4, 1
END IF
LOOP
IF GameOver = 10 THEN CLEAR : GOTO ProgStart
SUB BLOADFont (FlName$, FontArray(), RetCode)
FileNum = FREEFILE
OPEN FlName$ FOR BINARY AS FileNum
SizeInBytes& = LOF(FileNum)
CLOSE FileNum
IF (SizeInBytes& = 0) THEN RetCode = -1: EXIT SUB
SizeInBytes& = SizeInBytes& - 7
REDIM FontArray((SizeInBytes& - 1) \ 2)
DEF SEG = VARSEG(FontArray(0))
BLOAD FlName$, VARPTR(FontArray(0))
DEF SEG
RetCode = 0
END SUB
SUB CpuPutShips
NotThreeYet = 1
StartCput:
SELECT CASE LenCShip
CASE 0
LenCShip = 2
CASE 2
LenCShip = 3
CASE 3
IF CThreeB4 = 1 THEN
CThreeB4 = 0
LenCShip = 4
ELSE
NotThreeYet = 0
CThreeB4 = 1
END IF
CASE 5
LINE (335, 65)-(630, 90), 2, BF
EXIT SUB
CASE 4
LenCShip = 5
END SELECT
DO UNTIL PPut
HOrV = INT(2 * RND + 1)
PutX = 0
PutY = 0
IF HOrV = 1 THEN
PutX = INT((9 - LenCShip) * RND + 1)
PutY = INT(9 * RND + 1)
ELSE
PutX = INT(9 * RND + 1)
PutY = INT((9 - LenCShip) * RND + 1)
END IF
IF HOrV = 1 THEN
PutOk = 0
FOR Check = 0 TO LenCShip - 1
IF HisGrid(PutX + Check, PutY, 2) = 0 THEN PutOk = PutOk + 1
NEXT
IF PutOk = LenCShip THEN
FOR PutShip = 0 TO LenCShip - 1
HisGrid(PutX + PutShip, PutY, 2) = LenCShip - NotThreeYet
NEXT
PPut = 1
END IF
ELSE
PutOk = 0
FOR Check = 0 TO LenCShip - 1
IF HisGrid(PutX, PutY + Check, 2) = 0 THEN PutOk = PutOk + 1
NEXT
IF PutOk = LenCShip THEN
FOR PutShip = 0 TO LenCShip - 1
HisGrid(PutX, PutY + PutShip, 2) = LenCShip - NotThreeYet
NEXT
PPut = 1
END IF
END IF
LOOP
PPut = 0
GOTO StartCput
END SUB
SUB CpuShoot
SHARED StilShoot
STATIC LastWasHit, LastShootX, LastShootY, ShootDir, NoChangeShootDir
STATIC HitSpotX, HitSpotY, CHits
ShowMessage "Computer is shooting... "
IF StilShoot = 0 THEN
ChooseSpot:
ShootDir = 1
NoChangeShootDir = 0
ShootX = INT(9 * RND + 1)
ShootY = INT(9 * RND + 1)
IF YourGrid(ShootX, ShootY, 1) <> 0 THEN GOTO ChooseSpot
IF YourGrid(ShootX, ShootY, 2) > 0 THEN
ShootDir = INT(RND * 3)
HitSpotX = ShootX
HitSpotY = ShootY
END IF
ELSE
GenSpot:
IF NoChangeShootDir = 0 THEN
ShootDir = ShootDir + 1
IF ShootDir = 5 THEN ShootDir = 1
LastShootX = HitSpotX
LastShootY = HitSpotY
END IF
SELECT CASE ShootDir
CASE 1
ShootY = LastShootY
ShootX = LastShootX + 1
CASE 2
ShootY = LastShootY
ShootX = LastShootX - 1
CASE 3
ShootY = LastShootY + 1
ShootX = LastShootX
CASE 4
ShootY = LastShootY - 1
ShootX = LastShootX
END SELECT
BadShot = 0
IF ShootX > 9 THEN BadShot = BadShot + 1: NoChangeShootDir = 0
IF ShootX < 1 THEN BadShot = BadShot + 1: NoChangeShootDir = 0
IF ShootY > 9 THEN BadShot = BadShot + 1: NoChangeShootDir = 0
IF ShootY < 1 THEN BadShot = BadShot + 1: NoChangeShootDir = 0
IF BadShot > 0 THEN
BadShot = 0
GOTO GenSpot
END IF
IF YourGrid(ShootX, ShootY, 1) = -1 THEN BadShot = BadShot + 1: NoChangeShootDir = 0
IF YourGrid(ShootX, ShootY, 1) = 5 THEN BadShot = BadShot + 1: NoChangeShootDir = 1
IF BadShot > 0 THEN
BadShot = 0
LastShootX = ShootX
LastShootY = ShootY
GOTO GenSpot
END IF
IF YourGrid(ShootX, ShootY, 1) = -1 AND StilShoot = 1 THEN
NoChangeShootDir = 2
SELECT CASE ShootDir
CASE 1
ShootDir = 2
CASE 2
ShootDir = 3
CASE 3
ShootDir = 4
CASE 4
ShootDir = 1
END SELECT
END IF
END IF
SELECT CASE YourGrid(ShootX, ShootY, 2)
CASE 0
PAINT (305 + (ShootX - 1) * 30, 167 + (ShootY - 1) * 30), 3, 1
PlaySound ("M")
ShowMessage "MISS!!! "
YourGrid(ShootX, ShootY, 1) = -1
DrawGrid
SELECT CASE NoChangeShootDir
CASE 1
NoChangeShootDir = 0
CASE 2
NoChangeShootDir = 1
END SELECT
CASE IS > 0
PAINT (305 + (ShootX - 1) * 30, 167 + (ShootY - 1) * 30), 15, 1
PlaySound ("H")
ShowMessage "HIT!!! "
YourHits(YourGrid(ShootX, ShootY, 2)) = YourHits(YourGrid(ShootX, ShootY, 2)) + 1
YourGrid(ShootX, ShootY, 1) = 5
CHits = CHits + 1
PAINT (20 + (CHits * 10), 350), 12, 1
DrawGrid
StilShoot = 1
IF ShootDir > 0 THEN NoChangeShootDir = 1
END SELECT
IsShipGone
LastShootX = ShootX
LastShootY = ShootY
END SUB
SUB DrawGrid
FOR Y = 1 TO 9
FOR x = 1 TO 9
SELECT CASE HisGrid(x, Y, 1)
CASE 0
IF POINT(25 + (x - 1) * 30, 37 + (Y - 1) * 30) <> 9 THEN
PAINT (25 + (x - 1) * 30, 37 + (Y - 1) * 30), 9, 1
END IF
CASE -1
IF POINT(25 + (x - 1) * 30, 37 + (Y - 1) * 30) <> 7 THEN
PAINT (25 + (x - 1) * 30, 37 + (Y - 1) * 30), 7, 1
END IF
CASE IS > 0
IF POINT(25 + (x - 1) * 30, 37 + (Y - 1) * 30) <> 2 THEN
CIRCLE (26 + (x - 1) * 30, 36 + (Y - 1) * 30), 10, 1
PAINT (25 + (x - 1) * 30, 37 + (Y - 1) * 30), 14, 1
PAINT (14 + (x - 1) * 30, 37 + (Y - 1) * 30), 12, 1
END IF
END SELECT
SELECT CASE YourGrid(x, Y, 2)
CASE -10
IF POINT(305 + (x - 1) * 30, 167 + (Y - 1) * 30) <> 13 THEN
PAINT (305 + (x - 1) * 30, 167 + (Y - 1) * 30), 13, 1
END IF
CASE 0
IF YourGrid(x, Y, 1) <> -1 THEN
PAINT (305 + (x - 1) * 30, 167 + (Y - 1) * 30), 9, 1
END IF
CASE IS > 0
IF YourGrid(x, Y, 1) <> 5 THEN
PAINT (305 + (x - 1) * 30, 167 + (Y - 1) * 30), 14, 1
END IF
END SELECT
SELECT CASE YourGrid(x, Y, 1)
CASE -1
IF POINT(305 + (x - 1) * 30, 167 + (Y - 1) * 30) <> 7 THEN
PAINT (305 + (x - 1) * 30, 167 + (Y - 1) * 30), 7, 1
END IF
CASE 5
IF POINT(305 + (x - 1) * 30, 167 + (Y - 1) * 30) <> 12 THEN
CIRCLE (316 + (x - 1) * 30, 166 + (Y - 1) * 30), 10, 1
PAINT (325 + (x - 1) * 30, 167 + (Y - 1) * 30), 14, 1
PAINT (304 + (x - 1) * 30, 167 + (Y - 1) * 30), 12, 1
END IF
END SELECT
NEXT
NEXT
END SUB
SUB FastString (Text$, FClr, x, Y, FontArray())
CONST NumHdrElem = 11
xchar = x
NumChars = FontArray(1)
FontHeight = FontArray(0)
DEF SEG = VARSEG(FontArray(0))
FOR k = 1 TO LEN(Text$)
RelChar = ASC(MID$(Text$, k, 1)) - FontArray(2)
IF ((RelChar < 0) OR (RelChar > NumChars - 1)) THEN RelChar = FontArray(4)
PWidth = FontArray(NumHdrElem + RelChar)
Ptr& = FontArray(NumHdrElem + NumChars + RelChar)
IF (Ptr& < 0) THEN Ptr& = 65536 + Ptr&
Ptr& = Ptr& + VARPTR(FontArray(0))
BytesPerRow = 1 + (PWidth - 1) \ 8
XLocn = xchar - 8
FOR j = 1 TO BytesPerRow
YLocn = Y
FOR I = 1 TO FontHeight
LINE (XLocn, YLocn)-STEP(15, 0), FClr, , PEEK(Ptr&)
Ptr& = Ptr& + 1
YLocn = YLocn + 1
NEXT I
XLocn = XLocn + 8
NEXT j
xchar = xchar + PWidth + FontArray(9)
NEXT k
DEF SEG
x = xchar
END SUB
SUB FontNotFound
CLS
PRINT "Sorry, I could not find the font files. Please"
PRINT "change to the driectory which contains the original"
PRINT "Ka-Boom Files. Thank you."
SYSTEM
END SUB
SUB GetPlace
SHARED NowSpotX, NowSpotY, PutFlag
Start:
Key$ = ""
DO UNTIL Key$ <> ""
Key$ = INKEY$
LOOP
IF Key$ = CHR$(27) THEN SYSTEM
SELECT CASE Key$
CASE CHR$(13)
IF HisGrid(NowSpotX, NowSpotY, 1) <> 0 THEN
ShowMessage "You already tried there!!!"
ELSE
PutFlag = 1
END IF
CASE "4"
IF NowSpotX = 1 THEN
SOUND 32000, 2
EXIT SUB
ELSE
SELECT CASE HisGrid(NowSpotX, NowSpotY, 1)
CASE 0
PClr = 9
CASE -1
PClr = 7
CASE IS > 0
PClr = 12
END SELECT
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), PClr, 1
NowSpotX = NowSpotX - 1
END IF
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 4, 1
CASE "6"
IF NowSpotX = 9 THEN
SOUND 32000, 2
EXIT SUB
ELSE
SELECT CASE HisGrid(NowSpotX, NowSpotY, 1)
CASE 0
PClr = 9
CASE -1
PClr = 7
CASE IS > 0
PClr = 12
END SELECT
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), PClr, 1
NowSpotX = NowSpotX + 1
END IF
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 4, 1
CASE "8"
IF NowSpotY = 1 THEN
SOUND 32000, 2
EXIT SUB
ELSE
SELECT CASE HisGrid(NowSpotX, NowSpotY, 1)
CASE 0
PClr = 9
CASE -1
PClr = 7
CASE IS > 0
PClr = 12
END SELECT
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), PClr, 1
NowSpotY = NowSpotY - 1
END IF
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 4, 1
CASE "2"
IF NowSpotY = 9 THEN
SOUND 32000, 2
EXIT SUB
ELSE
SELECT CASE HisGrid(NowSpotX, NowSpotY, 1)
CASE 0
PClr = 9
CASE -1
PClr = 7
CASE IS > 0
PClr = 12
END SELECT
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), PClr, 1
NowSpotY = NowSpotY + 1
END IF
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 4, 1
CASE ELSE
GOTO Start
END SELECT
END SUB
SUB Instructions
FastString "Would you like instructions?", 15, 340, 50, DtchFont()
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
LINE (330, 45)-(555, 120), 2, BF
IF Key$ = CHR$(27) THEN SYSTEM
IF UCASE$(Key$) <> "Y" THEN EXIT SUB
FastString "First, I will tell you how to", 15, 340, 50, DtchFont()
FastString "place your ships. You must use", 15, 340, 63, DtchFont()
FastString "the number keypad to move the", 15, 340, 76, DtchFont()
FastString "ship around. Then, pushing the", 15, 340, 89, DtchFont()
FastString "spacebar will rotate.", 15, 340, 102, DtchFont()
Key$ = ""
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
IF Key$ = CHR$(27) THEN SYSTEM
LINE (330, 45)-(555, 120), 2, BF
FastString "You must press the enter key to", 15, 340, 37, DtchFont()
FastString "place the ship, and you cannot", 15, 340, 50, DtchFont()
FastString "move a ship through another. You", 15, 340, 63, DtchFont()
FastString "cannot rotate, if it would put your", 15, 340, 76, DtchFont()
FastString "ship out of the playing field, or", 15, 340, 89, DtchFont()
FastString "on top of another ship.", 15, 340, 102, DtchFont()
Key$ = ""
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
IF Key$ = CHR$(27) THEN SYSTEM
LINE (330, 30)-(555, 120), 2, BF
FastString "GOOD LUCK!!", 12, 380, 70, Sys8514font()
Key$ = ""
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
LINE (350, 60)-(500, 90), 2, BF
END SUB
SUB IsGameOver
SHARED GameOver
FOR GameOvr = 1 TO 5
IF HisHits(GameOvr) >= 10 THEN YouWin = YouWin + 1
NEXT
IF YouWin = 5 THEN
LINE (285, 20)-(600, 120), 2, BF
FastString "YOU win!? How can that be? I will", 15, 322, 50, Sys8514font()
FastString "crush you next time, puny human!!!", 15, 320, 70, Sys8514font()
FastString "And I won't let you play again! HA!", 15, 302, 90, CourfFont()
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
SYSTEM
END IF
FOR GameOvr = 1 TO 5
IF YourHits(GameOvr) >= 10 THEN HeWins = HeWins + 1
NEXT
IF HeWins = 5 THEN
LINE (285, 20)-(600, 120), 2, BF
FastString "I win!!!, my superior intelect", 15, 325, 50, Sys8514font()
FastString "crushes your puny human brain!!!", 15, 315, 70, Sys8514font()
FastString "Wanna play again? (I don't see why.)", 15, 305, 90, CourfFont()
DO UNTIL Key$ <> "": Key$ = INKEY$: LOOP
IF UCASE$(Key$) = "Y" THEN GameOver = 10: EXIT SUB
SYSTEM
END IF
END SUB
SUB IsShipGone
SHARED StilShoot
FOR Check = 1 TO 5
TempCheckC = 0
SELECT CASE Check
CASE IS < 2
TempCheckC = 2
CASE IS > 2
TempCheckC = Check
CASE 2
TempCheckC = 3
END SELECT
IF HisHits(Check) = TempCheckC THEN
ShowMessage "You sunk one of my ships!!!"
HisHits(Check) = 10
IsGameOver
END IF
TempCheck = 0
TempCheck = Check
IF TempCheck < 3 THEN TempCheck = TempCheck + 1
IF YourHits(Check) = TempCheck THEN
ShowMessage "I sunk one of your ships!!!"
StilShoot = 0
YourHits(Check) = 10
IsGameOver
END IF
NEXT
END SUB
SUB IsYoursAHit
SHARED NowSpotX, NowSpotY
STATIC YHits
SELECT CASE HisGrid(NowSpotX, NowSpotY, 2)
CASE 0
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 7, 1
FastString "MISS!!!", 15, 340, 70, SseriffFont()
PlaySound ("M")
Delay 5
LINE (335, 65)-(400, 90), 2, BF
HisGrid(NowSpotX, NowSpotY, 1) = -1
CASE IS > 0
HisGrid(NowSpotX, NowSpotY, 1) = 1
HisHits(HisGrid(NowSpotX, NowSpotY, 2)) = HisHits(HisGrid(NowSpotX, NowSpotY, 2)) + 1
DrawGrid
PAINT (15 + (NowSpotX - 1) * 30, 35 + (NowSpotY - 1) * 30), 4, 1
YHits = YHits + 1
PAINT (16 + (YHits * 10), 386), 12, 1
FastString "HIT!!!", 15, 340, 70, SseriffFont()
PlaySound ("H")
LINE (335, 65)-(400, 90), 2, BF
IsShipGone
IsGameOver
END SELECT
END SUB
SUB MakeOld
SHARED LenShip, ThreeB4
FOR Y = 1 TO 9
FOR x = 1 TO 9
IF YourGrid(x, Y, 2) = -10 THEN
YourGrid(x, Y, 2) = LenShip + 1 - ThreeB4
END IF
NEXT
NEXT
END SUB
SUB PlaySound (HorM$)
IF UCASE$(HorM$) = "M" THEN
PLAY "T255L64O4CDEFGABO3CDEFGABO2CDEFGAB"
ELSE
FOR I = 1 TO 20
SOUND I * 50, .1
SOUND I * 100, .1
SOUND I * 150, .1
NEXT
END IF
END SUB
SUB PutShips
SHARED LenShip, ThreeB4
LenShip = 5
NextShip:
MakeOld
DrawGrid
NextFlag = 0
Xp = 0
GoodFlag = 0
Top = 0
DO UNTIL GoodFlag
Ok4Now = 0
Xp = Xp + 1
IF Xp = 10 THEN
Top = Top + 1
Xp = 1
END IF
FOR Yp = Top + 1 TO LenShip + Top
IF YourGrid(Xp, Yp, 2) = 0 THEN Ok4Now = Ok4Now + 1
NEXT
IF Ok4Now >= LenShip THEN GoodFlag = 1
LOOP
FOR Y = 1 TO LenShip
YourGrid(Xp, Y + Top, 2) = -10
NEXT
DrawGrid
MoveShip:
Key$ = ""
DO UNTIL Key$ <> ""
Key$ = INKEY$
LOOP
IF Key$ = CHR$(27) THEN SYSTEM
SELECT CASE Key$
CASE CHR$(13)
IF LenShip = 3 THEN
IF ThreeB4 THEN
LenShip = LenShip - 1
ELSE
ThreeB4 = 1
END IF
ELSE
LenShip = LenShip - 1
END IF
NextFlag = LenShip
GOTO Edge
CASE " "
Rotate LenShip
CASE "4"
FOR e = 1 TO 9
IF YourGrid(1, e, 2) = -10 THEN SOUND 32000, 2: GOTO Edge
NEXT
HitFlag = 0
Test HitFlag, "left"
IF HitFlag THEN GOTO Edge
FOR Y = 1 TO 9
FOR x = 1 TO 9
IF YourGrid(x, Y, 2) = -10 THEN
YourGrid(x - 1, Y, 2) = YourGrid(x, Y, 2)
YourGrid(x, Y, 2) = 0
END IF
NEXT
NEXT
CASE "6"
FOR e = 1 TO 9
IF YourGrid(9, e, 2) = -10 THEN SOUND 32000, 2: GOTO Edge
NEXT
HitFlag = 0
Test HitFlag, "right"
IF HitFlag THEN GOTO Edge
FOR Y = 1 TO 9
FOR x = 9 TO 1 STEP -1
IF YourGrid(x, Y, 2) = -10 THEN
YourGrid(x + 1, Y, 2) = YourGrid(x, Y, 2)
YourGrid(x, Y, 2) = 0
END IF
NEXT
NEXT
CASE "8"
FOR e = 1 TO 9
IF YourGrid(e, 1, 2) = -10 THEN SOUND 32000, 2: GOTO Edge
NEXT
HitFlag = 0
Test HitFlag, "up"
IF HitFlag THEN GOTO Edge
X2 = 0: Y2 = 0
FOR Y = 1 TO 9
FOR x = 1 TO 9
IF YourGrid(x, Y, 2) = -10 THEN
YourGrid(x, Y - 1, 2) = YourGrid(x, Y, 2)
YourGrid(x, Y, 2) = 0
END IF
NEXT
NEXT
CASE "2"
FOR e = 1 TO 9
IF YourGrid(e, 9, 2) = -10 THEN SOUND 32000, 2: GOTO Edge
NEXT
HitFlag = 0
Test HitFlag, "down"
IF HitFlag THEN GOTO Edge
FOR Y = 9 TO 1 STEP -1
FOR x = 1 TO 9
IF YourGrid(x, Y, 2) = -10 THEN
YourGrid(x, Y + 1, 2) = YourGrid(x, Y, 2)
YourGrid(x, Y, 2) = 0
END IF
NEXT
NEXT
END SELECT
DrawGrid
Edge:
IF NextFlag = LenShip AND LenShip = 1 THEN EXIT SUB
IF NextFlag = LenShip THEN GOTO NextShip
GOTO MoveShip
END SUB
SUB Rotate (LenShip)
FOR Y = 0 TO 8
FOR x = 0 TO 8
IF YourGrid(x, Y, 2) = -10 THEN
IF YourGrid(x + 1, Y, 2) = -10 THEN
IF Y > (10 - LenShip) THEN EXIT SUB
FOR yc = Y + 1 TO (LenShip - 1 + Y)
IF YourGrid(x, yc, 2) > 0 THEN EXIT SUB
NEXT
FOR X2 = x TO (LenShip - 1 + x)
YourGrid(X2, Y, 2) = 0
NEXT
FOR Y2 = Y TO (LenShip - 1 + Y)
YourGrid(x, Y2, 2) = -10
NEXT
EXIT SUB
ELSE
IF x > (10 - LenShip) THEN EXIT SUB
FOR xc = x + 1 TO (LenShip - 1 + x)
IF YourGrid(xc, Y, 2) > 0 THEN EXIT SUB
NEXT
FOR Y2 = Y TO (LenShip - 1 + Y)
YourGrid(x, Y2, 2) = 0
NEXT
FOR X2 = x TO (LenShip - 1 + x)
YourGrid(X2, Y, 2) = -10
NEXT
EXIT SUB
END IF
END IF
NEXT
NEXT
END SUB
SUB ShowMessage (Text$)
FastString Text$, 15, 340, 70, SseriffFont()
Delay INT(LEN(Text$))
LINE (335, 65)-(335 + (10 * LEN(Text$)), 90), 2, BF
END SUB
SUB Test (HitFlag, Direction$)
SELECT CASE Direction$
CASE "up"
FOR x = 1 TO 9
FOR Y = 9 TO 1 STEP -1
IF YourGrid(x, Y - 1, 2) > 0 AND YourGrid(x, Y, 2) = -10 THEN
HitFlag = 1
EXIT SUB
END IF
NEXT
NEXT
CASE "down"
FOR x = 1 TO 9
FOR Y = 8 TO 1 STEP -1
IF YourGrid(x, Y + 1, 2) > 0 AND YourGrid(x, Y, 2) = -10 THEN
HitFlag = 1
EXIT SUB
END IF
NEXT
NEXT
CASE "left"
FOR x = 1 TO 8
FOR Y = 1 TO 9
IF YourGrid(x - 1, Y, 2) > 0 AND YourGrid(x, Y, 2) = -10 THEN
HitFlag = 1
EXIT SUB
END IF
NEXT
NEXT
CASE "right"
FOR x = 8 TO 1 STEP -1
FOR Y = 1 TO 9
IF YourGrid(x + 1, Y, 2) > 0 AND YourGrid(x, Y, 2) = -10 THEN
HitFlag = 1
EXIT SUB
END IF
NEXT
NEXT
END SELECT
END SUB
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.