Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
10-26-2025, 06:16 PM
(This post was last modified: 10-26-2025, 06:31 PM by bplus.)
I am looking for colaborators or input on idea of boiling down my Boids work into a Clouds forming code.
I started this some time ago but either was distracted or didn't see it was going anywhere (then).
The 100 lines or less challenge (real or Unseen attention grabber?) brought this code back to mind.
Here is code, I wonder if anyone can take it closer to a Cloud like formation?
Code: (Select All) Option _Explicit
_Title "Clouds" ' b+ 2022-03-20
Randomize Timer
Const xmax = 300, ymax = 300, pi = _Pi, nb = 1500, blue = _RGB32(0, 0, 220)
Dim As Long i, j, testx, testy
Dim As Single s, dist
Dim As Single bx(nb), by(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As Single oldbx(nb), oldby(nb)
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
For i = 1 To nb
bx(i) = Rnd * xmax ' start random screen x, y away from borders
by(i) = Rnd * ymax
ba(i) = Rnd * 2 * pi
Next
Color , blue
Cls
While _KeyDown(27) = 0
Line (0, 0)-(_Width, _Height), _RGB32(0, 0, 200, 5), BF
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = distance(bx(i), by(i), bx(j), by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To nb 'draw then update positions of birds
' draw current
PSet (oldbx(i), oldby(i)), blue
PSet (bx(i), by(i)), &HFFFFFFFF '_RGB32(Rnd * 100 + 126)
oldbx(i) = bx(i): oldby(i) = by(i)
s = rand(3, 5) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i)): by(i) = by(i) + s * Sin(ba(i))
' JB&LB have better Mod function! tsh73 pointed it to me
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 20 Then ' birds are close enough to influence each other by visual
'sway the neighbors headings towards each other
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
'If dist > 5 And dist < 50 Then
' 'stickiness stay close to neighbors, close distance between
' If Rnd < 1 Then
' bx(i) = bx(i) - .1 * (bx(i) - bx(j))
' bx(j) = bx(j) + .1 * (bx(i) - bx(j))
' by(i) = by(i) - .1 * (by(i) - by(j))
' by(j) = by(j) + .1 * (by(i) - by(j))
' End If
'End If
If dist < 1 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function distance (x1, y1, x2, y2) ' default single OK
distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
' this allows us to do floats including negative floats
Function Mod2# (n As Double, modulus As Double)
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
Untouched for 3 years, hmm... does not bode well but the idea still valid, I think.
I suppose I should post what this code was boiled down from if I don't have it posted in my corner yet. Look for Boids by me.
You don't have to say anything if you think 'just scrap the idea and start with another approach' or you are just going to kabitz like old man Pete  (now I have one comment for sure! LOL you better like old men, you will be one too if you are lucky. Thats for Pete!)
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
10-26-2025, 06:29 PM
(This post was last modified: 10-26-2025, 06:29 PM by bplus.)
Ah the Cloud code was boiled down from Screensavers > Boid Watching
https://qb64phoenix.com/forum/showthread...0#pid25230
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 243
Threads: 15
Joined: Apr 2024
Reputation:
30
10-26-2025, 07:59 PM
(This post was last modified: 10-26-2025, 09:22 PM by ahenry3068.)
This KINDA makes clouds.
Needs some Tweaking
Code: (Select All)
Dim Shared SCREENWIDTH As Integer
Dim Shared SCREENHEIGHT As Integer
SCREENWIDTH = 800
SCREENHEIGHT = 600
Screen _NewImage(SCREENWIDTH, SCREENHEIGHT, 32)
Line (0, 0)-(SCREENWIDTH - 1, SCREENHEIGHT - 1), _RGB32(3, &HCC, &HFE), BF
Randomize Timer
For I = 1 To 5
MakeCloud
Next
End
Sub MakeCloud
Dim CLOUD_WIDTH As Integer
Dim CLOUD_HEIGHT As Integer
Dim CLOUD_COLOR As Long
Dim GrayLevel As Integer
Dim Transparency As Integer
Dim RAD_LIMIT As Integer
Dim DOT_RADIUS As Integer
Dim C_RAD As Integer
Dim LINE_STEP
Dim COL_STEP
Dim DOT_Y
Dim DOT_X
Dim Y_ADJ
Dim X_ADJ
GETNUMS:
CLOUD_WIDTH = Int((Int(Rnd(1) * SCREENWIDTH) + 120) / 4)
CLOUD_HEIGHT = Int((Int(Rnd(1) * SCREENHEIGHT) + 30) / 3)
If CLOUD_HEIGHT > CLOUD_WIDTH GoTo GETNUMS
LINE_STEP = CLOUD_HEIGHT / 10
COL_STEP = CLOUD_WIDTH / 15
If LINE_STEP > COL_STEP Then
RAD_LIMIT = LINE_STEP
Else
RAD_LIMIT = COL_STEP
End If
START_Y = (Int(Rnd(1) * SCREENHEIGHT - 10) + 10) / 2
START_X = Int(Rnd(1) * SCREENWIDTH - 20) + 20
For DOT_Y = START_Y To START_Y + CLOUD_HEIGHT Step LINE_STEP
For DOT_X = START_X To START_X + CLOUD_WIDTH Step COL_STEP
Transparency = Int(Rnd(1) * 171) + 84
GrayLevel = Int(Rnd(1) * 20) + 225
CLOUD_COLOR = _RGBA(GrayLevel, GrayLevel, GrayLevel, Transparency)
C_RAD = Int(Rnd(1) * RAD_LIMIT) + 5
Y_ADJ = Int(Rnd(1) * RAD_LIMIT)
If Int(Rnd(1) * 11) > 5 Then Y_ADJ = Y_ADJ * -1
X_ADJ = Int(Rnd(1) * RAD_LIMIT)
If Int(Rnd(1) * 11) > 5 Then X_ADJ = X_ADJ * -1
ASPECT = (Rnd(1) * .6) + .5
If ASPECT > 1 Then ASPECT = 1
For R = C_RAD To 0 Step -.1
Circle (DOT_X + X_ADJ, DOT_Y + Y_ADJ), R, CLOUD_COLOR
Next
Rem Paint Step(0, 0), CLOUD_COLOR
Next
Next
End Sub
Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
10-26-2025, 10:08 PM
(This post was last modified: 10-26-2025, 10:24 PM by bplus.)
+1 @ahenry3068 for being first!
OK I will try to assimulate your hints, thanks! I do insist on animation, I should have mentioned.
Code: (Select All)
Option _Explicit
_Title "2025-10-26-5 Clouds" 'b+ mod with filled circles
Randomize Timer
Const xmax = 600, ymax = 600, pi = _Pi, nb = 1500, blue = _RGB32(0, 0, 220)
Dim As Long i, j, testx, testy, lc
Dim As Single s, dist
Dim As Single bx(nb), by(nb), br(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As _Unsigned Long bc(nb)
Dim As Single oldbx(nb), oldby(nb)
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
For i = 1 To nb
bx(i) = Rnd * xmax ' start random screen x, y away from borders
by(i) = Rnd * ymax
br(i) = rand(1, 15)
bc(i) = _RGB32(Rnd * 75 + 180)
ba(i) = Rnd * 2 * pi
Next
Color , blue
Cls
_Display
While _KeyDown(27) = 0
lc = lc + 1
Line (0, 0)-(_Width, _Height), _RGB32(0, 0, 200, 140), BF
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = distance(bx(i), by(i), bx(j), by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To nb 'draw then update positions of birds
FC3 bx(i), by(i), br(i), bc(i) ' &HFFFFFFFF '
s = rand(3, 5) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i))
by(i) = by(i) + s * Sin(ba(i))
' JB&LB have better Mod function! tsh73 pointed it to me
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 20 Then ' birds are close enough to influence each other by visual
'sway the neighbors headings towards each other
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
'If dist > 5 And dist < 50 Then
' 'stickiness stay close to neighbors, close distance between
' If Rnd < 1 Then
' bx(i) = bx(i) - .1 * (bx(i) - bx(j))
' bx(j) = bx(j) + .1 * (bx(i) - bx(j))
' by(i) = by(i) - .1 * (by(i) - by(j))
' by(j) = by(j) + .1 * (by(i) - by(j))
' End If
'End If
If dist < 5 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
If lc > 15 Then _Display: _Limit 30
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function distance (x1, y1, x2, y2) ' default single OK
distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
Function Mod2# (n As Double, modulus As Double) ' this allows us to do floats including negative floats
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&)
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
I am ready for bubble bath 
Edit: Oh remove : to separate statements on a like.
Note: Even though
Code: (Select All) If lc > 15 Then _Display: _Limit 30
has colon in it, it is still one statement in my QB64 code challenge book anyway
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
10-26-2025, 10:36 PM
(This post was last modified: 10-26-2025, 10:39 PM by bplus.)
More tweaking and removed the one colon:
Code: (Select All)
Option _Explicit
_Title "2025-10-26-6p Clouds" 'b+ mod with filled circles
Randomize Timer
Const xmax = 800, ymax = 600, pi = _Pi, nb = 1500, blue = _RGB32(0, 0, 220)
Dim As Long i, j
Dim As Single s, dist
Dim As Single bx(nb), by(nb), br(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As _Unsigned Long bc(nb)
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
For i = 1 To nb
bx(i) = Rnd * xmax ' start random screen x, y away from borders
by(i) = Rnd * ymax
br(i) = rand(1, 15)
bc(i) = _RGB32(Rnd * 75 + 180)
ba(i) = pi * (1 + 1.25 * Rnd - 1.25 * Rnd)
Next
Color , blue
Cls
While _KeyDown(27) = 0
Line (0, 0)-(_Width, _Height), _RGB32(0, 0, 200, 140), BF
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = distance(bx(i), by(i), bx(j), by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To nb 'draw then update positions of birds
FC3 bx(i), by(i), br(i), bc(i) ' &HFFFFFFFF '
s = rand(3, 5) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i))
by(i) = by(i) + s * Sin(ba(i))
' JB&LB have better Mod function! tsh73 pointed it to me
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 20 Then ' birds are close enough to influence each other by visual
'sway the neighbors headings towards each other
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
'If dist > 5 And dist < 50 Then
' 'stickiness stay close to neighbors, close distance between
' If Rnd < 1 Then
' bx(i) = bx(i) - .1 * (bx(i) - bx(j))
' bx(j) = bx(j) + .1 * (bx(i) - bx(j))
' by(i) = by(i) - .1 * (by(i) - by(j))
' by(j) = by(j) + .1 * (by(i) - by(j))
' End If
'End If
If dist < 5 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
_Display
_Limit 30
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function distance (x1, y1, x2, y2) ' default single OK
distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
Function Mod2# (n As Double, modulus As Double) ' this allows us to do floats including negative floats
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&)
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
This might be interesting projected onto a sphere!
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 347
Threads: 45
Joined: Jun 2024
Reputation:
32
Here's my input...seems im a bit late to the party though! Mine is probably complete overkill but with some refinement i think itll look okay...i realised i can use its core to create random terrains that go on for ever too...bonus!
Code: (Select All)
'///////////////////////////////////////////////////////////////////////////////////////////////////
'/// Clouds Demo using Perlin Noise and Fractal Brownian Motion
'///////////////////////////////////////////////////////////////////////////////////////////////////
TYPE Vector2
X AS SINGLE
Y AS SINGLE
END TYPE
' Global data for the Perlin noise algorithm.
DIM SHARED g_p(511) AS INTEGER ' Permutation table, doubled to wrap
DIM SHARED g_grad(31) AS Vector2 ' Predefined gradient vectors
DIM SHARED g_initialized AS INTEGER, g_time AS SINGLE '// setup complete and animation timer
'///////////////////////////////////////////////////////////////////////////////////////////////////
InitPerlin ' Initialize the Perlin noise system by filling the permutation tables
SCREEN _NEWIMAGE(400, 300, 32)
_SCREENMOVE _MIDDLE
_TITLE "QB64 Clouds Demo (Perlin Noise and FBM)"
'///////////////////////////////////////////////////////////////////////////////////////////////////
DO
_LIMIT 60 ' Cap frame rate
g_time = g_time + 15 ' Adjust this value to change the speed
CLS
DrawClouds 400, 300, 24, .005 '// last two parameters are detail level...lower = faster but worse and last is scale...make larger for smaller clouds
_DISPLAY
LOOP WHILE INKEY$ = ""
END
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Sub to initialize the permutation and gradient tables. This creates a more organic cloud
SUB InitPerlin
IF g_initialized THEN EXIT SUB
' Permutation table, as a string of hex values.
p_hex$ = "9BA1B2ED B168D1B6 722D8B87 795B066C 7F27B5C7 E3C90CE2 B7460320 4C1B8C99 470A940F EBE430C5 AB1E594D 3F53A8BF E5CCA42F 08E8F243 417E2AD5 333CDE29 0D883B48 6E1018A7 139ED4AE 6D80504B E9EEF076 634A043A A9372C45 C25CA55E 07C6F76B 9F899362 1C703E60 C4D80009 8291B87D CFF87A16 7B6A8386 A6D067B9 648A0B54 DF320121 85D35A96 BA558F31 7465FC02 1A1DA32B 52927C8D 26421744 23358475 9A6FDA73 1FAA4990 22589D95 24E171D7 FD51BDA0 14255777 8ECA380E 78156111 BCF69756 9CCD A2FB AD3934D6 5F6905DB C8B0E6C1 ECBEFA12 D9F966F4 CB98E7C3 BBDCFECE F5B3B43D AC C0FFDD F32EAF F1B0"
DIM p(255) AS INTEGER, i AS INTEGER, j AS INTEGER
FOR i = 1 TO LEN(p_hex$)
hex_char$ = MID$(p_hex$, i, 1)
IF hex_char$ <> " " THEN
val_str$ = val_str$ + hex_char$
IF LEN(val_str$) = 2 THEN
p(j) = VAL("&H" + val_str$) '// convert to hex value
val_str$ = ""
j = j + 1
END IF
END IF
NEXT i
' Copy the table to itself for wrapping.
FOR i = 0 TO 255
g_p(i) = p(i)
g_p(i + 256) = p(i)
NEXT i
' Predefined gradient vectors for 2D.
g_grad(0).X = 1: g_grad(0).Y = 1
g_grad(1).X = -1: g_grad(1).Y = 1
g_grad(2).X = 1: g_grad(2).Y = -1
g_grad(3).X = -1: g_grad(3).Y = -1
g_grad(4).X = 1: g_grad(4).Y = 0
g_grad(5).X = -1: g_grad(5).Y = 0
g_grad(6).X = 0: g_grad(6).Y = 1
g_grad(7).X = 0: g_grad(7).Y = -1
g_initialized = 1
END SUB
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Sub to generate and draw the cloud effect using FBM.
SUB DrawClouds (width AS INTEGER, height AS INTEGER, FineDetail, Scale)
DIM x AS INTEGER, y AS INTEGER
DIM clr AS LONG, shadowClr AS LONG, cloudClr AS LONG, highlightClr AS LONG
shadowClr = _RGB32(5, 5, 5) ' Dark shadow color (purplish grey)
cloudClr = _RGB32(120, 120, 130) ' Main cloud body color (light grey)
highlightClr = _RGB32(255, 255, 255) ' Bright highlight color (pure white)
octaves = FineDetail ' Use more octaves for finer detail
persistence = 0.5
'scale = 0.0005 ' Smaller scale for larger cloud features
FOR y = 0 TO height - 1
FOR x = 0 TO width - 1
noiseValue = 0
frequency = Scale
amplitude = 1
' Fractal Brownian Motion (FBM) loop
FOR i = 1 TO octaves
' Add g_time to the x-coordinate to simulate horizontal movement
noiseValue = noiseValue + PerlinNoise((x + g_time) * frequency, y * frequency) * amplitude
frequency = frequency * 2
amplitude = amplitude * persistence
NEXT i
' Clamp and adjust noise for appearance.
noiseValue = ABS(noiseValue) ^ 0.7
IF noiseValue > 1 THEN noiseValue = 1
IF noiseValue < 0 THEN noiseValue = 0
' Map the noise value to a color.
IF noiseValue < 0.5 THEN
clr = LerpClr(shadowClr, cloudClr, noiseValue * 2)
ELSE
clr = LerpClr(cloudClr, highlightClr, (noiseValue - 0.5) * 2)
END IF
PSET (x, y), clr
NEXT x
NEXT y
END SUB
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Function to perform linear interpolation between two colors.
FUNCTION LerpClr& (clr1 AS LONG, clr2 AS LONG, t AS SINGLE)
DIM r1 AS INTEGER, g1 AS INTEGER, b1 AS INTEGER
DIM r2 AS INTEGER, g2 AS INTEGER, b2 AS INTEGER
DIM r AS INTEGER, g AS INTEGER, b AS INTEGER
r1 = _RED32(clr1)
g1 = _GREEN32(clr1)
b1 = _BLUE32(clr1)
r2 = _RED32(clr2)
g2 = _GREEN32(clr2)
b2 = _BLUE32(clr2)
r = r1 + t * (r2 - r1)
g = g1 + t * (g2 - g1)
b = b1 + t * (b2 - b1)
LerpClr& = _RGB32(r, g, b)
END FUNCTION
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Main Perlin noise function for 2D.
FUNCTION PerlinNoise! (x AS SINGLE, y AS SINGLE)
DIM x_int AS INTEGER, y_int AS INTEGER
DIM gi00 AS Vector2, gi01 AS Vector2, gi10 AS Vector2, gi11 AS Vector2
DIM dist00 AS Vector2, dist01 AS Vector2, dist10 AS Vector2, dist11 AS Vector2
' Get the integer and fractional parts.
x_int = INT(x) AND 255
y_int = INT(y) AND 255
x_frac = x - INT(x)
y_frac = y - INT(y)
' Get the gradients for the four corners.
gi00 = g_grad(g_p(g_p(x_int) + y_int) AND 7)
gi01 = g_grad(g_p(g_p(x_int) + y_int + 1) AND 7)
gi10 = g_grad(g_p(g_p(x_int + 1) + y_int) AND 7)
gi11 = g_grad(g_p(g_p(x_int + 1) + y_int + 1) AND 7)
' Create and populate temporary distance vectors.
dist00.X = x_frac: dist00.Y = y_frac
dist01.X = x_frac: dist01.Y = y_frac - 1
dist10.X = x_frac - 1: dist10.Y = y_frac
dist11.X = x_frac - 1: dist11.Y = y_frac - 1
' Calculate dot products of gradient and distance vectors.
n00 = DotProduct(gi00, dist00)
n01 = DotProduct(gi01, dist01)
n10 = DotProduct(gi10, dist10)
n11 = DotProduct(gi11, dist11)
' Smooth the interpolation (fade function).
u = Fade(x_frac)
v = Fade(y_frac)
' Interpolate to find the final noise value.
PerlinNoise = Lerp(Lerp(n00, n10, u), Lerp(n01, n11, u), v)
END FUNCTION
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Hermite interpolation function (6t^5 - 15t^4 + 10t^3).
FUNCTION Fade (t AS SINGLE)
Fade = t * t * t * (t * (t * 6 - 15) + 10)
END FUNCTION
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Linear interpolation function.
FUNCTION Lerp (a AS SINGLE, b AS SINGLE, t AS SINGLE)
Lerp = a + t * (b - a)
END FUNCTION
'///////////////////////////////////////////////////////////////////////////////////////////////////
' Helper function to compute the dot product of two vectors.
FUNCTION DotProduct (v1 AS Vector2, v2 AS Vector2)
DotProduct = v1.X * v2.X + v1.Y * v2.Y
END FUNCTION
'///////////////////////////////////////////////////////////////////////////////////////////////////
Unseen
Posts: 347
Threads: 45
Joined: Jun 2024
Reputation:
32
Quote:This might be interesting projected onto a sphere!
@bplus
Im working on a maptriangle version too....
Code: (Select All)
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
'// Improved GL control...now we only need ONE variable to control things! //
CONST GL_Mode_OFF = 0, GL_Mode_Load = 1, GL_Mode_Render = 2
DIM SHARED GL_Mode AS _BYTE
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
'// Generic Screen setup //
SCREEN _NEWIMAGE(_DESKTOPWIDTH, _DESKTOPHEIGHT, 32)
_FULLSCREEN '_SQUAREPIXELS , _SMOOTH
_DISPLAYORDER _SOFTWARE , _GLRENDER '// this way we can oveylay our dubug info
_MOUSEHIDE
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
Root$ = "OpenWorld2\Need\" '// Where our files are
CHDIR Root$ '// Set our root path
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
GL_Mode = GL_Mode_Load '// Load everything
DO
_LIMIT 120
_FPS 120
CLS
_DISPLAY
IF INKEY$ = CHR$(27) OR _KEYDOWN(27) THEN SYSTEM
LOOP
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
SUB UDTS
TYPE Vertex_F '// A point in 3d space
X AS SINGLE
Y AS SINGLE
Z AS SINGLE
END TYPE
TYPE Triangle '// Made from 3 points in 3d space
Vertex1 AS Vertex_F
Vertex2 AS Vertex_F
Vertex3 AS Vertex_F
END TYPE
TYPE UV_F '// Texture coordinates - Each Vertex in your triangle probally has one - Often referred to as ST coordinates
U AS SINGLE
V AS SINGLE
END TYPE
END SUB
'/////////////////////////////////////////////////////////////////////////////////////////////////////////
SUB _GL
STATIC SkyList~&, WorldList~&
IF GL_Mode = GL_Mode_OFF THEN
EXIT SUB
ELSE
'// Bog standard Open_GL Setup \\
_GLCLEARDEPTH 1
_GLCLEARCOLOR 0, 0, 0, 1
_GLENABLE _GL_DEPTH_TEST
_GLENABLE _GL_TEXTURE_2D
_GLMATRIXMODE _GL_PROJECTION
_GLLOADIDENTITY
_GLUPERSPECTIVE 90, _DESKTOPWIDTH / _DESKTOPHEIGHT, .1, 20000
_GLMATRIXMODE _GL_MODELVIEW
_GLLOADIDENTITY
_GLVIEWPORT 0, 0, _DESKTOPWIDTH, _DESKTOPHEIGHT
SELECT CASE GL_Mode
CASE GL_Mode_Load
SkyList~& = CreateSphereList(5000, 120, 120, GL_Load_Texture("night_sky.jpg"))
GL_Mode = GL_Mode_Render '// We have loaded the things so Update flag to render mode
CASE GL_Mode_Render
_GLCLEAR _GL_DEPTH_BUFFER_BIT OR _GL_COLOR_BUFFER_BIT '// GL CLS
_GLLOADIDENTITY '// Go home (0,0,0)
_GLTRANSLATEF 0, 100, -8000 '// Remove this see from the inside
'// SKY Rendering
_GLPUSHMATRIX
_GLROTATEF 180, 1, 0, 0
_GLROTATEF 90, 0, 0, 1
_GLCALLLIST SkyList~&
_GLPUSHMATRIX
_DISPLAY
CASE ELSE
EXIT SUB '// GL rendering is disabled right now
END SELECT
END IF
END SUB
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
FUNCTION CreateSphereList~& (Rad!, Slices%, Stacks%, Texture&)
DIM AS Vertex_F p1, p2, p3, p4
DIM AS Triangle tri
DIM AS INTEGER i, j
list_handle~& = _GLGENLISTS(1)
IF list_handle~& <> 0 THEN
_GLNEWLIST list_handle~&, _GL_COMPILE
_GLENABLE _GL_TEXTURE_2D
_GLBINDTEXTURE _GL_TEXTURE_2D, Texture&
lon_step = (2 * _PI) / Slices%
lat_step = _PI / Stacks%
_GLBEGIN _GL_TRIANGLES
FOR j = 0 TO Stacks% - 1
lat_rad! = -_PI / 2 + j * lat_step
next_lat_rad! = -_PI / 2 + (j + 1) * lat_step
FOR i = 0 TO Slices% - 1
lon_rad! = i * lon_step
next_lon_rad! = (i + 1) * lon_step
p1.X = Rad! * COS(lat_rad!) * COS(lon_rad!)
p1.Y = Rad! * SIN(lat_rad!)
p1.Z = Rad! * COS(lat_rad!) * SIN(lon_rad!)
p2.X = Rad! * COS(lat_rad!) * COS(next_lon_rad!)
p2.Y = Rad! * SIN(lat_rad!)
p2.Z = Rad! * COS(lat_rad!) * SIN(next_lon_rad!)
p3.X = Rad! * COS(next_lat_rad!) * COS(next_lon_rad!)
p3.Y = Rad! * SIN(next_lat_rad!)
p3.Z = Rad! * COS(next_lat_rad!) * SIN(next_lon_rad!)
p4.X = Rad! * COS(next_lat_rad!) * COS(lon_rad!)
p4.Y = Rad! * SIN(next_lat_rad!)
p4.Z = Rad! * COS(next_lat_rad!) * SIN(lon_rad!)
tri.Vertex1 = p1
tri.Vertex2 = p2
tri.Vertex3 = p3
_GLTEXCOORD2F i / Slices%, j / Stacks%
_GLVERTEX3F p1.X, p1.Y, p1.Z
_GLTEXCOORD2F (i + 1) / Slices%, j / Stacks%
_GLVERTEX3F p2.X, p2.Y, p2.Z
_GLTEXCOORD2F (i + 1) / Slices%, (j + 1) / Stacks%
_GLVERTEX3F p3.X, p3.Y, p3.Z
tri.Vertex1 = p1
tri.Vertex2 = p3
tri.Vertex3 = p4
_GLTEXCOORD2F i / Slices%, j / Stacks%
_GLVERTEX3F p1.X, p1.Y, p1.Z
_GLTEXCOORD2F (i + 1) / Slices%, (j + 1) / Stacks%
_GLVERTEX3F p3.X, p3.Y, p3.Z
_GLTEXCOORD2F i / Slices%, (j + 1) / Stacks%
_GLVERTEX3F p4.X, p4.Y, p4.Z
NEXT i
NEXT j
_GLEND
_GLENDLIST
END IF
CreateSphereList~& = list_handle~&
END FUNCTION
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
FUNCTION GL_MAKE_TEXTURE& (File&)
Sx% = _WIDTH(File&)
Sy% = _HEIGHT(File&)
DIM h AS LONG, LoadTexture_Buffer(Sx% * Sy%) AS LONG, LoadTexture_Buffer2(Sx% * Sy%) AS LONG
OldSrc& = _SOURCE
_SOURCE File&
GET (0, 0)-(Sx% - 1, Sy% - 1), LoadTexture_Buffer(0)
_SOURCE OldSrc&
FOR y% = 0 TO Sy% - 1
FOR x% = 0 TO Sx% - 1
clr~& = LoadTexture_Buffer(PXCnt&)
LoadTexture_Buffer2(PXCnt&) = ((clr~& \ 65536) AND 255) + (clr~& AND &HFF00&) + ((clr~& AND 255) * 65536)
PXCnt& = PXCnt& + 1
NEXT
NEXT
_GLGENTEXTURES 1, _OFFSET(h)
_GLBINDTEXTURE _GL_TEXTURE_2D, h
gluBuild2DMipmaps _GL_TEXTURE_2D, _GL_RGBA, Sx%, Sy%, _GL_RGBA, _GL_UNSIGNED_BYTE, LoadTexture_Buffer2(0)
_GLTEXPARAMETERI _GL_TEXTURE_2D, _GL_TEXTURE_MAG_FILTER, _GL_LINEAR
_GLTEXPARAMETERI _GL_TEXTURE_2D, _GL_TEXTURE_MIN_FILTER, _GL_LINEAR_MIPMAP_LINEAR
GL_MAKE_TEXTURE = h
END FUNCTION
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
FUNCTION GL_Load_Texture& (FileName$)
GL_Load_Texture& = GL_MAKE_TEXTURE(_LOADIMAGE(FileName$, 32))
END FUNCTION
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
DECLARE DYNAMIC LIBRARY "glu32"
SUB gluBuild2DMipmaps (BYVAL eg_GL_TEXTURE_2D&, BYVAL eg_GL_RGBA&, BYVAL sx&, BYVAL sy&, BYVAL eg_GL_RGBA&, BYVAL eg_GL_UNSIGNED_BYTE&, offset&)
SUB gluLookAt (BYVAL eyex#, BYVAL eyey#, BYVAL eyez#, BYVAL centerx#, BYVAL centery#, BYVAL centerz#, BYVAL upx#, BYVAL upy#, BYVAL upz#)
SUB gluPerspective (BYVAL fovy#, BYVAL aspect#, BYVAL zNear#, BYVAL zFar#)
END DECLARE
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
To test it change root in line 18 and file name in line 86 to one youve got...or to use your generated images, ud=se the make texture function instead of loading file...
John
Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
10-26-2025, 11:53 PM
(This post was last modified: 10-27-2025, 01:08 AM by bplus.)
+1 @Unseen Machine thanks for participating. I've seen Perlin Noise before now that you mention it. I may have even attempted clouds with that too. For me, the Perlin Noise Clouds are too static but does look perfect for terrain as you said.
I have sphere converter already made in about 50 17 LOC lets see how long it takes me to put up my clouds on a planetoid.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
10-27-2025, 01:00 AM
(This post was last modified: 10-27-2025, 01:06 AM by bplus.)
And bplus brings it at 98 LOC with no colons!
Code: (Select All)
_Title "2025-10-26 Clouds over Sphere" 'b+ mod with filled circles
Const xmax = 1000, ymax = 700, pi = _Pi, nb = 1500, blue = _RGB32(50, 30, 90)
Dim As Long i, j, clouds
Dim As Single bx(nb), by(nb), br(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As _Unsigned Long bc(nb)
Screen _NewImage(xmax, ymax, 32)
For i = 1 To nb
bx(i) = Rnd * xmax ' start random screen x, y away from borders
by(i) = Rnd * ymax
br(i) = rand(1, 4)
bc(i) = _RGB32(Rnd * 75 + 160)
ba(i) = -pi * (1 + .75 * Rnd - .75 * Rnd)
Next
clouds = _NewImage(xmax, ymax, 32)
While _KeyDown(27) = 0
Cls , 0
_Dest clouds
Line (0, 0)-(_Width, _Height), blue, BF
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = _Hypot(bx(i) - bx(j), by(i) - by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To nb 'draw then update positions of birds
FC3 bx(i), by(i), br(i), bc(i) ' &HFFFFFFFF '
s = rand(3, 5) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i))
by(i) = by(i) + s * Sin(ba(i))
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 20 Then ' birds are close enough to influence each other by visual
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j))) 'sway the neighbors headings towards each other
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
If dist < 5 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
xoff = (xoff + 4) ' Mod (_Width(clouds&) + 1)
a = a + _Pi(2 / 320)
projectImagetoSphere clouds, xmax / 2, ymax / 2, ymax / 2 - 20, xoff
_Display
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
Function Mod2# (n As Double, modulus As Double) ' this allows us to do floats including negative floats
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&)
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Sub projectImagetoSphere (image&, x0, y0, sr, xo)
Dim r, iW, iH, scale, y, x1, tv, x, tu, pc~&
r = _Height(image&) / 2
iW = _Width(image&) - 20
iH = _Height(image&)
scale = sr / r
For y = -r To r
x1 = Sqr(r * r - y * y)
tv = (_Asin(y / r) + 1.5) / 3
For x = -x1 + 1 To x1
tu = (_Asin(x / x1) + 1.5) / 6
_Source image&
pc~& = Point((xo + tu * iW) Mod iW, tv * iH)
_Dest 0
PSet (x * scale + x0, y * scale + y0), pc~&
Next x
Next y
End Sub
shhhh... unfortunately there is a seam in the sphere
EDIT: cut 2 lines
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,697
Threads: 222
Joined: Apr 2022
Reputation:
322
@Unseen Machine nice rendering of my mars Image but no animation?
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
|
