Code: Select all
'coded by UEZ build 2018-04-27
'thanks to dodicat for the DrawThickLine function
'use 64-bit compilation for faster progress
#include "string.bi"
#include "fbgfx.bi"
#if __FB_LANG__ = "fb"
Using FB '' Scan code constants are stored in the FB namespace in lang FB
#endif
#Define Min(a, b) Iif(a < b, a, b)
Declare Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
Declare Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger)
Const As Ushort iW = 1200, iH = 800, iCenterX = iW \ 2, iCenterY = iH \ 2
Const As Single fD2R = Acos(-1) / 180, thresholdBloom = 0.03, treeSize = 0.275
Const As Ubyte maxLevel = 14, bloomLevel = Cubyte(maxLevel * 0.75), lineThickness = 10, maxBloomSize = 8
Const As Ulong bloomColor = &h910F66, colorTree = &h800
Screenres iW, iH, 32, , GFX_WINDOWED Or GFX_NO_SWITCH
Color 0, &hA0A0A0
Cls
'======================= maybe needed later
Dim Shared As Integer w, h, depth, bpp, bpsl
ScreenInfo w, h, depth, bpp, bpsl
Dim Shared As Any Ptr pScreen
pScreen = Screenptr()
'=======================
Windowtitle("Simple Recursive Tree Generator v0.90 / " & Format((3^maxLevel) Shr 1, "#,##") & " function calls")
Randomize
Dim Shared As Ulong level
level = 0
DrawRecTree(iCenterX, iH, 90, -90, colorTree)
Draw String(10, 10), "Press space / lmb to regenerate tree", &hFFFFFF
Dim As Single fTimer
Dim As Integer x, y, buttons
Do
Getmouse(x, y, , buttons)
If Multikey(SC_SPACE) Or buttons = 1 Then
fTimer = Timer()
Cls
Screenlock
DrawRecTree(iCenterX, iH, 90, -90, colorTree)
Screenunlock
Draw String(10, iH - 10), Format((Timer() - fTimer) * 1000, "0.0000") & " ms", &hFFFFFF
End If
Sleep 50, 1
Loop Until Multikey(SC_ESCAPE)
Sub DrawRecTree(x As Single, y As Single, length As Single, angle As Single, col As Ulong)
level += 1
Dim As Single destX, destY, col2
destX = x + length * Cos(angle * fD2R)
destY = y + length * Sin(angle * fD2R)
col += 256 * level
If level > bloomLevel And Rnd() < thresholdBloom Then
col = bloomColor 'this will overwrite the green color and will change the color of the branches, too.
Circle (x, y), Min(maxBloomSize, (destX - x)), col, , , 1.25 + Rnd() / 4, F
Else
DrawThickLine(x, y, destX, destY, 1 + lineThickness / level, col)
'Line (x, y)-(destX, destY), col
End If
If level < maxLevel Then
DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
DrawRecTree(destX, destY, length * (1 + 3 * Rnd()) * treeSize, angle + 60 * (Rnd() - Rnd()), col)
End If
level -= 1
End Sub
Sub DrawThickLine(Byval x1 As Integer, Byval y1 As Integer, Byval x2 As Integer, Byval y2 As Integer, Byval size As Integer, Byval c As Uinteger) 'by dodicat
If x1 = x2 And y1 = y2 Then
Circle (x1, y1), size, c, , , , f
Elseif Abs(x2 - x1) >= Abs(y2 - y1) Then
Dim K As Single = (y2 - y1) / (x2 - x1)
For I As Integer = x1 To x2 Step Sgn(x2 - x1)
Circle (I, K * (I - x1) + y1), size, c, , , , f
Next I
Else
Dim L As Single = (x2 - x1) / (y2 - y1)
For J As Integer = y1 To y2 Step Sgn(y2 - y1)
Circle (L * (J - y1) + x1, J), size, c, , , , f
Next J
End If
End Sub
I'm thinking about to add a save function...
Update1: tidy up the code