+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Fishing anyone? (/showthread.php?tid=947)
Pages:
1
2
Fishing anyone? - bplus - 10-04-2022
Look what I found, anyone up for some fishing?
Code: (Select All)
Option _Explicit
_Title " Fish: press m for more, l for less" 'b+ 2021-12-03
Const sw = 1024, sh = 700, LHead$ = "<*", LBody$ = ")", LTail$ = "<{", RHead$ = "*>", RBody$ = "(", RTail$ = "}<"
Type fish
As Integer LFish, X, Y, DX
As String fish
As _Unsigned Long Colr
End Type
Screen _NewImage(sw, sh, 32)
_ScreenMove 180, 40
_FullScreen ' <<<<<<<<<<<<<<< goto full screen once you know instructions for more and less fish
Color _RGB32(220), _RGB32(0, 0, 60)
Cls
_PrintMode _KeepBackground
Dim As Integer i, nFish
Dim k$
nFish = 20
restart:
ReDim Shared school(1 To nFish) As fish, kelp(sw, sh) As _Unsigned Long
growKelp
For i = 1 To nFish
NewFish i, -1
Next
Do
Cls
k$ = InKey$
If k$ = "m" Then ' more fish
nFish = nFish * 2
If nFish > 300 Then Beep: nFish = 300
GoTo restart
End If
If k$ = "l" Then ' less fish
nFish = nFish / 2
If nFish < 4 Then Beep: nFish = 4
GoTo restart
End If
For i = 1 To nFish ' draw fish behind kelp
If _Red32(school(i).Colr) < 160 Then
Color school(i).Colr
_PrintString (school(i).X, school(i).Y), school(i).fish 'draw fish
school(i).X = school(i).X + school(i).DX
If school(i).LFish Then
If school(i).X + Len(school(i).fish) * 8 < 0 Then NewFish i, 0
Else
If school(i).X - Len(school(i).fish) * 8 > _Width Then NewFish i, 0
End If
End If
Next
showKelp
For i = 1 To nFish ' draw fish in from of kelp
If _Red32(school(i).Colr) >= 160 Then
Color school(i).Colr
_PrintString (school(i).X, school(i).Y), school(i).fish 'draw fish
school(i).X = school(i).X + school(i).DX
If school(i).LFish Then
If school(i).X + Len(school(i).fish) * 8 < 0 Then NewFish i, 0
Else
If school(i).X - Len(school(i).fish) * 8 > _Width Then NewFish i, 0
End If
End If
Next
_Display
_Limit 10
Loop Until _KeyDown(27)
Sub NewFish (i, initTF)
Dim gray
gray = Rnd * 200 + 55
school(i).Colr = _RGB32(gray) ' color
If Rnd > .5 Then
school(i).LFish = -1
school(i).fish = LHead$ + String$(Int(Rnd * 5) + -2 * (gray > 160) + 1, LBody$) + LTail$
Else
school(i).LFish = 0
school(i).fish = RTail$ + String$(Int(Rnd * 5) + -2 * (gray > 160) + 1, RBody$) + RHead$
End If
If initTF Then
school(i).X = _Width * Rnd
Else
If school(i).LFish Then school(i).X = _Width + Rnd * 35 Else school(i).X = -35 * Rnd - Len(school(i).fish) * 8
End If
If gray > 160 Then
If school(i).LFish Then school(i).DX = -18 * Rnd - 3 Else school(i).DX = 18 * Rnd + 3
Else
If school(i).LFish Then school(i).DX = -6 * Rnd - 1 Else school(i).DX = 6 * Rnd + 1
End If
school(i).Y = _Height * Rnd
End Sub
Sub growKelp
Dim kelps, x, y, r
ReDim kelp(sw, sh) As _Unsigned Long
kelps = Int(Rnd * 20) + 20
For x = 1 To kelps
kelp(Int(Rnd * sw / 8), (sh - 16) / 16) = _RGB32(0, Rnd * 128, 0)
Next
For y = sh / 16 To 0 Step -1
For x = 0 To sw / 8
If kelp(x, y + 1) Then
r = Int(Rnd * 23) + 1
Select Case r
Case 1, 2, 3, 18 '1 branch node
If x - 1 >= 0 Then kelp(x - 1, y) = kelp(x, y + 1)
Case 4, 5, 6, 7, 8, 9, 21 '1 branch node
kelp(x, y) = kelp(x, y + 1)
Case 10, 11, 12, 20 '1 branch node
If x + 1 <= sw Then kelp(x + 1, y) = kelp(x, y + 1)
Case 13, 14, 15, 16, 17, 19 '2 branch node
If x - 1 >= 0 Then kelp(x - 1, y) = kelp(x, y + 1)
If x + 1 <= sw Then kelp(x + 1, y) = kelp(x, y + 1)
End Select
End If
Next
Next
End Sub
Sub showKelp
Dim y, x
For y = 0 To sh / 16
For x = 0 To sw / 8
If kelp(x, y) Then
Color kelp(x, y)
_PrintString (x * 8, y * 16), Mid$("kelp", Int(Rnd * 4) + 1, 1)
End If
Next
Next
End SubNice underwater effect with kelp.
RE: Fishing anyone? - Pete - 10-04-2022
Kelp me out here, how do I catch them? On second thought, I'm in the camp of the worst day coding beats the best day fishing. Ah, but as far as the visual effects go, weirdly spot on. It actually looks like a real kelp field. How'd you come up with the idea? Oh, and feed the fish, they look a bit bony.
Pete
RE: Fishing anyone? - mnrvovrfc - 10-04-2022
"LTail$" and "RTail$" aren't the opposite of one another. Maybe change to "greater-than" sign for "LTail$"?
RE: Fishing anyone? - TerryRitchie - 10-04-2022
Now that was impressive. Those who can program using ASCII characters for things such as this has always amazed me. Outstanding kelp field as Pete said.
RE: Fishing anyone? - bplus - 10-04-2022
Right! LTail$ = ">{"
Nice catch!
RE: Fishing anyone? - Pete - 10-04-2022
LOL@Nice catch! Makes me think you might be fishing for compliments. + 1.
Pete
RE: Fishing anyone? - vince - 10-05-2022
(10-04-2022, 01:13 AM)Pete Wrote: It actually looks like a real kelp field. How'd you come up with the idea?
yeah, it's pretty impressive looking, seems to accurately predict natural kelp shapes, a whole new kind of science I think
RE: Fishing anyone? - SierraKen - 10-05-2022
LOL Awesome B+! It's almost just like your original Underwater Medication Aquarium you made a few years ago, which I still have. You should post it here, or I can if you want. It's only one extra file with the sound.
RE: Fishing anyone? - Pete - 10-05-2022
(10-05-2022, 11:47 PM)SierraKen Wrote: LOL Awesome B+! It's almost just like your original Underwater Medication Aquarium you made a few years ago, which I still have. You should post it here, or I can if you want. It's only one extra file with the sound.
I think you meant "Meditation" there, Ken. Or does bplus have something growing in that aquarium other than just kelp?
Pete
RE: Fishing anyone? - bplus - 10-06-2022
Some would have it that meditation is medication.
Code: (Select All)
_Title "3-6-9 Tesla Breathing Sit up straight relaxed alertness" ' B+ 2020-05-19
Screen _NewImage(600, 300, 32)
_Delay .25
_ScreenMove _Middle
'_FULLSCREEN
cText 300, 150, 32, &HFFFFFF00, "Prep: quick exhale"
_Delay 4
lim = 1
l = -1
l2 = 1
Do
Cls
If l <= 2 Then
cText 300, 150, 32, &HFFFF3633, "To 3, Quick Deep Inhale" + Str$(l + 1)
ElseIf l > 2 And l <= 8 Then
cText 300, 150, 32, &HFF006900, "To 6, H o l d . . ." + Str$(l - 2)
ElseIf l > 8 Then
cText 300, 150, 32, &HFF440066, "To 9, S l o w E x h a l e " + Str$(l - 8)
End If
_Display
_Limit lim
l = (l + 1) Mod 18
If l2 Mod 162 = 0 Then lim = lim - .02
l2 = l2 + 1
Loop
Sub cText (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, cur&, I&, mult, xlen
fg = _DefaultColor
'screen snapshot
cur& = _Dest
I& = _NewImage(8 * Len(txt$), 16, 32)
_Dest I&
Color K, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), txt$
mult = textHeight / 16
xlen = Len(txt$) * 8 * mult
_PutImage (x - .5 * xlen, y - .5 * textHeight)-Step(xlen, textHeight), I&, cur&
Color fg
_FreeImage I&
End Sub