Posts: 4,703
Threads: 222
Joined: Apr 2022
Reputation:
322
Code: (Select All) Option _Explicit
_Title "Landscape Fills 1 Demo Basic Technique" ' bplus 2025-10-12 the basic technique
' The problem:
' upper part of screen is blue sky rectangle
' you want to fill lower green landscape with objects mostly non overlapping
'screen rectangle Xmax by Ymax constants
Const Xmax = 800, Ymax = 600
Dim horizon ' horizon y as fraction of screen height
Dim As Long n, i, j ' number of objects to place in landscape
Dim hMin ' smallest radius at horizon
Dim z ' size ' variable function fraction of how far down from horizon to bottom of screen
Dim x, y, yFrac, hMax, hRange, yRange ' position object middle goinbg to use circles here
Screen _NewImage(Xmax, Ymax, 32)
horizon = .25 * Ymax ' 1/4 down screen
Line (0, 0)-(Xmax - 1, horizon), &HFFAAAAFF, BF ' sky rect
Line (0, horizon)-(Xmax - 1, Ymax - 1), &HFF008800, BF ' land
n = 1500 ' number of objects to fit
hMin = 2 ' height of smallest object at horizon
hMax = 80 ' maximum object height at bottom of screen
hRange = hMax - hMin ' precalcs total height range
yRange = Ymax - horizon ' precalcs land range
Dim cx(n), cy(n), sz(n) ' location and size of objects
For i = 0 To n
tryAgain:
x = Rnd * Xmax: y = horizon + Rnd * yRange ' pick point at random past horizon
' calc size of object at this point
' z is the radius size according to y place
yFrac = (y - horizon) / yRange 'the fraction of y from horizon over horizon to bottom of screen
z = hMin + yFrac * hRange ' the object should have this size in height
' since our objects are circles we want 1/2 that height for radius of circle
z = z / 2
For j = 0 To i - 1
If _Hypot(cx(j) - x, cy(j) - y) < z + sz(j) Then GoTo tryAgain
Next
cx(i) = x: cy(i) = y: sz(i) = z
Circle (cx(i), cy(i)), sz(i)
_Title "Landscape Fills Demo:" + Str$(i) + " objects of" + Str$(n) + " objects placed."
Next
Beep
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,703
Threads: 222
Joined: Apr 2022
Reputation:
322
Code: (Select All) Option _Explicit
_Title "Landscape Fills 2 Demo with Images" ' bplus 2025-10-12 make a sub for doing an image
' The problem:
' upper part of screen is blue sky rectangle
' you want to fill lower green landscape with objects mostly non overlapping
'screen rectangle Xmax by Ymax constants
Const Xmax = 800, Ymax = 600
Type Object
As Single X, Y, Size
End Type
Dim horizon, r ' r is radii of circle image we will be making
Dim As Long img, n ' number of objects to place in landscape
Dim hMin, hMax ' position object middle goinbg to use circles here
Screen _NewImage(Xmax, Ymax, 32)
_Delay .1
_ScreenMove 250, 60
img = _NewImage(102, 102, 32) ' make a thick circle image
_Dest img
For r = 20 To 49 Step .25
Circle (51, 51), r
Next
_Dest 0 'test image
'_PutImage (0, 0), img, 0 ' check image
'Print _Height(img)
'Sleep
'simple screen with land and sky
horizon = .25 * Ymax ' 1/4 down screen
Line (0, 0)-(Xmax - 1, horizon), &HFFAAAAFF, BF ' sky rect
Line (0, horizon)-(Xmax - 1, Ymax - 1), &HFF008800, BF ' land
n = 1000 ' number of objects to fill landscape, you will likely have to tweak this
' to save all locations and sizes of positioned objects
hMin = 3 ' spec height of smallest object at horizon
hMax = 80 ' spec maximum object height at bottom of screen
Dim ohs(1 To n) As Object
'now fill landscape with our object
LandscapeFill img, horizon, hMin, hMax, ohs()
Sub LandscapeFill (ObjImg As Long, horizon, hMin, hMax, ObjContainer( 1 To nObjs) As Object)
' this sub needs:
'Const Xmax = 800, Ymax = 600 ' for screen dimension
'Type Object
' As Single X, Y, Size
'End Type
' Sub RotoZoom (X, Y, Image As Long, Scale, degreesRotation)
' Parameters;
' ObjImg = image handle
' horizon = how far down is the horizon on y axis
' hMin = minimum object height at horizon
' hMax = max object height at bottom of screen
Dim hImg, hRange, yRange, x, y, z, yFrac
Dim As Long i, j
hImg = _Height(ObjImg)
hRange = hMax - hMin ' precalcs total height range
yRange = Ymax - horizon ' precalcs land range
For i = 1 To UBound(ObjContainer)
tryAgain:
x = Rnd * Xmax
' this might speed up fills by testing more often top half of screen
If Rnd < .5 Then y = horizon + Rnd * yRange * .5 Else y = horizon + Rnd * yRange ' pick point at random past horizon
' calc size of object at this point
' z is the radius size according to y place
yFrac = (y - horizon) / yRange 'the fraction of y from horizon over horizon to bottom of screen
z = hMin + yFrac * hRange ' the object should have this size in height
' since our objects are circles we want 1/2 that height for radius of circle
For j = 1 To i - 1
If _Hypot(ObjContainer(j).X - x, ObjContainer(j).Y - y) < (z + ObjContainer(j).Size) / 2 Then GoTo tryAgain
Next
ObjContainer(i).X = x: ObjContainer(i).Y = y: ObjContainer(i).Size = z
RotoZoom ObjContainer(i).X, ObjContainer(i).Y, ObjImg, ObjContainer(i).Size / hImg, 0
' OK check out the placement given by the code with a circle command!!!
'Circle (ObjContainer(i).X, ObjContainer(i).Y), ObjContainer(i).Size / 2, &HFF880000
'Perfection!!!! exactly the same circles
Next
End Sub
Sub RotoZoom (X, Y, Image As Long, Scale, degreesRotation)
Dim px(3) As Single, py(3) As Single, W, H, sinr, cosr, i, x2, y2
W = _Width(Image): H = _Height(Image)
px(0) = -W / 2: py(0) = -H / 2: px(1) = -W / 2: py(1) = H / 2
px(2) = W / 2: py(2) = H / 2: px(3) = W / 2: py(3) = -H / 2
sinr = Sin(-degreesRotation / 57.2957795131): cosr = Cos(-degreesRotation / 57.2957795131)
For i = 0 To 3
x2 = (px(i) * cosr + sinr * py(i)) * Scale + X: y2 = (py(i) * cosr - px(i) * sinr)_
* Scale + Y
px(i) = x2: py(i) = y2
Next
_MapTriangle (0, 0)-(0, H - 1)-(W - 1, H - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W - 1, 0)-(W - 1, H - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 4,703
Threads: 222
Joined: Apr 2022
Reputation:
322
Admittedly using that code in Candy Corn Trees took some hacking!
Here is test screen for setup of Candy Corn River:
The code for Candy Corn Trees 4:
Code: (Select All) Option _Explicit
_Title "Candy Corn Trees 4" 'bplus 2025-10-12
' from "Alien Trees Mod 3: Leaves" 'b+ 2022-09-05
' 10/10 good have it growing on trees next step is to drop corn when full size.
' 10/11 falling fruit complete next is to distribute to Sugarland Productions.
' 10/12 Part 3: Corn River
' 10/12 Part 4: test Corn River fill with new LandscapeFill sub
Randomize Timer
DefDbl A-Z
Const Xmax = 1024, Ymax = 600
Type Corn
As Double x, y, size, scale, frac, falling, dy, savey, dx, a
End Type
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 170, 40 ' clear sides
'_FullScreen
Randomize Timer
Dim Shared CC&
CC& = _LoadImage("Candy Corn 1.png")
Dim Shared As Long BK ' background image
BK = _NewImage(Xmax, Ymax, 32) 'container for drawings
Dim Shared As Long Seed(1 To 3), Start, CN ' Randomize seeds for trees and plasma starters
Dim Shared As Single Rd(1 To 3), Gn(1 To 3), Bl(1 To 3) ' plasma colors for trees
Dim Shared Leaf ' indexing ends of branches
Dim ref&
ref& = _NewImage(Xmax, Ymax * .2, 32) 'container for reflection image
Dim Shared Corns(448) As Corn ' corns / leaves
Dim Shared RiverCorn(180) As Corn
Dim As Long i
'MakeRiverCorn
' just testing how LandscapeFill would work
LandscapeFill CC&, .8 * Ymax, 20, 60, RiverCorn()
'_Display
Beep
Sleep 'see how it did?
Dim hImg, bob
hImg = _Height(CC&)
For i = 0 To UBound(RiverCorn)
RiverCorn(i).scale = RiverCorn(i).size / hImg
RiverCorn(i).dx = RiverCorn(i).y * rndR(.001, .0013) ' the farther down the faster flow
RiverCorn(i).dy = rndR(-20, 20) ' tilt
' checking distribution
'Circle (RiverCorn(i).x, RiverCorn(i).y), RiverCorn(i).scale
'_Display
Next
restart:
makeBackground
Seed(1) = Rnd * 1000 ' get new trees setup including the Plasma generators
Seed(2) = Rnd * 1000
Seed(3) = Rnd * 1000
For i = 1 To 3
Rd(i) = Rnd + .1
Gn(i) = Rnd * Rd(i)
Bl(i) = 0 'Rnd * Rnd
Next
Leaf = 0
Start = 0
CN = Start
Randomize Using Seed(1)
branch Xmax * .6 + Rnd * .3 * Xmax, Ymax * .8 - 30, 6, 90, Xmax / 20, 0, 1, 1
CN = Start
Randomize Using Seed(2)
branch Rnd * .3 * Xmax, Ymax * .8 - 15, 7, 90, Xmax / 18, 0, 2, 1
CN = Start
Randomize Using Seed(3)
branch Xmax / 2, Ymax * .8 - 8, 8, 90, Xmax / 16, 0, 3, 1
For i = 1 To 448 'assign rnd sizes
Corns(i).frac = Rnd * .75
Next
Do
_PutImage , BK, 0
Start = Start + 1
CN = Start
Randomize Using Seed(1)
branch Xmax * .6 + Rnd * .3 * Xmax, Ymax * .8 - 30, 6, 90, Xmax / 20, 0, 1, 0
CN = Start
Randomize Using Seed(2)
branch Rnd * .3 * Xmax, Ymax * .8 - 15, 7, 90, Xmax / 18, 0, 2, 0
CN = Start
Randomize Using Seed(3)
branch Xmax / 2, Ymax * .8 - 8, 8, 90, Xmax / 16, 0, 3, 0
For i = 448 To 1 Step -1
'FCirc corns(i).x, corns(i).y, 3, &HFF0000FF
If Corns(i).falling Then
Corns(i).y = Corns(i).y + Corns(i).dy
If Corns(i).y > _Height Then
Corns(i).y = Corns(i).savey ' back to start position
Corns(i).frac = .1 ' small start
Corns(i).falling = 0 ' no longer falling
Else
RotoZoom Corns(i).x, Corns(i).y, CC&, Corns(i).frac * Corns(i).scale / 10, 0
Corns(i).dy = Corns(i).dy + .5
End If
Else
RotoZoom Corns(i).x, Corns(i).y, CC&, Corns(i).frac * Corns(i).scale / 10, 0
Corns(i).frac = Corns(i).frac + .0003
If Corns(i).frac > .75 Then
Corns(i).falling = 1: Corns(i).dy = 1
End If
End If
Next
If _KeyDown(32) Then GoTo restart
_PutImage , 0, ref&, (0, 0)-(Xmax, .8 * Ymax)
_PutImage (0, .8 * Ymax)-(Xmax, Ymax), ref&, 0, (0, _Height(ref&))-(Xmax, 0)
Line (0, .8 * Ymax)-(Xmax, Ymax), &H88663399, BF
' the river
QuickSort 0, UBound(RiverCorn), RiverCorn() ' to draw corn in back first
For i = 0 To UBound(RiverCorn)
' for makeRivercorn sub
'RotoZoom RiverCorn(i).x, RiverCorn(i).y, CC&, RiverCorn(i).scale/30, RiverCorn(i).dy
'for LandscapeFill sub
RotoZoom RiverCorn(i).x, RiverCorn(i).y + bob, CC&, RiverCorn(i).scale, RiverCorn(i).dy
RiverCorn(i).x = RiverCorn(i).x + RiverCorn(i).dx 'move along
If RiverCorn(i).x > Xmax + 10 Then RiverCorn(i).x = rndR(-50, 0) ' too far right start another
Next
_Display
_Limit 30
Loop Until _KeyDown(27)
Sub makeBackground
Dim As Long i, stars
Dim horizon
_Dest BK
For i = 0 To Ymax
Line (0, i)-(Xmax, i), _RGB32(70, 60, i / Ymax * 160)
Next
stars = Xmax * Ymax * 10 ^ -4
horizon = .67 * Ymax
For i = 1 To stars 'stars in sky
PSet (Rnd * Xmax, Rnd * horizon), _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Next
stars = stars / 2
For i = 1 To stars
FCirc Rnd * Xmax, Rnd * horizon, 1, _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Next
stars = stars / 2
For i = 1 To stars
FCirc Rnd * Xmax, Rnd * horizon, 2, _RGB32(175 + Rnd * 80, 175 + Rnd * 80, 175 + Rnd * 80)
Next
DrawTerrain 405, 25, &HFF002255
DrawTerrain 420, 15, &HFF224444
DrawTerrain 435, 6, &HFF448855
DrawTerrain 450, 5, &HFF88FF66
_Dest 0
End Sub
Sub branch (x, y, startr, angD, lngth, lev, tree, leafTF)
Dim As Double x2, y2, dx, dy
Dim As Long i, lev2
x2 = x + Cos(_D2R(angD)) * lngth
y2 = y - Sin(_D2R(angD)) * lngth
dx = (x2 - x) / lngth
dy = (y2 - y) / lngth
For i = 0 To lngth
FCirc x + dx * i, y + dy * i, startr, changePlasma~&(tree)
Next
If startr <= 0 Or lev > 11 Or lngth < 5 Then
If leafTF Then
Leaf = Leaf + 1
Corns(Leaf).scale = .75 * tree + 1
Corns(Leaf).x = x2
Corns(Leaf).y = y2
Corns(Leaf).savey = y2
End If
Exit Sub
Else
lev2 = lev + 1
branch x2, y2, startr - 1, angD + 10 + 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2, tree, leafTF
branch x2, y2, startr - 1, angD - 10 - 30 * Rnd, .8 * lngth + .2 * Rnd * lngth, lev2, tree, leafTF
End If
End Sub
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Function changePlasma~& (n) ' red green for reds and yellows
CN = CN - 1 'dim shared cN as _Integer64, pR as long, pG as long, pB as long
changePlasma~& = _RGB32(127 + 127 * Sin(Rd(n) * CN), 127 + 127 * Sin(Gn(n) * CN), 0)
End Function
Sub DrawTerrain (h, modN, c As _Unsigned Long) ' modN for ruggedness the higher the less smooth
Dim x, dy
For x = 0 To _Width
If x Mod modN = 0 Then ' adjust mod number for ruggedness the higher the number the more jagged
If h < 600 - modN And h > 50 + modN Then
dy = Rnd * 20 - 10
ElseIf h >= 600 - modN Then
dy = Rnd * -10
ElseIf h <= 50 + modN Then
dy = Rnd * 10
End If
End If
h = h + .1 * dy
Line (x, _Height)-(x, h), c
Next
End Sub
Sub MakeRiverCorn
'Type corn
' As Double x, y, scale, frac, falling, dy, savey, dx
'End Type
Dim r, xoff, yoff, size
Dim As Long i, j
r = 7
For i = 0 To UBound(RiverCorn)
tryAgain:
xoff = Rnd * Xmax
yoff = rndR(.81 * Ymax, Ymax)
size = r + r * (yoff - .81 * Ymax) / (.25 * Ymax)
For j = 0 To i - 1
If _Hypot(xoff - RiverCorn(j).x, yoff - RiverCorn(j).y) < size + RiverCorn(j).scale Then GoTo tryAgain
Next
RiverCorn(i).x = xoff: RiverCorn(i).y = yoff: RiverCorn(i).scale = size
RiverCorn(i).dx = RiverCorn(i).y * rndR(.001, .0017) ' the farther down the faster flow
RiverCorn(i).dy = rndR(-30, 30) ' tilt
' checking distribution
'Circle (RiverCorn(i).x, RiverCorn(i).y), RiverCorn(i).scale
'_Display
Next
'Sleep
'Cls
End Sub
Sub LandscapeFill (ObjImg As Long, horizon, hMin, hMax, ObjContainer() As Corn)
' this sub needs:
'Const Xmax = 800, Ymax = 600 ' for screen dimension
'Type Object
' As Single X, Y, Size
'End Type
' Sub RotoZoom (X, Y, Image As Long, Scale, degreesRotation)
' Parameters;
' ObjImg = image handle
' horizon = how far down is the horizon on y axis
' hMin = minimum object height at horizon
' hMax = max object height at bottom of screen
Dim hImg, hRange, yRange, x, y, z, yFrac
Dim As Long i, j
hImg = _Height(ObjImg)
hRange = hMax - hMin ' precalcs total height range
yRange = Ymax - horizon ' precalcs land range
For i = 1 To UBound(ObjContainer)
tryAgain:
x = Rnd * Xmax
' this might speed up fills by testing more often top half of screen
If Rnd < .5 Then y = horizon + Rnd * yRange * .5 Else y = horizon + Rnd * yRange ' pick point at random past horizon
' calc size of object at this point
' z is the radius size according to y place
yFrac = (y - horizon) / yRange 'the fraction of y from horizon over horizon to bottom of screen
z = hMin + yFrac * hRange ' the object should have this size in height
' since our objects are circles we want 1/2 that height for radius of circle
For j = 1 To i - 1
If _Hypot(ObjContainer(j).x - x, ObjContainer(j).y - y) < (z + ObjContainer(j).size) / 3 Then GoTo tryAgain
Next
ObjContainer(i).x = x: ObjContainer(i).y = y: ObjContainer(i).size = z
RotoZoom ObjContainer(i).x, ObjContainer(i).y, ObjImg, ObjContainer(i).size / hImg, 0
' OK check out the placement given by the code with a circle command!!!
Circle (ObjContainer(i).x, ObjContainer(i).y), ObjContainer(i).size / 2, &HFF880000
'Perfection!!!! exactly the same circles
Locate 1, 1: Print i
Next
End Sub
Sub RotoZoom (X, Y, Image As Long, Scale, degreesRotation)
Dim px(3) As Single, py(3) As Single, W, H, sinr, cosr, i, x2, y2
W = _Width(Image): H = _Height(Image)
px(0) = -W / 2: py(0) = -H / 2: px(1) = -W / 2: py(1) = H / 2
px(2) = W / 2: py(2) = H / 2: px(3) = W / 2: py(3) = -H / 2
sinr = Sin(-degreesRotation / 57.2957795131): cosr = Cos(-degreesRotation / 57.2957795131)
For i = 0 To 3
x2 = (px(i) * cosr + sinr * py(i)) * Scale + X: y2 = (py(i) * cosr - px(i) * sinr)_
* Scale + Y
px(i) = x2: py(i) = y2
Next
_MapTriangle (0, 0)-(0, H - 1)-(W - 1, H - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(W - 1, 0)-(W - 1, H - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Function rndR (n1, n2) 'return real number (_single, double, _float depending on default / define setup)
rndR = (n2 - n1) * Rnd + n1
End Function
Sub QuickSort (start As Long, finish As Long, array() As Corn)
Dim Hi As Long, Lo As Long, Middle As Single
Hi = finish: Lo = start
Middle = array((Lo + Hi) / 2).y 'find middle of array
Do
Do While array(Lo).y < Middle: Lo = Lo + 1: Loop
Do While array(Hi).y > Middle: Hi = Hi - 1: Loop
If Lo <= Hi Then
Swap array(Lo), array(Hi)
Lo = Lo + 1: Hi = Hi - 1
End If
Loop Until Lo > Hi
If Hi > start Then Call QuickSort(start, Hi, array())
If Lo < finish Then Call QuickSort(Lo, finish, array())
End Sub
Image needed:
Sample run:
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
Tell me those trees are made using fractals or something! Can i use it to make a 3d/gl tree thingy please?
Posts: 4,703
Threads: 222
Joined: Apr 2022
Reputation:
322
10-15-2025, 11:11 PM
(This post was last modified: 10-15-2025, 11:19 PM by bplus.)
Yeah that bplus guy made a little mod on the classic recursive branch code:
Code: (Select All) _Title "Basic Tree from branch"
Randomize Timer
Screen _NewImage(800, 600, 32)
_ScreenMove 300, 20
Color _RGB32(0, 255, 0)
'just test call to sub
' x, y, 270, .2*height, 1 start a tree with 270 degrees to point up, and about 1/5 the height you want to grow the tree
Do
Cls
branch 400, 590, 270, 100, 1
Print "press escape to see the forest, any other for another tree, zzz..."
Sleep
Loop Until _KeyDown(27)
horizon = .35 * _Height
For i = 0 To horizon
Line (0, i)-(_Width, i), _RGB(0, 0, .25 * i + 100)
Next
For i = horizon To _Height
Line (0, i)-(_Width, i), _RGB(0, 255 - .25 * i - 50, 0)
Next
For i = 1 To 100
y = randWeight(horizon, _Height, 3)
branch _Width * Rnd, y, 270, (.015 * Rnd + .027) * y, 1
Next
Sleep
Sub branch (x, y, angD, lngth, lev)
x2 = x + Cos(_D2R(angD)) * lngth
y2 = y + Sin(_D2R(angD)) * lngth
Line (x, y)-(x2, y2), _RGB32(lev * 36 + Rnd * 39, lev * 36 + Rnd * 39, .25 * (lev * 36 + Rnd * 39))
If lev > 6 Or lngth < 2 Then Exit Sub
l = lev + 1
branch x2, y2, angD + 10 + 30 * Rnd, .7 * lngth + .2 * Rnd * lngth, l
branch x2, y2, angD - 10 - 30 * Rnd, .7 * lngth + .2 * Rnd * lngth, l
If Rnd < .65 Then branch x2, y2, angD + 20 * Rnd - 10, .8 * lngth + .2 * Rnd * lngth, l
End Sub
Function randWeight (manyValue, fewValue, power)
randWeight = manyValue + Rnd ^ power * (fewValue - manyValue)
End Function
Can you use it? probably, Ashish did with _GL let me see if I can find it...
Nope, Must of been lost with one of my hard drive crashes.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
Posts: 811
Threads: 128
Joined: Apr 2022
Reputation:
135
Hey these are neat! Thanks for sharing.
- Dav
|
