+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: Proggies (/showthread.php?tid=162)
RE: Proggies - bplus - 06-20-2024
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 Subedit i changed my mind to black smoke instead of white, no pope today
RE: Proggies - bplus - 06-20-2024
+1 @dbox looks good!
we need some marshmallows
RE: Proggies - bplus - 06-27-2024
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 Functiontrue heat lightning needs more clouds and rarely ever sends bolts to the ground, more like flickering fluorescent bulb.
RE: Proggies - Steffan-68 - 06-27-2024
(06-27-2024, 01:09 PM)bplus Wrote:I also found something from 'RhoSigma'.Ohio's Heat Lightninginspired sometime ago
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: 17)
gewitter2.mp3 (Size: 90.75 KB / Downloads: 16)
gewitter3.mp3 (Size: 562.93 KB / Downloads: 21)
RE: Proggies - bplus - 06-27-2024
@Steffan-68
i see some bm files that might be needed too
last lines
Quote:
'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'
'_Icondefinitely 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.
RE: Proggies - Steffan-68 - 06-27-2024
(06-27-2024, 04:09 PM)bplus Wrote: @Steffan-68Oh sorry
i see some bm files that might be needed too
last lines
Quote:
'INCLUDE: '.\Gewitter1.bas.bm'
'INCLUDE: '.\Gewitter2.bas.bm'
'INCLUDE: '.\Gewitter3.bas.bm'
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)
RE: Proggies - GareBear - 06-27-2024
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.
RE: Proggies - Steffan-68 - 06-27-2024
(06-27-2024, 05:08 PM)GareBear Wrote: To all that runs Lighting2.bas,Ok, you're right, but I never actually have my speakers at 90%.
Check your speaker or headphone levels, at Speakers 90%, it very loud. I set mine at 19%. Much better on the ears.
For anyone who would like to do this, please insert this command.
Code: (Select All)
_SNDVOL handle&, volume!RE: Proggies - bplus - 06-29-2024
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 SubRE: Proggies - bplus - 07-01-2024
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