+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: QBJS, BAM, and Other BASICs (https://staging.qb64phoenix.com/forumdisplay.php?fid=50)
+--- Thread: FBCWIN - Wormer (/showthread.php?tid=1468)
FBCWIN - Wormer - mnrvovrfc - 02-13-2023
Have at it. It's "Wormer", a clone of "Nibbles" or "Snake" or something else. IT'S IN FREEBASIC. Sorry I don't have the motivation to port it to QB64 but it should be easy enough for someone else.
Code: (Select All)
'by mnrvovrfc May-2014
#Include "fbmessage.bi"
#Include "util.bi"
#Include "truecolr256.bi"
#Include "file.bi"
Enum namesprites
wormhead = 1
wormbody = 5
wormvanish = 7
wallsolid = 9
wormfood = 13
wormnumeral = 17
wormletters = 27
wormportal = 49
wormevil
wormheart = 54
lastsprite = 55
End Enum
Enum nameicon
noicon = 0
iconwall
iconworm
iconfood
iconshrink
iconportal
End Enum
Type charpgtype
As Integer x, y, xi, yi, s, c
End Type
Const thewallcolor = RGB(255, 255, 255), theshrinkcolor = RGB(255, 0, 0), theportalcolor = RGB(0, 255, 0)
Const thewormcolor = RGB(0, 0, 255)
Declare Sub PrintFancyMessage(which As Integer)
Declare Sub DrawWalls()
Declare Sub Drawcharpg()
Declare Function CheckIcon(x As Integer, y As Integer, actual As Integer = 0) As nameicon
Declare Sub SetIcon(x As Integer, y As Integer, valu As nameicon)
Declare Sub Centertext(ro As Integer, tx As string)
Dim Shared As nameicon icon(1 To 53, 1 To 40)
Dim Shared As Any Ptr spr(1 To lastsprite)
Dim Shared As charpgtype cw(1 To 100), cj(1 To 10), mv(1 To 16)
Dim As Any Ptr s1, s2
Dim As String curp, bmpfile, nameprog
Dim As Integer i, j, u, x, y, z, resu
nameprog = "Wormer (Nibbles)"
curp = ExePath() + "\"
bmpfile = curp + "wormer.bmp"
If FileExists(bmpfile) = 0 Then
fb_message(nameprog, "File not found:" + Chr(13) + bmpfile, MB_ICONERROR)
End 1
EndIf
Randomize
ScreenRes 640, 480, 32
WindowTitle nameprog
s1 = ImageCreate(96, 96)
s2 = ImageCreate(53, 40)
resu = BLoad(bmpfile, s1)
z = 1
For j = 0 To 7
For i = 0 To 7
spr(z) = ImageCreate(12, 12)
Get s1, (i * 12, j * 12)-Step(11, 11), spr(z)
z += 1
Next
Next
Dim Shared As Integer thiswall, lengthworm
Dim As Integer died, done, wormspeed, score, bonus, lvl, numworm, hits
Dim As Integer whead, refreshwall, numfood, startother, portalrestore, maxmove, fl
Dim As Integer onfreelife
Dim As String ke, lvlbmpfile
Color smalt, khaki
Cls
lvl = 1: fl = 0
Centertext(12, "Wormer -- A Crude Version of Nibbles")
Centertext(15, "Press [ESC] at any time to quit.")
Centertext(18, "Some levels have portals.")
Centertext(21, "Others have patrolling robots.")
Centertext(24, "The worm dies if it strikes a part of itself,")
Centertext(25, "a wall or one of the robots.")
Centertext(28, "Use your arrow keys for movement.")
Centertext(31, "If your score is at least 4,")
Centertext(32, "Press [ENTER] during game play to view it briefly.")
Centertext(38, "Use [UP] and [DOWN] arrow keys to change level, [ENTER] to select.")
Centertext(40, "What level do you want to begin play?")
Centertext(42, "Level = 1")
Do
ke = InKey()
If Len(ke) > 1 Then
ke = Right(ke, 1)
Select Case ke
Case "H"
If lvl < 36 Then lvl += 1: fl = 1
Case "P"
If lvl > 1 Then lvl -= 1: fl = 1
End Select
EndIf
If fl = 1 Then
fl = 0
Centertext(42, " Level = " + Str(lvl) + " ")
EndIf
Sleep(100, 1)
Loop Until (ke = Chr(13)) Or (ke = Chr(27))
If ke = Chr(27) Then GoTo pend
Centertext(47, "At what speed to you want to play?")
Centertext(49, "(1) = slow, (2) = fast, (3) = quick")
Do: ke = InKey(): Loop Until ke = ""
Do
ke = InKey()
If (ke = "1") Or (ke = "2") Or (ke = "3") Then Exit Do
Sleep(100, 1)
Loop Until (ke = Chr(13)) Or (ke = Chr(27))
If ke = Chr(27) Then GoTo pend
If ke = Chr(13) Then ke = "1"
wormspeed = (52 - Asc(ke)) * 50
done = 0
numworm = 6
score = 0: bonus = 0
thiswall = Rand(wallsolid, wormfood - 1)
hits = 0
If lvl > 15 Then onfreelife = 1 Else onfreelife = 0
Do ''until done, main program loop
Color , 0
Cls
refreshwall = 1
lengthworm = 4
died = 0
portalrestore = 0
Erase cw, cj
lvlbmpfile = curp + "wormer" + PadZero(lvl, 2) + ".BMP"
If FileExists(lvlbmpfile) = 0 Then
fb_message(nameprog, "BMP file not found for level " + Str(lvl) + "!", MB_ICONERROR)
End 4
EndIf
resu = BLoad(lvlbmpfile, s2)
u = 0
For i = 1 To 53
For j = 1 To 40
If u > 0 Then u += 1
z = Point(i - 1, j - 1, s2)
Select Case z
Case thewallcolor
icon(i, j) = iconwall
Case theshrinkcolor
icon(i, j) = iconshrink
Case theportalcolor
icon(i, j) = iconportal
Case thewormcolor
If u = 0 Then
u = 1
cw(1).x = i * 12 - 12: cw(1).y = j * 12 - 12
ElseIf u = 2 Then
cw(1).xi = 0: cw(1).yi = 12
whead = wormhead + 3
Else
cw(1).xi = 12: cw(1).yi = 0
whead = wormhead
EndIf
icon(i, j) = noicon
Case Else
icon(i, j) = noicon
End Select
Next
Next
With cw(1)
.s = whead
x = .x
y = .y
End With
Select Case lvl
Case 1, 2, 3, 4
numfood = 2
startother = 0
Case 5, 6, 7, 9, 11 To 14, 16
numfood = 3
startother = 0
Case 8, 10
numfood = 3
startother = 9
Case 15
numfood = 3
startother = 8
Case 17
numfood = 4
startother = 7
Case 18 To 22
numfood = 4
startother = 0
Case 23, 24
numfood = 5
startother = 0
Case 25
numfood = 5
startother = 7
Case 26
numfood = 5
startother = 9
Case 27 To 29
numfood = 6
startother = 0
Case 30, 33
numfood = 4
startother = 10
Case 31, 32, 34
numfood = 3
startother = 9
Case 35, 36
numfood = 2
startother = 0
End Select
#Include "wormer.bi"
For j = 2 To lengthworm
cw(j).x = x
cw(j).y = y
cw(j).s = whead
x -= cw(1).xi
y -= cw(1).yi
Next
z = 0
For i = 1 To numfood
With cj(i)
.x = 0: .y = 0: .s = 0 ''position (x, y) and food type
.xi = 0 ''number of steps to remain on screen (.c greater than zero)
.yi = 0 ''not used
.c = z ''total number of steps (if negative, food not activated yet)
End With
If i > 1 Then z -= Random1(20) * 10
Next
cj(1).c = z
If (lvl >= 8) And (startother > 0) Then
z = startother
For j = 1 To 40
For i = 1 To 53
If icon(i, j) = iconportal Then
With cj(z)
.x = i * 12 - 12
.y = j * 12 - 12
If lvl < 30 Then
.s = wormportal
Else
icon(i, j) = noicon
.s = wormevil ''sprite indicate it's a bad guy
.c = 0 ''pointer into mv()
.xi = 100 ''current step to take
.yi = 0 ''animation flag
EndIf
End With
z += 1
EndIf
Next
Next
If lvl = 32 Then
Swap cj(9), cj(10)
EndIf
EndIf
PrintFancyMessage(2)
Do
ke = InKey()
Loop Until (ke = "") Or (ke = Chr(27))
If ke = Chr(27) Then done = 1: Exit Do
Do
ke = InKey()
If Len(ke) = 2 Then
ke = Right(ke, 1)
Select Case ke
Case "k"
done = 1
Exit Do
Case "H"
If cw(1).yi = 0 Then cw(1).xi = 0: cw(1).yi = -12: whead = 2
Case "K"
If cw(1).xi = 0 Then cw(1).yi = 0: cw(1).xi = -12: whead = 3
Case "M"
If cw(1).xi = 0 Then cw(1).yi = 0: cw(1).xi = 12: whead = 1
Case "P"
If cw(1).yi = 0 Then cw(1).xi = 0: cw(1).yi = 12: whead = 4
End Select
Else
Select Case ke
Case Chr(13)
If score > 3 Then
PrintFancyMessage(score)
refreshwall = 1
EndIf
Case Chr(27)
done = 1
Exit Do
End Select
EndIf
With cw(lengthworm)
Line(.x, .y)-Step(11, 11), 0, BF
SetIcon(.x, .y, noicon)
End With
If (cw(1).s = 1) Or (cw(1).s = 3) Then
cw(1).s = wormbody + 1
Else
cw(1).s = wormbody
EndIf
For j = lengthworm - 1 To 1 Step -1
i = j + 1
cw(i) = cw(j)
Next
With cw(1)
.x += .xi
.y += .yi
If .s <> whead Then .s = whead
If .x < 0 Then .x = 624
If .x > 624 Then .x = 0
If .y < 0 Then .y = 468
If .y > 468 Then .y = 0
z = CheckIcon(.x, .y)
If (z = iconwall) Or (z = iconworm) Then died = 1
If z = iconportal Then
For j = startother To 10
If (cj(j).x = .x) And (cj(j).y = .y) Then Exit For
Next
If j <= 10 Then
If startother = 9 Then
If j = 9 Then i = 10 Else i = 9
Else
Do
i = Rand(startother, 10)
Loop While i = j
EndIf
.x = cj(i).x
.y = cj(i).y
portalrestore = lengthworm + 2
EndIf
ElseIf z = iconshrink Then
If lengthworm > 4 Then
bonus = bonus \ 2
u = Random1(2) * 4
Do While (u > 0) And (lengthworm > 4)
With cw(lengthworm)
SetIcon(.x, .y, noicon)
Line(.x, .y)-Step(11, 11), 0, BF
lengthworm -= 1
u -= 1
End With
Loop
EndIf
Else
SetIcon(.x, .y, iconworm)
EndIf
End With
For i = 1 To numfood
If cj(i).s > 0 Then
With cj(i)
.c += 1
If .c > .xi Then
.c = Random1(20) * -10
.s = 0
SetIcon(.x, .y, noicon)
Line(.x, .y)-Step(11, 11), 0, BF
ElseIf (.x = cw(1).x) And (.y = cw(1).y) Then
If .s = wormheart Then
numworm += 1
bonus += 1
Else
x = .s - wormfood + 1
If bonus = 0 Then bonus = 1 Else bonus += (x \ 4)
score += bonus
hits += 1
If lengthworm <= 100 Then
x *= 4
Do While x > 0
If portalrestore > 0 Then portalrestore += 1
lengthworm += 1
x -= 1
cw(lengthworm) = cw(lengthworm - 1)
Loop
EndIf
EndIf
.c = Random1(20) * -10
.s = 0
SetIcon(.x, .y, noicon)
EndIf
End With
Else
With cj(i)
.c += 1
If .c > 0 Then
If (i = 1) And (onfreelife > 0) Then
onfreelife = 0
.s = wormheart
.xi = 100
Else
y = Random1(20)
.s = wormfood
.xi = 200
Select Case y
Case 1
.s += 3
.xi = 100
Case 2, 3
.s += 2
.xi = 100
Case 4, 5, 6
.s += 1
.xi = 100
End Select
EndIf
Do
.x = Random1(51) + 1
.y = Random1(38) + 1
Loop Until CheckIcon(.x, .y, 1) = noicon
icon(.x, .y) = iconfood
.x = .x * 12 - 12
.y = .y * 12 - 12
EndIf
End With
EndIf
Next
If (lvl >= 30) And (lvl < 35) Then
For i = startother To 10
With cj(i)
If .c = 0 Then u = 100 Else u = mv(.c).c
.xi += 1
If .xi > u Then
.xi = 0
Do
.c += 1
If .c > maxmove Then .c = 1
Loop Until mv(.c).s = i
EndIf
Line(.x, .y)-Step(11, 11), 0, BF
.x = .x + mv(.c).xi
.y = .y + mv(.c).yi
If .y < 0 Then .y = 468
If .y > 468 Then .y = 0
If .x < 0 Then .x = 624
If .x > 624 Then .x = 0
.yi = Not .yi
If CheckIcon(.x, .y) = iconworm Then died = 1
End With
Next
ElseIf portalrestore > 0 Then
portalrestore -= 1
If portalrestore < 1 Then
For j = startother To 10
With cj(j)
SetIcon(.x, .y, iconportal)
End With
Next
EndIf
EndIf
''------------------------------------------------
If refreshwall > 0 Then
refreshwall = 0
DrawWalls()
EndIf
Drawcharpg()
Sleep(wormspeed, 1)
Loop Until (died > 0) Or (hits > 10) Or (done > 0)
If done > 0 Then
''[ESC] was pressed, quit main program loop
ElseIf died > 0 Then
For j = wormvanish To wallsolid
With cw(1)
Line(.x, .y)-Step(11, 11), 0, BF
If j < wallsolid Then Put(.x, .y), spr(j), Trans
End With
Sleep(100, 1)
Next
PrintFancyMessage(3)
numworm -= 1
If numworm < 1 Then
Do
PrintFancyMessage(1)
ke = InKey()
If ke = Chr(27) Then done = 1: Exit Do
PrintFancyMessage(score)
ke = InKey()
If ke = Chr(27) Then done = 1
Loop Until done > 0
Else
Color RGB(128, 255, 192)
Locate 28, 28: Print "Please press any key...";
Do: ke = InKey(): Loop Until ke = ""
Sleep
If bonus > 1 Then bonus -= 1
EndIf
ElseIf hits > 10 Then
lvl += 1
If lvl > 36 Then
Color smalt, khaki
Cls
Centertext(12, "There are no more levels.")
Centertext(18, "You won the game, congratulations!")
Centertext(24, "Score: " + Str(score))
Centertext(32, "Press [ESC] to quit the program.")
Do: ke = InKey(): Loop Until ke = Chr(27)
done = 1
EndIf
thiswall = Rand(wallsolid, wormfood - 1)
hits = 0
If lvl > 15 Then onfreelife = 1 Else onfreelife = 0
EndIf
Loop Until done > 0 ''end of main program loop
pend:
For z = 1 To lastsprite
ImageDestroy(spr(z))
Next
ImageDestroy(s2)
ImageDestroy(s1)
End
Sub PrintFancyMessage(which As Integer)
Dim As UByte Ptr ndx
Dim As String * 10 mesg
Dim As String ke
Dim As Integer j, c, x = 264
Select Case which
Case 1: mesg = Chr(33, 34, 35, 36, 48, 37, 38, 36, 39, 32) ''Game Over!
Case 2: mesg = Chr(33, 36, 27, 48, 28, 36, 34, 29, 40, 32) ''Get Ready!
Case 3: mesg = Chr(41, 42, 30, 48, 43, 44, 36, 29, 32, 48) ''You Died!
Case Else ''Score:0000
mesg = Chr(45, 46, 42, 39, 36, 47)
ke = Str(which)
If which < 1000 Then mesg &= "0"
If which < 100 Then mesg &= "0"
If which < 10 Then mesg &= "0"
For j = 1 To Len(ke)
c = Asc(ke, j) - 32
If c < 17 Then c += 10
mesg &= Chr(c)
Next
End Select
Line(264, 216)-Step(120, 11), 0, BF
ndx = StrPtr(mesg)
For j = 0 To 9
Put(x, 216), spr(ndx[j]), Trans
x += 12
Next
Sleep(3000, 1)
Line(264, 216)-Step(120, 11), 0, BF
End Sub
Sub DrawWalls()
Dim As Integer i, j
Cls
For i = 1 To 53
For j = 1 To 40
Select Case icon(i, j)
Case iconwall
Put(i * 12 - 12, j * 12 - 12), spr(thiswall), Trans
End Select
Next
Next
End Sub
Sub Drawcharpg()
Dim As Integer j, u
For j = 1 To 10
If cj(j).s > 0 Then
With cj(j)
If (.s >= wormevil) And (.s < wormheart) Then
If (.xi < 0) Or (.yi < 0) Then u = .s + (2 - .yi) Else u = .s + (-1 * .yi)
Put(.x, .y), spr(u), Trans
Else
Put(.x, .y), spr(.s), Trans
EndIf
End With
EndIf
Next
For j = lengthworm To 1 Step -1
With cw(j)
If .s > 0 Then
Put(.x, .y), spr(.s), Trans
EndIf
End With
Next
End Sub
Function CheckIcon(x As Integer, y As Integer, actual As Integer = 0) As nameicon
Dim As Integer px, py
If actual > 0 Then
px = x: py = y
Else
px = x \ 12 + 1: py = y \ 12 + 1
EndIf
Return icon(px, py)
End Function
Sub SetIcon(x As Integer, y As Integer, valu As nameicon)
Dim As Integer px, py
px = x \ 12 + 1: py = y \ 12 + 1
icon(px, py) = valu
End Sub
Sub Centertext(ro As Integer, tx As string)
Dim As Integer lx
lx = Len(tx)
If lx > 0 Then
lx = 40 - (lx \ 2)
Locate ro, lx
Print tx;
EndIf
End SubBoards could be created but have to follow specific dimensions and pixel colors. Each pixel is a "big" position on the screen, ie. the snake's body part, food, wall etc. The snake could wrap around from one side of the screen to another unless the wall stops it. There are many other things to discover that I'm not going to reveal. Oh well the instructions near the top of the source code give away a lot already but not playing the game would miss it.
This program should compile without problems with Freebasic as GUI program for Windows. It has no sound. For Linux the "fb_message()" would have to be removed, call "exec()" instead to bring about a dialog box from "yad", "zenity" or other such utility.
All BMP files are required except "wormer-empty.bmp", that one exists to help the user create a new one out of it for the game.
mnrvovrfc-wormer.zip (Size: 18.57 KB / Downloads: 28)