Proggies

[bplus]

don't put off to tomorrow what you can do today

Flame On 2

Code: (Select All)

_Title "Flame on 2, press spacebar for new background color" ' by bplus 2017-11-23
' flame on.bas SmallBASIC 0.12.9 (B+=MGA) 2017-11-22
' 2024-06-20 mod palette to blend with background

Const xmax = 800
Const ymax = 600
Dim back~&

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 60 'adjust as needed _MIDDLE needs a delay .5 or more for me

xxmax = 400: yymax = 150 'pixels too slow
xstep = xmax / xxmax: ystep = ymax / yymax
Dim p~&(300) 'pallette

restart:
back~& = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
cAnalysis back~&, red, green, blu, alph
For i = 1 To 100
    fr = 240 * i / 100 + 15
    If i < 50 Then p~&(i) = midInk~&(red, green, blu, fr, 0, 0, i / 100) Else p~&(i) = _RGB(fr, 0, 0)
    p~&(i + 100) = _RGB(255, fr, 0)
    p~&(i + 200) = _RGB(255, 255, fr)
Next
ReDim f(xxmax, yymax + 2) 'fire array and seed
For x = 0 To xxmax
    f(x, yymax + 1) = Int(Rnd * 2) * 300
    f(x, yymax + 2) = 300
Next
Color , back~&
While _KeyDown(32) = 0 'main fire
    Cls
    For x = 1 To xxmax - 1 'shift fire seed a bit
        r = Rnd
        If r < .15 Then
            f(x, yymax + 1) = f(x - 1, yymax + 1)
        ElseIf r < .3 Then
            f(x, yymax + 1) = f(x + 1, yymax + 1)
        ElseIf r < .35 Then
            f(x, yymax + 1) = Int(Rnd * 2) * 300
        End If
    Next
    For y = 0 To yymax 'fire based literally on 4 pixels below it like cellular automata
        For x = 1 To xxmax - 1
            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
            Line (x * xstep, y * ystep)-Step(xstep, ystep), p~&(f(x, y)), BF
        Next
    Next
    _Display
Wend
GoTo restart:

Function max (a, b)
    If a > b Then max = a Else max = b
