| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| Are These Dots Spinning? |
|
Posted by: bplus - 02-15-2023, 08:38 PM - Forum: Programs
- Replies (6)
|
 |
Code: (Select All) _Title "Do the dots in disk look like they are spinning?" ' B+ 2019-01-12
'try an optical illusion saw on Internet
Const xmax = 600
Const ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 60
x0 = xmax / 2: y0 = ymax / 2: a24 = _Pi(2 / 24): r = 240
While _KeyHit <> 27
If loopcnt < 2 Then stopit = 11
If loopcnt = 2 Then stopit = 0
If loopcnt > 2 Then
If stopit < 11 Then stopit = stopit + 1
End If
For a = 0 To _Pi(2) Step _Pi / 180
Color _RGB32(128, 0, 0): fcirc x0, y0, 251
For i = 0 To stopit
If loopcnt > 1 Then
xs = x0 + r * Cos(a24 * i)
ys = y0 + r * Sin(a24 * i)
xe = x0 + r * Cos(a24 * i + _Pi)
ye = y0 + r * Sin(a24 * i + _Pi)
Line (xs, ys)-(xe, ye), _RGB32(255, 255, 255)
End If
x = x0 + Cos(a + _Pi(i / 12)) * r * Cos(a24 * i)
y = y0 + Cos(a + _Pi(i / 12)) * r * Sin(a24 * i)
Color _RGB32(255, 255, 255)
fcirc x, y, 10
Next
_Display
_Limit 90
Next
loopcnt = loopcnt + 1
Wend
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
No...
|
|
|
| Array in an array |
|
Posted by: NasaCow - 02-15-2023, 12:44 AM - Forum: Help Me!
- Replies (79)
|
 |
