Fishing anyone?

[bplus]

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 Sub

Nice underwater effect with kelp.

[Pete]

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

[mnrvovrfc]

"LTail$" and "RTail$" aren't the opposite of one another. Maybe change to "greater-than" sign for "LTail$"?

[TerryRitchie]

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.

[bplus]

Right!  LTail$ = ">{"

Nice catch!

[Pete]

LOL@Nice catch! Makes me think you might be fishing for compliments. + 1.

Pete

[vince]

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

[SierraKen]

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.

[Pete]

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

[bplus]

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