End Function
Function midInk~& (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    midInk~& = _RGB32(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
End Function
Sub cAnalysis (c As _Unsigned Long, outRed, outGrn, outBlu, outAlp)
    outRed = _Red32(c): outGrn = _Green32(c): outBlu = _Blue32(c): outAlp = _Alpha32(c)
End Sub

edit i changed my mind to black smoke instead of white, no pope today

[bplus]

+1 @dbox looks good!

we need some marshmallows

[bplus]

Ohio's Heat Lightning

inspired sometime ago

Code: (Select All)

'recurring lightning w Fade.bas for QB64 fork 2017-08-23
'translated from: recurring lightning.bas for SmallBASIC 0.12.9 2017-08-22
'translated from: recurring lightning.txt for JB (B+=MGA) 2017-08-21
'2017-10-10 fade by TylerDarko and Branching Lightning by RhoSigma

Randomize Timer
Const xmax = 800
Const ymax = 600
Const FORKINESS = 15 '1 to 20
Const FREQUENCY = 3 '1 to 15

Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_Title "Recurring Branching Lightning with Fade"

land& = _NewImage(xmax, ymax, 32)
_Dest land&
drawLandscape
_Dest 0
rpause = 55
While 1
    _PutImage , land&, 0
    If Int(Rnd(1) * 100) > 50 Then
        DrawLightning Int(Rnd(1) * (xmax / 2)), 0, 50, 0.785398163, 1
    Else
        DrawLightning (xmax / 2) + Int(Rnd(1) * ((xmax / 2) - 1)), 0, 50, 2.35619449, 1
    End If
    Color _RGB(128, Rnd * 55 + 200, Rnd * 55 + 200)
    _Delay rpause / 1000 '<< adjust time as needed for your system
    s! = Timer
    rpause = rand&&(80, 2500)
    Do
        Line (0, 0)-(_Width, _Height), _RGBA32(0, 0, 0, 25), BF
        _Display
        _Limit 60
    Loop While Timer - s! < rpause / 1000 '<< adjust time as needed for your system
Wend

'============================================================

Sub DrawLightning (X&, Y&, Segments&, Dir#, Fork&)
    Sign# = 0.392699081
    xSeg# = xmax / (15.0 * Fork&)
    ySeg# = ymax / (15.0 * Fork&)
    Do
        Angle& = Int(Rnd(1) * 100)
        DeltaAngle# = Sign# * Angle& / 100.0
        Dir# = Dir# + DeltaAngle#
        Sign# = Sign# * -1.0

        nX& = X& + (Cos(Dir#) * xSeg#)
        nY& = Y& + (Sin(Dir#) * ySeg#)
        cc&& = _RGBA(128, Rnd * 55 + 200, Rnd * 55 + 200, 15 * FORKINESS / Fork&)
        DrawLine X&, Y&, nX&, nY&, cc&&
        X& = nX&
        Y& = nY&

        If ((Fork& < 5) And (Int(Rnd(1) * 60) < (FORKINESS / Fork&))) Then
            DrawLightning (X&), (Y&), 5 + Int(Rnd(1) * 10), Dir# - (2.0 * DeltaAngle#), Fork& + 2
        End If
        Segments& = Segments& - 1
    Loop While Segments& > 0 And Y& < ymax - 100
End Sub

Sub DrawLine (x1%, y1%, x2%, y2%, cc&&)
    If x1% < 0 Then
        If x2% < 0 Then Exit Sub
        x1% = 0
    ElseIf x1% >= xmax Then
        If x2% >= xmax Then Exit Sub
        x1% = xmax - 1
    End If
    If y1% < 0 Then
        If y2% < 0 Then Exit Sub
        y1% = 0
    ElseIf y1% >= ymax Then
        If y2% >= ymax Then Exit Sub
        y1% = ymax - 1
    End If

    If x2% < 0 Then
        x2% = 0
    ElseIf x2% >= xmax Then
        x2% = xmax - 1
    End If
    If y2% < 0 Then
        y2% = 0
    ElseIf y2% >= ymax Then
        y2% = ymax - 1
    End If
    Line (x1%, y1%)-(x2%, y2%), cc&&
End Sub

Sub drawLandscape
    'the sky
    For i = 0 To ymax
        midInk 0, 0, 0, 128, 128, 128, i / ymax
        Line (0, i)-(xmax, i)
    Next
    'the land
    startH = ymax - 200
    rr = 70: gg = 70: bb = 90
    For mountain = 1 To 6
        Xright = 0
        y = startH
        While Xright < xmax
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (Rnd * .8 - .35) * (mountain * .5)
            range = Xright + rand&&(15, 25) * 2.5 / mountain
            lastx = Xright - 1
            For X = Xright To range
                y = y + upDown
                Color _RGB(rr, gg, bb)
                Line (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            Next
            Xright = range
        Wend
        rr = rand&&(rr - 15, rr): gg = rand&&(gg - 15, gg): bb = rand&&(bb - 25, bb)
        If rr < 0 Then rr = 0
        If gg < 0 Then gg = 0
        If bb < 0 Then bb = 0
        startH = startH + rand&&(5, 20)
    Next
End Sub

Sub midInk (r1, g1, b1, r2, g2, b2, fr)
    Color _RGB(r1 + (r2 - r1) * fr, g1 + (g2 - g1) * fr, b1 + (b2 - b1) * fr)
End Sub

Function distance## (x1##, y1##, x2##, y2##)
    distance## = ((x1## - x2##) ^ 2 + (y1## - y2##) ^ 2) ^ .5
End Function

Function rand&& (lo&&, hi&&)
    rand&& = Int(Rnd * (hi&& - lo&& + 1)) + lo&&
End Function

true heat lightning needs more clouds and rarely ever sends bolts to the ground, more like flickering fluorescent bulb.

[Steffan-68]

Ohio's Heat Lightning

inspired sometime ago

I also found something from 'RhoSigma'.
I changed it a bit and added some sound.
I'm attaching the sound files below.

Code: (Select All)

$Embed:'.\gewitter.mp3','Gewi1'

$Embed:'.\gewitter2.mp3','Gewi2'

$Embed:'.\gewitter3.mp3','Gewi3'



$ExeIcon:'F:\QB64\ICO\candles.ico'

_Icon



'+---------------+---------------------------------------------------+

'| ###### ###### |    .--. .        .-.                            |

'| ##  ## ##  # |    |  )|        (  ) o                        |

'| ##  ##  ##    |    |--' |--. .-.  `-.  .  .-...--.--. .-.        |

'| ######  ##  |    |  \ |  |(  )(  ) | (  ||  |  |(  )      |

'| ##      ##    |    '  `'  `-`-'  `-'-' `-`-`|'  '  `-`-'`-      |

'| ##    ##  # |                            ._.'                  |

'| ##    ###### |  Sources & Documents placed in the Public Domain. |

'+---------------+---------------------------------------------------+

'|                                                                  |

'| === Lightning2.bas ===                                            |

'|                                                                  |

'| == The filnal result of joint efforts by bplus, TylerDarko and    |

'| == myself. (http://www.qb64.net/forum/index.php?topic=14532.0)    |

'|                                                                  |

'+-------------------------------------------------------------------+

'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |

'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for  |

'| any questions or suggestions. Thanx for your interest in my work. |

'+-------------------------------------------------------------------+



Dim h1 As Long: h1 = _SndOpen(_Embedded$("Gewi1"), "memory")



Dim h2 As Long: h2 = _SndOpen(_Embedded$("Gewi2"), "memory")



Dim h3 As Long: h3 = _SndOpen(_Embedded$("Gewi3"), "memory")





Dim Shared scrX%, scrY%

di& = _ScreenImage

scrX% = _Width(di&)

scrY% = _Height(di&)

_FreeImage di&

si& = _NewImage(scrX%, scrY%, 32)

Screen si&

_Delay 0.2: _ScreenMove _Middle

_Delay 0.2: _FullScreen



Const FORKINESS = 20 '1 to 20



Dim Shared scrX2%, scrX10%, scrXE%

Dim Shared scrY4%, scrY6%, scrYE%

scrX2% = scrX% \ 2: scrX10% = scrX% \ 10: scrXE% = scrX% - 1

scrY4% = scrY% \ 4: scrY6% = scrY% \ 6: scrYE% = scrY% - 1





Randomize Timer

flash& = _NewImage(scrX%, scrY%, 32)

land& = _NewImage(scrX%, scrY%, 32)

_Dest land&

DrawLandscape 6

_Dest 0



_MouseHide

While InKey$ = "" And mx% = 0 And my% = 0

    _PutImage , land&

    _Dest flash&

    Cls , _RGBA32(0, 0, 0, 0)

    Select Case RangeRand%(0, 180)

        Case 0 To 35

            DrawLightning scrXE%, RangeRand%(25, scrY6%), 50, 2.748893571, 1

            _SndPlay h1 'My Sound file fo play

        Case 36 To 71

            DrawLightning RangeRand%(scrX2% + scrX10%, scrXE%), 0, 50, 1.963495408, 1

            _SndPlay h2 'My Sound file fo play

        Case 72 To 107

            DrawLightning RangeRand%(scrX2% - scrX10%, scrX2% + scrX10%), 0, 50, 1.570796326, 1

            _SndPlay h2 'My Sound file fo play

        Case 108 To 144

            DrawLightning RangeRand%(0, scrX2% - scrX10%), 0, 50, 1.178097245, 1

            _SndPlay h3 'My Sound file fo play

        Case 145 To 180

            DrawLightning 0, RangeRand%(25, scrY6%), 50, 0.392699081, 1

            _SndPlay h3 'My Sound file fo play

    End Select

    _Dest 0

    _PutImage , flash&

    _Display

    _Delay 0.05

    pulse% = RangeRand%(0, 3)



    '  h& = _SndOpen("splash_gewitter.mp3") 'My Sound file fo play

    'If h& = 0 Then Else _SndPlay h&





    For fade% = 1 To 24

        Line (0, 0)-(_Width, _Height), _RGBA32(0, 0, 0, 10), BF

        If fade% > 4 And fade% < 8 And pulse% > 0 And RangeRand%(1, 100) > 50 Then

            _PutImage , land&

            _PutImage , flash&

            pulse% = pulse% - 1

            fade% = 0

        End If

        _Display

        _Limit 80

    Next fade%

    _PutImage , land&

    For fade% = 1 To 24

        Line (0, 0)-(_Width, _Height), _RGBA32(0, 0, 0, 10), BF

    Next fade%

    _Display



    _Delay RangeRand%(50, 4500) / 1000 '<< milliseconds to next lightning



    Do While _MouseInput

        mx% = mx% + _MouseMovementX

        my% = my% + _MouseMovementY

    Loop



    _SndStop h&



Wend



_FullScreen _Off

_Delay 0.2: Screen 0

_Delay 0.2: _FreeImage si&



System



'======================================================================

Sub DrawLandscape (hills%)

    '--- sky ---

    For i% = 0 To scrY%

        Line (0, i%)-(scrX%, i%), _RGB32(128 * (i% / scrY%), 128 * (i% / scrY%), 128 * (i% / scrY%))

    Next i%

    '--- land ---

    startH# = scrY% - scrY4%

    rr% = 70: gg% = 70: bb% = 90

    For hill% = 1 To hills%

        Xright# = 0

        y# = startH#

        While Xright# < scrX%

            'upDown# = local up / down over range, change along Y

            'range#  = how far up / down, along X

            upDown# = ((Rnd(1) * 0.8) - 0.35) * (hill% * 0.5)

            range# = Xright# + RangeRand%(15, 25) * (2.5 / hill%)

            lastX# = Xright# - 1

            For x# = Xright# To range#

                y# = y# + upDown#

                Line (lastX#, y#)-(x#, scrY%), _RGB32(rr%, gg%, bb%), BF 'just lines weren't filling right

                lastX# = x#

            Next x#

            Xright# = range#

        Wend

        rr% = RangeRand%(rr% - 15, rr%): If rr% < 0 Then rr% = 0

        gg% = RangeRand%(gg% - 15, gg%): If gg% < 0 Then gg% = 0

        bb% = RangeRand%(bb% - 25, bb%): If bb% < 0 Then bb% = 0

        startH# = startH# + RangeRand%(5, 20)

    Next hill%

End Sub



'======================================================================

Sub DrawLightning (X&, Y&, Segments&, Dir#, Fork&)

    Sign# = 0.392699081

    xSeg# = scrX% / (15.0 * Fork&)

    ySeg# = scrY% / (15.0 * Fork&)

    Do

        Angle& = RangeRand%(0, 100)

        DeltaAngle# = Sign# * Angle& / 100.0

        Dir# = Dir# + DeltaAngle#

        Sign# = Sign# * -1.0



        nX& = X& + (Cos(Dir#) * xSeg#)

        nY& = Y& + (Sin(Dir#) * ySeg#)

    DrawLine X&, Y&, nX&, nY&, _RGBA32(RangeRand%(160, 180), _

                                      RangeRand%(117, 137), _

                                      RangeRand%(235, 255), _

                                      75 + (180 \ Fork&))

        X& = nX&

        Y& = nY&



        If ((Fork& < 3) And (RangeRand%(0, 50) < (FORKINESS \ Fork&))) Then

            DrawLightning (X&), (Y&), 5 + RangeRand%(1, 10), Dir# - (2.0 * DeltaAngle#), Fork& + 1

        End If

        Segments& = Segments& - 1

    Loop While Segments& > 0 And Y& < scrY% - RangeRand%(75, scrY4% - 50)

End Sub



'======================================================================

Sub DrawLine (x1%, y1%, x2%, y2%, col&)

    If x1% < 0 Then

        If x2% < 0 Then Exit Sub

        x1% = 0

    ElseIf x1% >= scrX% Then

        If x2% >= scrX% Then Exit Sub

        x1% = scrXE%

    End If

    If y1% < 0 Then

        If y2% < 0 Then Exit Sub

        y1% = 0

    ElseIf y1% >= scrY% Then

        If y2% >= scrY% Then Exit Sub

        y1% = scrYE%

    End If



    If x2% < 0 Then

        x2% = 0

    ElseIf x2% >= scrX% Then

        x2% = scrXE%

    End If

    If y2% < 0 Then

        y2% = 0

    ElseIf y2% >= scrY% Then

        y2% = scrYE%

    End If



    Line (x1%, y1%)-(x2%, y2%), col&

End Sub



'======================================================================

Function RangeRand% (low%, high%)

    RangeRand% = Int(Rnd(1) * (high% - low% + 1)) + low%

End Function





'INCLUDE: '.\Gewitter1.bas.bm'

'INCLUDE: '.\Gewitter2.bas.bm'

'INCLUDE: '.\Gewitter3.bas.bm'

  gewitter.mp3 (Size: 83.31 KB / Downloads: 16)

  gewitter2.mp3 (Size: 90.75 KB / Downloads: 15)

  gewitter3.mp3 (Size: 562.93 KB / Downloads: 17)

[bplus]

@Steffan-68

i see some bm files that might be needed too
last lines

'INCLUDE: '.\Gewitter1.bas.bm'
'INCLUDE: '.\Gewitter2.bas.bm'
'INCLUDE: '.\Gewitter3.bas.bm'

IMO it's easier to put all this stuff into a single zip folder of the project, no?

UPDATE
ok it works after i comment out this, (without the bm includes which is curious)

Code: (Select All)

'$ExeIcon:'F:\QB64\ICO\candles.ico'
'_Icon

definitely nice sound effects for lightning!!!

but i miss the flashing / flickering of light that is both lightning and heat lightning.
ps the branching might be better, not sure if we have difference? or if it's just because there is no flashing flickering.

[Steffan-68]

@Steffan-68
i see some bm files that might be needed too
last lines

'INCLUDE: '.\Gewitter1.bas.bm'
'INCLUDE: '.\Gewitter2.bas.bm'
'INCLUDE: '.\Gewitter3.bas.bm'

Oh sorry 
I forgot to clean up the program. Previously embedded the sound with the 'bm' files and later with the new command '$Embed'
But the INCLUDE are already commented out because the leading $ is missing ('$INCLUDE: is the original command) 

[GareBear]

To all that runs Lighting2.bas,

Check your speaker or headphone levels, at Speakers 90%, it very loud. I set mine at 19%. Much better on the ears.

[Steffan-68]

To all that runs Lighting2.bas,
Check your speaker or headphone levels, at Speakers 90%, it very loud. I set mine at 19%. Much better on the ears.

Ok, you're right, but I never actually have my speakers at 90%.
For anyone who would like to do this, please insert this command.

Code: (Select All)

_SNDVOL handle&, volume!

[bplus]

Persian Carpets

Code: (Select All)

_Title "Persian Carpets" 'b+ revisit JB code 2020-04-26
DefInt A-Z
'Persian Carpets.txt for Just Basic v1.01 [B+=MGA] 2017-10-01
'based on orig by Anne M Burns
'2017-10-04 bi-lateral symmetry fixed! thanks tsh73 for help!
'2017-10-05 add varaibles report at bottom of screen, ask for help finding bad combos
'2020-04-26 translate to QB64

Const XMAX = 512, YMAX = 512
Dim Shared vScreen(XMAX, YMAX)
Dim Shared qb(15) As _Unsigned Long
qb(0) = &HFF000000
qb(1) = &HFF000088
qb(2) = &HFF008800
qb(3) = &HFF008888
qb(4) = &HFF880000
qb(5) = &HFF880088
qb(6) = &HFF888800
qb(7) = &HFFCCCCCC
qb(8) = &HFF888888
qb(9) = &HFF0000FF
qb(10) = &HFF00FF00
qb(11) = &HFF00FFFF
qb(12) = &HFFFF0000
qb(13) = &HFFFF00FF
qb(14) = &HFFFFFF00
qb(15) = &HFFFFFFFF

Screen _NewImage(XMAX, YMAX, 32)
Randomize Timer
a = 5: b = 7
While _KeyDown(27) = 0
    Cls
    Erase vScreen
    lft = 1: rght = 512: top = 1: bot = 512
    'a = INT(RND * 16)
    'b = (INT(RND * 16) + a) MOD 16
    'c = INT(RND * 16)
    vLINE lft + 1, top, rght - 1, top, a
    vLINE lft + 1, bot, rght - 1, bot, a
    vLINE lft, top, lft, bot, b
    vLINE rght, top, rght, bot, b
    DetermineColr lft, rght, top, bot, c
    c = c + 1
    If c = 16 Then
        b = Int(Rnd * 16): a = Int(Rnd * 16)
        If c = 16 Then c = 0
    End If
    _Display
    _Delay 2
Wend

' Determine the color based on function f
Sub DetermineColr (lft, rght, top, bot, a)
    If lft < rght - 1 Then '<<<< if you like intricate paterns go -1, for speed go -5
        c = findClr(lft, rght, top, bot, a)
        middlecol = Int(lft + rght) / 2
        middlerow = Int(top + bot) / 2
        If c = 0 Then c = 1
        If c = 14 Then c = 9

        vLINE lft, middlerow, rght, middlerow, c
        vLINE middlecol, top, middlecol, bot, c
        DetermineColr lft, middlecol, top, middlerow, a
        DetermineColr middlecol, rght, top, middlerow, a
        DetermineColr lft, middlecol, middlerow, bot, a
        DetermineColr middlecol, rght, middlerow, bot, a
    Else
        Exit Sub
    End If
End Sub

Function findClr (lft, rght, top, bot, a)
    'dang no POINT(x, y) oh well...
    p = (vScreen(lft, top) + vScreen(rght, top) + vScreen(lft, bot) + vScreen(rght, bot)) * 33
    'Try values of b = 4 or b = 7
    'b = 4
    'findClr = INT(p + a) MOD 16 'too much
    'findClr = INT(p / 13 + a) MOD 8 'less is more, yellow, green, red, brown theme
    findClr = Int(p / 17 + a) Mod 15 'less is more, blue and white theme
End Function

Sub vLINE (x0, y0, x1, y1, QBc)
    'record our line on the virtual screen
    If x0 = x1 Then
        If y0 > y1 Then start = y1: fini = y0 Else start = y0: fini = y1
        For i = start + 1 To fini - 1
            vScreen(x0, i) = QBc
        Next
    Else
        If x0 > x1 Then start = x1: fini = x0 Else start = x0: fini = x1
        For i = start + 1 To fini - 1
            vScreen(i, y0) = QBc
        Next
    End If
    Line (x0, y0)-(x1, y1), qb(QBc)
End Sub

   

[bplus]

Carnivore Message

Code: (Select All)

_Title "Carnivore message" ' b+ 2024-07-01
Screen _NewImage(500, 130, 32)
f& = _LoadFont("arial.ttf", 128, "MONOSPACE")
_Font f&
While _KeyDown(27) = 0
    Cls
    toggle = 1 - toggle
    If toggle = 0 Then Print " EAT"; Else Print "MEAT";
    _Display
    _Limit 1
Wend