Happy Year of the Rabbit. Back to work and also back to programming. The holiday break was nice....
So I am trying to rack my head how to store this. Let me show what I have and then maybe someone can call me an idiot and point out an eaiser way of making everything work 
The gradebook:
![[Image: image.png]](https://i.ibb.co/DrSTs4K/image.png)
As we can see I am going for something a little more complicated than just enter numbers and call it a day. I want it to be flexiable. Able to add and drop students. Being pulled from the report side of the program
The student data:
Code: (Select All) TYPE NameListType 'Used for the student name database
PinYinName AS STRING * 20
FirstName AS STRING * 20
MiddleName AS STRING * 20
LastName AS STRING * 20
Year AS INTEGER
Month AS INTEGER
Day AS INTEGER
HouseColor AS STRING * 8
MomName AS STRING * 30
MomPhone AS STRING * 20 'Saved as string to support symbols and international prefixes
MomEmail AS STRING * 38
DadName AS STRING * 30
DadPhone AS STRING * 20
DadEmail AS STRING * 38
UID AS INTEGER
END TYPE
The key I believe is to have a unique id number for each student (UID), positive values will be current students and deleted students will have the value made negative. So we can keep grades with names by having the grade database match this one.
Ok so far....
This is where I run into trouble, one assignment, has details and many students with multiple details. How to combine?
Assignment file (Master):
Code: (Select All) TYPE MasterAssignmentType 'Each entry needs to be defined before use with slave
ARName AS STRING * 20 'Assignment report name
ADName AS STRING * 10 'Assignment display name (short name)
AType AS UNSIGNED BYTE 'Assignment Type (Completeion, formative, summative, etc.)
ACat AS STRING * 20 'Assignment Category (subject, unit, etc)
AColor AS UNSIGNED BYTE 'Color coding assignment headers and for grouping for reports
ACode AS UNSIGNED BYTE 'Reserved
APts AS UNSIGNED INTEGER 'Total points allowed
END TYPE
Slave file (for student details):
Code: (Select All) TYPE SlaveAssignmentType 'Each student would require one with use with master
UID AS INTEGER 'UID will match the stuedent name list to match results, negative UID means deleted and we will ignore it on display and reports
MPts AS UNSIGNED INTEGER 'Points earned for each particular students
Flags AS UNSIGNED BYTE 'See below for codes
Flags2 AS UNSIGNED BYTE ' Reserved
Notes AS STRING * 512 'Comments for a student's work
END TYPE
'====================Flag codes====================
'1 - Late (Turned in late) |
'2 - Absent on due date (ignore due date) |
'4 - Incomplete (turned in but not done) |
'8 - Missing (Not turned in) |
'16 - Excused/Exempt |
'32 - Ignore score internally for avg, etc. |
'64 - Remove from reports (ignore externally) |
'128 - Reserved |
'==================================================
Now this is where I am in trouble.
Now I could make a file for each student with the slave but that seems.... excesive. I tried to combine both with an array but, as far as I know, it doesn't work. I want to do something like SlaveFile (UIDs(40), 500) with 40 being for UIDs and 500 for the UDT SlaveFile (something like an array in an array or jagged array). I just don't know the context for this or the workaround to get what I want....
Tried it out in a smiple way and it doesn't work the way I thought it would
Code: (Select All) OPTION _EXPLICIT
TYPE Test
X AS INTEGER
y AS INTEGER
z AS STRING
END TYPE
TYPE UID
ID AS INTEGER
END TYPE
DIM AS INTEGER abc(1 TO 4)
DIM AS Test xyz(1 TO 10, abc())
abc(3) = 2
xyz(1, abc(1)).X = 5
xyz(1, abc(2)).y = 3
PRINT xyz(1, abc(1)).X
PRINT xyz(1, abc(2)).y
PRINT abc(3)
PRINT xyz(1, abc(4)).X
Like I said, there is likely a much easier way (I can be a stubborn Polock after all and make things more complicated than I need to!)
You guys are amazing and I look forward to your wisdom and advide!
|
|
|
|
| IDE for Windows like the official one? |
|
Posted by: Ikerkaz - 02-14-2023, 02:36 PM - Forum: General Discussion
- Replies (25)
|
 |
Hello to everyone.
It's just an idea. Would it be possible to build an IDE with auto tabbing and syntax checking, just like the official IDE but for Windows?
I'm not quite convinced by the current text-mode IDE, and Notepad++ doesn't have error checking and auto tabbing. Thanks and sorry for the question, I understand that the current IDE already has a lot of work done. I would not want to belittle the work of the creators.
|
|
|
|
| Recursion: 4 ways to get it working |
|
Posted by: TempodiBasic - 02-14-2023, 01:27 PM - Forum: Help Me!
- Replies (16)
|
 |
Hi
I think that this demo is clear enough to be used as example about recursion in QB64pe.
I must remark that the STATIC way has is goal in preserving the previouse values of variable of the SUB/FUNCTION.
So if we need to preserve few variables we can use STATIC into the SUB to declare the variable to preserve,
instead if we need to preserve all variable or the more part of local variables we use STATIC in SUB/FUNCTION declaration.
Code: (Select All) Rem Demonstration of variables into recursive calling
Screen 0
Dim counter As Single
Dim Shared counter2 As Single
Dim Choice As String
Choice = " "
Do
If Choice <> "" Then
Cls
Print "we are testing recursive calling"
Print String$(60, "#")
Print "please make your choice: "
Print " press 1 for recursion without parameter or shared variable"
Print " press 2 for recursion with parameter and no shared variable"
Print " press 3 for recursion with shared variable and no parameter"
Print " press 4 for STATIC recursion without parameter or shared variable"
Print " press 0 to exit from demonstration"
Print String$(60, "#")
End If
Choice = InKey$
If Choice = "0" GoTo Ending
If Choice = "1" Then GoSub NoParameters
If Choice = "2" Then GoSub YesParameters
If Choice = "3" Then GoSub SharedVariable
If Choice = "4" Then GoSub StaticNoParameters
Loop
End
NoParameters:
counter = 0
Print " No parameter and no shared variable demo"
Print "-----------------------------------------"
Print counter; " value of flag in the main"
RecursiveNoParameters
Return
YesParameters:
counter = 0
Print " Yes parameter and no shared variable demo"
Print "------------------------------------------"
Print counter; " value of flag in the main"
RecursiveYesParameters counter
Return
SharedVariable:
counter2 = 0
Print " No parameter and Yes shared variable demo"
Print "------------------------------------------"
Print counter2; " value of flag in the main"
SharedVariables
Return
StaticNoParameters:
counter = 0
Print " STATIC and no parameter and no shared variable demo"
Print "-----------------------------------------"
Print counter; " value of flag in the main"
StaticNoParameter
Return
Ending:
Rem here the flow of code ends
End
Sub RecursiveNoParameters
counter = counter + 1
DoJob counter
If InKey$ <> "" Then Exit Sub ' emergency exit
If counter < 10 Then RecursiveNoParameters
End Sub
Sub RecursiveYesParameters (c As Single)
c = c + 1
DoJob c
If InKey$ <> "" Then Exit Sub ' emergency exit
If c < 10 Then RecursiveYesParameters c
End Sub
Sub SharedVariables
counter2 = counter2 + 1
DoJob counter2
If InKey$ <> "" Then Exit Sub ' emergency exit
If counter2 < 10 Then SharedVariables
End Sub
Sub StaticNoParameter
Static counter ' you need to have STATIC only the flag of recursion, at least
counter = counter + 1
DoJob counter
If InKey$ <> "" Then Exit Sub ' emergency exit
If counter < 10 Then StaticNoParameter
End Sub
Sub DoJob (c As Single)
Print c; " press a key to stop the recursive loop"
Sleep 1 ' we need this to avoid the crash of application
End Sub
more explanation and tips coming soon.
|
|
|
|
| Square brackets and curly brackets in expressions? |
|
Posted by: CharlieJV - 02-13-2023, 05:49 PM - Forum: QBJS, BAM, and Other BASICs
- Replies (12)
|
 |
I'm thinking of adding the ability to use curly brackets and square brackets in expressions, along with parentheses, to make complex expressions easier to read.
But not if square brackets (i.e. [ and ] ) and curly brackets (i.e. { and } ) are used in any way as special characters in QB64pe.
Are square brackets and/or curly brackets used for any purpose in QB64pe? (I haven't noticed any.)
|
|
|
|
| Smarter than a fb Worm |
|
Posted by: bplus - 02-13-2023, 05:44 PM - Forum: Programs
- Replies (4)
|
|
This snake never goes hungry:
Code: (Select All) _Title "Snake AI-1.1" 'b+ 2020-03-16
'2020-03-14 Snake AI-1 first post
'2020-03-16 Snake AI-1.1 there must be overlap of the snake somewhere!
Const sq = 20, sqs = 20, xmax = 400, ymax = 400
Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle
Randomize Timer
Dim X(xmax + 100), Y(ymax + 100), overlap(19, 19) As Integer
hx = 10: hy = 10: ax = 15: ay = 15: top = 0: X(top) = hx: Y(top) = hy 'initialize
Do
_Title Str$(top + 1)
Line (0, 0)-(xmax, ymax), &HFF006600, BF 'clear garden
'>>>>>>>>>>> SNAKE BRAIN <<<<<<<<<<<<<<<
If hx = 0 And hy = 19 Then
hy = hy - 1
ElseIf hx Mod 2 = 0 And hy <> 0 And hy <> 19 Then
hy = hy - 1
ElseIf hx Mod 2 = 0 And hy = 0 And hy <> 19 Then
hx = hx + 1
ElseIf hx Mod 2 = 1 And hx <> 19 And hy < 18 Then
hy = hy + 1
ElseIf hx Mod 2 = 1 And hx <> 19 And hy = 18 Then
hx = hx + 1
ElseIf hx = 19 And hy = 19 Then
hx = hx - 1
ElseIf hy = 19 And hx <> 0 Then
hx = hx - 1
ElseIf hx Mod 2 = 1 And hy = 0 And hy <> 19 Then
hy = hy + 1
ElseIf hx = 19 And hy < 19 Then
hy = hy + 1
End If
For i = 0 To top - 1
X(i) = X(i + 1): Y(i) = Y(i + 1)
Next
X(top) = hx: Y(top) = hy
'apple
If (ax = hx And ay = hy) Then 'snake eats apple, get new apple watch it's not where snake is
top = top + 1
X(top) = hx: Y(top) = hy
Do 'check new apple
ax = Int(Rnd * sqs): ay = Int(Rnd * sqs): good = -1
For i = 0 To top - 1
If ax = X(i) And ay = Y(i) Then good = 0: Exit For
Next
Loop Until good
End If
Line (ax * sq, ay * sq)-Step(sq - 2, sq - 2), _RGB32(255, 100, 255), BF
'snake
Erase overlap
For i = 0 To top
If i = top Then
c~& = &HFF000000
Else
Select Case (top - i) Mod 4
Case 0: c~& = &HFF000088
Case 1: c~& = &HFF880000
Case 2: c~& = &HFFBB8800
Case 3: c~& = &HFF008888
End Select
End If
overlap(X(i), Y(i)) = overlap(X(i), Y(i)) + 1
Line (X(i) * sq, Y(i) * sq)-Step(sq - 2, sq - 2), c~&, BF
If overlap(X(i), Y(i)) > 1 Then Line (X(i) * sq + .25 * sq, Y(i) * sq + .25 * sq)-Step(.5 * sq - 2, .5 * sq - 2), &HFFFFFFFF, BF
Next
_Display
If top < 10 Then
_Limit 10 + top
ElseIf top < 300 Then
_Limit 100
Else
_Limit 10
End If
Loop
And it's the dumbest snake I have!
|
|
|
|
| String to Array |
|
Posted by: AtomicSlaughter - 02-13-2023, 10:31 AM - Forum: Utilities
- Replies (1)
|
 |
A Handy piece of code that will split a string into an array.
Code: (Select All) Sub StringSplitter (ST As String, AR() As String, DL As String)
Dim Delim(Len(DL)) As String
For i = 1 To Len(DL)
Delim(i) = Mid$(DL, i, 1)
Next
c = 1
Do
For i = 1 To UBound(Delim)
If Mid$(ST, c, 1) = Delim(i) Then
ReDim _Preserve AR(UBound(AR) + 1)
c = c + 1
Exit For
End If
Next i
AR(UBound(AR)) = AR(UBound(AR)) + Mid$(ST, c, 1)
c = c + 1
Loop Until c > Len(ST)
End Sub
|
|
|
|
FBCWIN - Wormer |
|
Posted by: mnrvovrfc - 02-13-2023, 01:41 AM - Forum: QBJS, BAM, and Other BASICs
- No Replies
|
 |
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 Sub
Boards 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: 88)
|
|
|
|
|
