Some Variations of a Binary Fractal Tree

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
Bolee
Posts: 3
Joined: Jan 21, 2020 21:30

Some Variations of a Binary Fractal Tree

Postby Bolee » Jan 21, 2020 22:17

My very first post.
I was playing around with some fractal tree code and made a few different variations to share.

Thank you Paul Doe for the image box suggestion. I have now edited the post to try to include some images.

Version 1:

A multicoloured fractal tree with decreasing circle sizes at node points.

Image


Code: Select all

 ' A multicoloured fractal tree
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32
color rgb(0,0,0),rgb(0,0,0):cls

dim as single angle,x,y
x = 30
y = 40
angle = atan2(y,x)*RtoD
print angle;90-angle

'x = cos(angle*DtoR)*L
'y = sin(angle*DtoR)*L

SUB tree (x as integer, y as integer, a as single, L as single, depth as integer)
    dim as single Oldx,Oldy,xx,yy,lastdepth
    Oldx = x
    Oldy = y
   
   
   
    IF depth THEN
       
        x = x + L * COS(a + DtoR*90)          'compute new x coordinate
        y = y + L * SIN(a + DtoR*90)          'compute new y coordinate
       
       
       line (Oldx+320,480-Oldy)-(x+320,480-y),rgb(100 + 6*L,4*L,115)
       if depth  > 3 and depth <> 9  then circle (Oldx+320,480-Oldy),2*depth -5,rgb(100 + 6*L,4*L,115),,,,f
       
       
        xx = x+320
        yy = 480-y
        'line (xx-L\4,yy-L\4)-(xx+L\4,yy+L\4),rgb(100 + 6*L,4*L,115)
        'line (xx+L\4,yy-L\4)-(xx-L\4,yy+L\4),rgb(100 + 6*L,4*L,115)
        'if depth > 6 then circle (xx+L\4,yy-L\4),depth -2,rgb(255,0,0),,,,f
        'if depth > 6 then circle (xx-L\4,yy-L\4),depth -2,rgb(255,0,0),,,,f
        Oldx = x
        Oldy = y
       
       
        tree (x,y, a + 45*DtoR, L * .6, depth - 1)  'shorten the length of branch
        tree (x,y, a - 45*DtoR, L * .6 , depth - 1)  'and reduce the depth value
 
    END IF
       
    return
   
END SUB



'************** MAIN ROUTINE ****************
'      x, y, angle, length, depth
tree (0, 10,   0,    190,     9   )

while inkey="":wend









Version 2:

'A purple fractal tree with 3 extra diagonal lines at the node points.

Image

Code: Select all

Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32
color rgb(0,0,0),rgb(0,0,0):cls

dim as single angle,x,y
x = 30
y = 40
angle = atan2(y,x)*RtoD
print angle;90-angle

'x = cos(angle*DtoR)*L
'y = sin(angle*DtoR)*L

SUB tree (x as integer, y as integer, a as single, L as single, depth as integer)
    dim as single Oldx,Oldy,xx,yy,lastdepth
    Oldx = x
    Oldy = y
   
   
   
    IF depth THEN
       
        x = x + L * COS(a + DtoR*90)          'compute new x coordinate
        y = y + L * SIN(a + DtoR*90)          'compute new y coordinate
       
       
       line (Oldx+320,480-Oldy)-(x+320,480-y),rgb(255,0,255)
       
        xx = x+320
        yy = 480-y
       
        IF depth <> 9 THEN
            line (xx-L\4,yy-L\4)-(xx+L\4,yy+L\4),rgb(255,0,255)
            line (xx+L\4,yy-L\4)-(xx-L\4,yy+L\4),rgb(255,0,255)
        END IF


        Oldx = x
        Oldy = y
       
       
        tree (x,y, a + 45*DtoR, L * .6, depth - 1)  'shorten the length of branch
        tree (x,y, a - 45*DtoR, L * .6 , depth - 1)  'and reduce the depth value
 
    END IF
       
    return
   
END SUB



'************** MAIN ROUTINE ****************
'      x, y, angle, length, depth
tree (0, 10,   0,    190,     9   )

while inkey="":wend







Version 3:

A green Fractal Tree with 4 diagonal lines and four circles at the node points.

Image


Code: Select all

 'A green Fractal Tree
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32
color rgb(0,0,0),rgb(0,0,0):cls

dim as single angle,x,y
x = 30
y = 40
angle = atan2(y,x)*RtoD
print angle;90-angle

'x = cos(angle*DtoR)*L
'y = sin(angle*DtoR)*L

SUB tree (x as integer, y as integer, a as single, L as single, depth as integer)
    dim as single Oldx,Oldy,xx,yy,lastdepth
    Oldx = x
    Oldy = y
   
   
   
    IF depth THEN
       
        x = x + L * COS(a + DtoR*90)          'compute new x coordinate
        y = y + L * SIN(a + DtoR*90)          'compute new y coordinate
       
       
       line (Oldx+320,480-Oldy)-(x+320,480-y),rgb(0,150,0)
       
        xx = x+320
        yy = 480-y
       
        IF depth < 8 THEN
            line (xx-L\4,yy-L\4)-(xx+L\4,yy+L\4),rgb(0,150,0)
            line (xx+L\4,yy-L\4)-(xx-L\4,yy+L\4),rgb(0,150,0)
        END IF

       if depth < 8 then circle (xx+L\4,yy-L\4),depth -1.5,rgb(0,150,0),,,,f
       if depth < 8 then circle (xx-L\4,yy-L\4),depth -1.5,rgb(0,150,0),,,,f
       if depth < 8 then circle (xx+L\4,yy+L\4),depth -1.5,rgb(0,150,0),,,,f
       if depth < 8 then circle (xx-L\4,yy+L\4),depth -1.5,rgb(0,150,0),,,,f
        Oldx = x
        Oldy = y
       
       
        tree (x,y, a + 45*DtoR, L * .6, depth - 1)  'shorten the length of branch
        tree (x,y, a - 45*DtoR, L * .6 , depth - 1)  'and reduce the depth value
 
    END IF
       
    return
   
END SUB



'************** MAIN ROUTINE ****************
'      x, y, angle, length, depth
tree (0, 10,   0,    190,     8   )

while inkey="":wend




Version 4:

A cactus like picture (actually a fractal tree with circles instead of lines for branches).

Image

Code: Select all

 ' a cactus like picture
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32
color rgb(0,0,0),rgb(255,255,255):cls

dim as single angle,x,y
x = 20
y = 40
angle = atan2(y,x)*RtoD

'x = cos(angle*DtoR)*L
'y = sin(angle*DtoR)*L

SUB cactus (x as integer, y as integer, a as single, L as single, depth as integer)
    dim as single Oldx,Oldy,xx,yy
    Oldx = x
    Oldy = y
   
   
    IF depth THEN
       
        x = x + L * COS(a + DtoR*90)          'compute new x coordinate
        y = y + L * SIN(a + DtoR*90)          'compute new y coordinate
       
       
       if depth < 4 then line (Oldx+320,480-Oldy)-(x+320,480-y),rgb(50,120,50)
       
       if depth = 9 then circle (x+320,480-y+L\2.475),(L\3.375) - 2,rgb(0,120,0),,,,f
       
        xx = x+320
        yy = 480-y
       
       if depth > 4  then circle (x+320,480-y),L\1.815,rgb(10-L,238+11.5*L,0),,,,f
       if depth = 4  then circle (x+320,480-y),-1.5 + (L\1.815),rgb(60+5*L,10+L,0),,,,f
       if depth = 1  then circle (x+320,480-y),2,rgb(230,10,0),,,,f
       
        Oldx = x
        Oldy = y
       
        cactus (x,y, a + 45*DtoR, L * .6, depth - 1)  'shorten the length of branch
        cactus (x,y, a - 45*DtoR, L * .6 , depth - 1)  'and reduce the depth value
 
    END IF
   
END SUB

'      x, y, angle, length, depth
cactus (20, 40,   0,    170,     9   )

while inkey="":wend
 



I wonder how to make the branches like a trapezium in shape and how to distort them slightly to make the tree look bit more realistic.

I also thought about using Cairo to enhance the graphics.




I accidentally came across this forum a number of days ago and was really impressed by all the knowledge of it's members. I upload to PlanetVb but now I'n a big fan of FreeBasic. I have experimented with different Freebasic source code, and am finding it not to hard to use, except for the little errors that come up with win32 and win64 builds. A little bit frustrating but the great graphics is a real eye opener.

Thank you Paul Doe and Badidea for your fractal code additions and for making me welcome. I see that you are from the Netherlands and Argentina. I'm in Australia (which is being hit hard by fires, rain/hail and now wind). The weather has been really unusual and going from one extreme to the other.

See you for now.
Last edited by Bolee on Jan 22, 2020 3:47, edited 2 times in total.
paul doe
Posts: 1068
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: Some Variations of a Binary Fractal Tree

Postby paul doe » Jan 21, 2020 22:51

Bolee wrote:My very first post.
...

Welcome, then =D

Very nice! I love fractals (or anything procedural, for that matter). Since I'm working on the graphic backends on my framework, I'll share a little snippet with you:

Code: Select all

#include once "fbgfx.bi"

#define ColorR( c ) _
  ( culng( c ) shr 16 and 255 )
#define ColorG( c ) _
  ( culng( c ) shr 8 and 255 )
#define ColorB( c ) _
  ( culng( c ) and 255 )
#define ColorA( c ) _
  ( culng( c ) shr 24 )

#define pitchInPixelsOf( buffer ) _
  ( buffer->pitch \ sizeOf( ulong ) )
#define pixelsOf( buffer ) _
  ( cptr( _
    ulong ptr, _
    buffer ) + sizeOf( Fb.Image ) \ sizeOf( ulong ) )
#define pixel( buffer, x, y, pitch ) _
  buffer[ ( pitch ) * ( y ) + ( x ) ]
#define colorMix( component, s, d, x ) _
  ( ( component( d ) - component( s ) ) * ( x ) + component( s ) )

function _
  createBackground( _
    byval c1 as ulong, _
    byval c2 as ulong, _
    byval w as integer, _
    byval h as integer ) _
  as Fb.Image ptr
 
  dim as single _
    centerX => w / 2, _
    centerY => h / 2, _
    maxValue => sqr( centerX ^ 2 + centerY ^ 2 )
 
  dim as Fb.Image ptr _
    s => imageCreate( w, h )
 
  dim as integer _
    pitch => pitchInPixelsOf( s )
  dim as ulong ptr _
    px => pixelsOf( s )
 
  for _
    y as integer => 0 _
    to h - 1
     
     for _
       x as integer => 0 to _
       w - 1
        
        dim as single _
          v => sqr( _
            ( centerX - x ) * ( centerX - x ) + _
            ( centerY - y ) * ( centerY - y ) ) _
            / ( maxValue + 1 )
        
        pixel( _
          px, x, y, pitch ) => rgba( _
            colorMix( ColorR, c1, c2, v ), _
            colorMix( ColorG, c1, c2, v ), _
            colorMix( ColorB, c1, c2, v ), _
            colorMix( ColorA, c1, c2, v ) )
     next
  next
 
  return( s )
end function

 ' a cactus like picture
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 640,480,32
'color rgb(0,0,0),rgb(255,255,255):cls
var _
  background => createBackground( _
    rgba( 255, 0, 255, 255 ), _
    rgba( 255, 0, 0, 255 ), _
    640, 480 )

put _
  ( 0, 0 ), _
  background, pset

dim as single angle,x,y
x = 20
y = 40
angle = atan2(y,x)*RtoD

'x = cos(angle*DtoR)*L
'y = sin(angle*DtoR)*L

SUB cactus (x as integer, y as integer, a as single, L as single, depth as integer)
    dim as single Oldx,Oldy,xx,yy
    Oldx = x
    Oldy = y
   
   
    IF depth THEN
       
        x = x + L * COS(a + DtoR*90)          'compute new x coordinate
        y = y + L * SIN(a + DtoR*90)          'compute new y coordinate
       
       
       if depth < 4 then line (Oldx+320,480-Oldy)-(x+320,480-y),rgb(50,120,50)
       
       if depth = 9 then circle (x+320,480-y+L\2.475),(L\3.375) - 2,rgb(0,120,0),,,,f
       
        xx = x+320
        yy = 480-y
       
       if depth > 4  then circle (x+320,480-y),L\1.815,rgb(10-L,238+11.5*L,0),,,,f
       if depth = 4  then circle (x+320,480-y),-1.5 + (L\1.815),rgb(60+5*L,10+L,0),,,,f
       if depth = 1  then circle (x+320,480-y),2,rgb(230,10,0),,,,f
       
        Oldx = x
        Oldy = y
       
        cactus (x,y, a + 45*DtoR, L * .6, depth - 1)  'shorten the length of branch
        cactus (x,y, a - 45*DtoR, L * .6 , depth - 1)  'and reduce the depth value
 
    END IF
   
END SUB

'      x, y, angle, length, depth
cactus (20, 40,   0,    170,     9   )

while inkey="":wend

imageDestroy( background )

Which adds just the right amount of flair XD
Bolee wrote:...
I wanted to upload some screen captures but need to find a free site to host the images.
...

May I suggest ImgBox?
badidea
Posts: 1784
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Some Variations of a Binary Fractal Tree

Postby badidea » Jan 21, 2020 23:01

Nice, last holiday period I was also experimenting with 'fractal trees' (pasted before in Dry Christmas.)

Code: Select all

const as single M_PI = 3.141592654

type sgl2d
   as single x, y
   declare constructor
   declare constructor(x as single, y as single)
end type

constructor sgl2d
end constructor

constructor sgl2d(x as single, y as single)
   this.x = x : this.y = y
end constructor

const SCR_W = 800, SCR_H = 600

screenres SCR_W, SCR_H, 32

function tline(startPos as sgl2d, length as single, angle as single, c as ulong) as sgl2d
   dim as integer x1 = startPos.x
   dim as integer y1 = startPos.y
   dim as integer x2 = startPos.x + length * cos(angle)
   dim as integer y2 = startPos.y + length * sin(angle)
   line(x1, (SCR_H - 1) - y1)-(x2, (SCR_H - 1) - y2), c
   return sgl2d(x2, y2)
end function

type tree_type
   private:
   dim as integer branchDepth = 0
   dim as integer maxBranchDepth = 5
   dim as single branchAngle = M_PI * 0.2
   dim as single mainBranchFactor = 0.7
   dim as single sideBranchFactor = 0.4
   dim as ulong c = rgba(150, 75, 0, 255)
   public:
   declare sub setProperties(maxBranchDepth as integer, branchAngle as single, mainBranchFactor as single, sideBranchFactor as single, c as ulong)
   declare sub drawBranch(startPos as sgl2d, length as single, angle as single)
end type

sub tree_type.setProperties(maxBranchDepth as integer, branchAngle as single, mainBranchFactor as single, sideBranchFactor as single, c as ulong)
   this.maxBranchDepth = maxBranchDepth
   this.branchAngle = branchAngle
   this.mainBranchFactor = mainBranchFactor
   this.sideBranchFactor = sideBranchFactor
   this.c = c
end sub

sub tree_type.drawBranch(startPos as sgl2d, length as single, angle as single)
   branchDepth += 1
   dim as sgl2d endPos = tline(startPos, length, angle, c)
   if branchDepth < maxBranchDepth then
      drawBranch(endPos, length * mainBranchFactor, angle)
      drawBranch(endPos, length * sideBranchFactor, angle + branchAngle)
      drawBranch(endPos, length * sideBranchFactor, angle - branchAngle)
   end if
   branchDepth -= 1
end sub

dim as tree_type tree
dim as sgl2d startPos

startPos = sgl2d(SCR_W * 0.2, SCR_H * 0.1)
tree.setProperties(8, M_PI * 0.1, 0.9, 0.5, rgba(150, 125, 0, 255))
tree.drawBranch(startPos, 90, M_PI * 0.5)

startPos = sgl2d(SCR_W * 0.4, SCR_H * 0.1)
tree.setProperties(11, M_PI * 0.40, 0.9, 0.4, rgba(150, 175, 0, 255))
tree.drawBranch(startPos, 60, M_PI * 0.5)

startPos = sgl2d(SCR_W * 0.6, SCR_H * 0.1)
tree.setProperties(10, M_PI * 0.2, 0.7, 0.4, rgba(150, 100, 0, 255))
tree.drawBranch(startPos, 150, M_PI * 0.5)

startPos = sgl2d(SCR_W * 0.8, SCR_H * 0.1)
tree.setProperties(8, M_PI * 0.1, 0.2, 0.7, rgba(150, 150, 0, 255))
tree.drawBranch(startPos, 100, M_PI * 0.5)

sleep
paul doe
Posts: 1068
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: Some Variations of a Binary Fractal Tree

Postby paul doe » Jan 23, 2020 13:56

Bolee wrote:...
Thank you Paul Doe and Badidea for your fractal code additions and for making me welcome. I see that you are from the Netherlands and Argentina. I'm in Australia (which is being hit hard by fires, rain/hail and now wind).
...

You're welcome. Yeah, my ex-wife and I (being both Greenpeace members) are following the whereabouts there very closely. Know that our hearths and minds are with you people, and your magical country, at all times. We really wish we could do more ='(
dodicat
Posts: 6163
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Some Variations of a Binary Fractal Tree

Postby dodicat » Jan 23, 2020 19:51

paul doe
. . . (being both Greenpeace members) . . .
my respect.

Here is my variation

Code: Select all


screenres 900,700,32
color ,rgb(150,150,150)
cls
type point
    as long x,y
    as ulong col
end type

type angle
    as single cosa,sina
    declare sub set(as single)
end type

sub angle.set(a as single)
    cosa=cos(a)
    sina=sin(a)
    end sub

const pii=4*atn(1)
dim shared as long min

 Function r2d (pivotx As Single,pivoty As Single,px As Single,py As Single,a As angle,scale As Single=1) As point
    Return Type(scale*(a.Cosa*(px-pivotx)-a.Sina*(py-pivoty))+pivotx, _
                scale*(a.Sina*(px-pivotx)+a.Cosa*(py-pivoty))+pivoty)
    End Function
   
sub leaf(Xpos as long, Ypos as long,_Width as long, _Height as long,numpoints as long,arr() as point)
  #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
  static as single a(1 to 4)={.85,-.15,.2,0}
  static as single b(1 to 4)={.04,.28,-.26,0}
  static as single c(1 to 4)={-.04,.26,.23,0}
  static as single d(1 to 4)={.85,.24,.22,.16}
  static as single e(1 to 4)={0,0,0,0},p(1 to 4)
  static as single f(1 to 4)={1.6,.44,1.6,0}
    Dim As single pt = 0, pi, x, y, newx, newy
    dim as integer i
For i  = 1 To 4
    select case as const i
    case 1:pi=.85
    case 2,3:pi=.07
    case 4:pi=.01
    end select
    pt+=pi
    p(i)=pt
Next i
dim as long num=numpoints
dim as long max=num+min,ctr
redim preserve arr(0 to max)
For n As long = min To max
    ctr+=1
    pi = Rnd
    i = 0
    Do:i+=1:Loop While pi > p(i)
    newx = a(i)*x+b(i)*y+e(i)
    newy = c(i)*x+d(i)*y+f(i)
    x = newx
    y = newy
        var r=map(1,num,ctr,0,155)
        arr(n)=type<point>(x*_Width+Xpos,y*_Height+Ypos,rgb(r,255-r,0))
Next n
min=max
end sub

 Function Regulate(Byval MyFps As long,Byref fps As long) As long
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function


redim as point f(0),s(0)
min=0
leaf(150,650,30,-50,50000,f())
leaf(250,640,30,-60,50000,f())
leaf(360,640,20,-50,50000,f())
min=0
leaf(150,650,20,-50,2000,s())
leaf(150,640,20,-60,2000,s())
leaf(150,640,10,-30,900,s())


#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
dim as long i,fps
dim as angle a
a.set(pii/2)
do
    i+=2
    screenlock
    cls
    line(0,600)-(900,700),rgb(0,100,0),bf
    draw string(10,10),str(fps),rgb(0,0,0)
    for n as long=lbound(s) to ubound(s) 'shadow
    var z=map(600,200,s(n).y,0,10)
    var r=r2d(200,700,s(n).x,s(n).y,a)
    circle(r.x-z*sin(i/40)-100,r.y),3,rgb(0,90,0),,,.5,f
next n

for n as long=lbound(f) to ubound(f)'tree
    var z=map(600,200,f(n).y,0,20)
    select case  n
    case is < ubound(F)/3
    pset(f(n).x+z*sin(i/50),f(n).y),f(n).col
case is >2*ubound(f)/3
    pset(f(n).x-z*sin(i/60),f(n).y),f(n).col
case else
    pset(f(n).x-z*sin(i/40),f(n).y),f(n).col
    end select
next n

screenunlock
sleep regulate(45,fps)
loop until len(inkey)

sleep
 
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Variations of a Binary Fractal Tree

Postby hurtado » Jan 23, 2020 20:01

@dodicat
That's very nice. Here is another fractal tree in fb

Code: Select all

#define cdXSize         640
#define cdYSize         400
#define deg2rad         0.01745329251994329576923690768489
#define c1              27
#define c2              6
#define c3              3

' Variables globales
dim shared as ubyte mColores(0 to 19)
dim shared as integer miColor(2 to 10)

sub FractalTree (x as integer, y as integer, angulo as integer, lon as integer)
  dim as integer x1, y1, i, p, a1, c
  if lon >= 5 then
    x1 = x + lon * cos(angulo*deg2rad)
    y1 = y + lon * sin(angulo*deg2rad)
    if lon > 95 then p = 95 else p = lon
    i = mColores(p\5)
    if int(rnd() * 2) = 0 Then
      if i = mColores(0) Then
        i = mColores(1)
      elseif i = mColores(1) then
        i = mColores(0)
      End If
    End If
    c = miColor(i)
    if i = mColores(0) Or i = mColores(1) then
      for i = 0 to c3
        Line (x + i - c3 \ 2, y)-(x1, y1), c
      next i
    else
      for i = 0 to p\c2
        Line (x + i - p \ (c2*2), y)-(x1, y1), c
      next i
    end if
    for i = 0 to 3 - int(rnd()*3)
      p = int(rnd()*(lon - lon\6)) + lon\6
      a1 = angulo - int(rnd()*55)
      x1 = x + p * cos(angulo*deg2rad) : y1 = y + p * sin(angulo*deg2rad)
      if lon > 100 then
        FractalTree (x1, y1, a1, 100-(int(rnd()*15))-c1+int(rnd()*c1))
      else
        FractalTree (x1, y1, a1, lon-(int(rnd()*15))-c1+int(rnd()*c1))
      end if
      p = int(rnd() * (lon-lon \ 6)) + lon \ 6
      a1 = angulo + int(rnd() * 55)
      x1 = x + p * cos(angulo*deg2rad) : y1 = y + p * sin(angulo*deg2rad)
      if lon > 100 then
        FractalTree (x1, y1, a1, 100-(int(rnd()*15))-c1+int(rnd()*c1))
      else
        FractalTree (x1, y1, a1, lon-(int(rnd()*15))-c1+int(rnd()*c1))
      end if
    next i
  end if
end sub

sub Inicio()
  dim as integer i
  mColores(0) = 2
  for i = 1 to 19
   mColores(i) = 6
   if i = 1 Or i = 2 then mColores(i) = 10
   if i >= 3 And i <= 6 then mColores(i) = 8
  next i
  miColor(2) = 3190051 : miColor(6) = 4136203 : miColor(8) = 1144621 : miColor(10) = 10289032
  FractalTree(cdXSize \ 2, cdYSize-1, 270, int(10*cdYSize\25))
end sub

screenres cdXSize, cdYSize, 32
Inicio()

while not inkey = chr(27) : wend
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Variations of a Binary Fractal Tree

Postby hurtado » Jan 24, 2020 17:57

Hello, the WinAPI version in 26Kb, previous in more than 100Kb. Smaller and faster if I could say. BresLine included that could be improved with Cohen-Sutherland clipping algorithm.

Code: Select all

/' ----------------------------------------------------------------------------
-       Plantilla Programación Gráfica - SWGPTG -  FreeBasic                  -
-----                                                                     -----
-       AUTOR   : Alfonso Víctor Caballero Hurtado                            -
-----                                                                     -----
-       VERSION : 1.0                                                         -
-----                                                                     -----
-      (c) 2020. http://www.abreojosensamblador.net                           -
-                Small Windows Graphics Programming Tutorial With GDI         -
---------------------------------------------------------------------------- '/

#include "windows.bi"

#define cdXPos          CW_USEDEFAULT
#define cdYPos          CW_USEDEFAULT
#define cdXSize         640
#define cdYSize         400
#define cdColFondo      0
#define MAIN_ICON       100   ' //  IDI_APPLICATION
#define cdVCursor       IDC_ARROW
#define cdVBarTipo      0
#define cdVBtnTipo      WS_OVERLAPPEDWINDOW
#define cdIdTimer       1
'#define DIB_RGB_COLORS  0
#define deg2rad         0.01745329251994329576923690768489
#define c1              27
#define c2              6
#define c3              3

' Prototipos de funciones
Declare Function WndProc (As HWND,As UINT,As WPARAM, As LPARAM) As LRESULT

'// Variables globales
'Dim Shared As Ulong Ptr             pMainDIB:  pMainDIB    =Allocate((cdXSize)*(cdYSize))
Dim Shared As Ulong Ptr              pMainDIB
Dim Shared As Integer                vdxClient, vdyClient
Dim Shared As BITMAPINFOHEADER  bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize,-cdYSize,1,32,0,0,0,0,0,0)
dim shared as ubyte mColores(0 to 19)
dim shared as Ulong miColor(2 to 10)

Sub BresLine (x1 as integer, y1 as integer, x2 as integer, y2 as integer, c as Ulong)
  dim as integer x, y, Dx, Dy, xincr, yincr, erreur, i
  Dx = abs(x2-x1)
  Dy = abs(y2-y1)
  if (x1 < x2) then xincr = 1 else xincr = -1
  if (y1 < y2) then yincr = 1 else yincr = -1
  x = x1 : y = y1
  If Dx > Dy Then
    erreur = Dx Shr 1
    for i = 0 To Dx-1
      x += xincr
      erreur += Dy
      If erreur > Dx then
        erreur -= Dx
        y += yincr
      End If
      if x >= 0 And x < cdXSize And y >= 0 And y < cdYSize Then
        *(pMainDIB + y*cdXSize+x) = c
      End If
    next i
  Else
    erreur = Dy Shr 1
    for i = 0 To Dy-1
      y += yincr
      erreur += Dx
      if erreur > Dy Then
        erreur -= Dy
        x += xincr
      End If
      if x >= 0 And x < cdXSize And y >= 0 And y < cdYSize Then
        *(pMainDIB + y*cdXSize+x) = c
      End If
    Next i
  End If
End Sub

sub FractalTree (x as integer, y as integer, angulo as integer, lon as integer)
  dim as integer x1, y1, i, p, a1
  dim as Ulong   c
  if lon >= 5 then
    x1 = x + lon * cos(angulo*deg2rad)
    y1 = y + lon * sin(angulo*deg2rad)
    if lon > 95 then p = 95 else p = lon
    i = mColores(p\5)
    if int(rnd() * 2) = 0 Then
      if i = mColores(0) Then
        i = mColores(1)
      elseif i = mColores(1) then
        i = mColores(0)
      End If
    End If
    c = miColor(i)
    if i = mColores(0) Or i = mColores(1) then
      for i = 0 to c3
        BresLine (x + i - c3 \ 2, y, x1, y1, c)
      next i
    else
      for i = 0 to p\c2
        BresLine (x + i - p \ (c2*2), y, x1, y1, c)
      next i
    end if
    for i = 0 to 3 - int(rnd()*3)
      p = int(rnd()*(lon - lon\6)) + lon\6
      a1 = angulo - int(rnd()*55)
      x1 = x + p * cos(angulo*deg2rad) : y1 = y + p * sin(angulo*deg2rad)
      if lon > 100 then
        FractalTree (x1, y1, a1, 100-(int(rnd()*15))-c1+int(rnd()*c1))
      else
        FractalTree (x1, y1, a1, lon-(int(rnd()*15))-c1+int(rnd()*c1))
      end if
      p = int(rnd() * (lon-lon \ 6)) + lon \ 6
      a1 = angulo + int(rnd() * 55)
      x1 = x + p * cos(angulo*deg2rad) : y1 = y + p * sin(angulo*deg2rad)
      if lon > 100 then
        FractalTree (x1, y1, a1, 100-(int(rnd()*15))-c1+int(rnd()*c1))
      else
        FractalTree (x1, y1, a1, lon-(int(rnd()*15))-c1+int(rnd()*c1))
      end if
    next i
  end if
end sub

Sub PintaObjeto ()
End Sub

Sub Inicio ()
  dim as integer i
  Randomize
  mColores(0) = 2
  for i = 1 to 19
   mColores(i) = 6
   if i = 1 Or i = 2 then mColores(i) = 10
   if i >= 3 And i <= 6 then mColores(i) = 8
  next i
  miColor(2) = 3190051 : miColor(6) = 4136203 : miColor(8) = 1144621 : miColor(10) = 10289032
  FractalTree(cdXSize \ 2, cdYSize-1, 270, int(10*cdYSize\25))
End Sub

Function WndProc(hWnd As HWND, message As UINT, wParam As wPARAM,lParam As LPARAM) As LRESULT
   
    Static As   HDC               bufDIBDC
    Static As  HBITMAP           hMainDIB
    Dim As      HDC               hdc
    Dim As      PAINTSTRUCT       ps
    Static As  HGDIOBJ           hOldDIB=0, hGDITmp
    Dim As     Integer               bResult
   
    Select Case message
    Case WM_CHAR
        If (wParam = VK_ESCAPE) Then
          SendMessage hWnd, WM_CLOSE, 0, 0
        End If
        Return 0
       
    Case WM_CREATE:
        hdc = GetDC(hWnd)
       
        '// Crea un búfer dib para PintaObjeto. pMainDIB es un puntero a él
        bufDIBDC = CreateCompatibleDC (hdc)
        hMainDIB = CreateDIBSection(hdc,Cast(Any Ptr, @bi), DIB_RGB_COLORS, @pMainDIB, NULL, 0)
        hOldDIB  = SelectObject (bufDIBDC, hMainDIB)
       
        ReleaseDC (hWnd, hdc)'   // Libera device context
       
        Inicio ()
        SetTimer (hWnd, cdIdTimer, 20, NULL)
        Return 0
   
    Case WM_TIMER :
        PintaObjeto ()
        InvalidateRect (hWnd, NULL, FALSE)
        Return 0

    Case WM_SIZE :
        vdxClient = lParam And &hFFFF
        vdyClient = lParam Shr &h10 '>>
        Return 0

    Case WM_PAINT :
        hdc = BeginPaint(hWnd, @ps)
        '//bResult = BitBlt(hdc, 0, 0, cdXSize, cdYSize, bufDIBDC, 0, 0, SRCCOPY)
        bResult = StretchBlt (hdc, 0, 0, vdxClient, vdyClient, bufDIBDC, 0, 0, cdXSize, cdYSize, SRCCOPY)
        EndPaint(hWnd, @ps)
        Return 0

    Case WM_DESTROY
        KillTimer (hWnd, cdIdTimer)
        hGDITmp = SelectObject (bufDIBDC, hOldDIB)
        bResult = DeleteDC (bufDIBDC)
        bResult = DeleteObject (hMainDIB)
        PostQuitMessage (0)
        Return 0
    End Select

    Return DefWindowProc (hWnd, message, wParam, lParam)
End Function

Function  WinMain ( hInstance As HINSTANCE,  hPrevInstance As HINSTANCE, _
    szCmdLine As pSTR, iCmdShow As Integer) As Integer
    Dim As  RECT   WRect
    Static As String szAppName:szAppName = "SWGPTG"
    Dim As HWND         hWnd
    Dim As MSG          msg
    Dim As WNDCLASS     wndclass
    wndclass.style         = CS_HREDRAW Or CS_VREDRAW
    wndclass.lpfnWndProc   =  @WndProc
    wndclass.cbClsExtra    = 0
    wndclass.cbWndExtra    = 0
    wndclass.hbrBackground = cdColFondo
    wndclass.lpszMenuName  = NULL
    wndclass.lpszClassName = Strptr(szAppname)
    wndclass.hInstance     = GetModuleHandle (NULL)
    wndclass.hIcon         = LoadIcon(hInstance, MAKEINTRESOURCE(MAIN_ICON))
    wndclass.hCursor       = LoadCursor (NULL, IDC_ARROW)
   
    If RegisterClass (@wndclass) =0 Then
        MessageBox (NULL, "This program requires Windows NT!", _
        "Error", MB_ICONERROR)
        Return 0
    End If
   
   
    SetRect (@WRect, 0, 0, cdXSize, cdYSize)
    AdjustWindowRectEx (@WRect, cdVBtnTipo, 0, cdVBarTipo)
    WRect.bottom -= WRect.top
    WRect.right  -= WRect.left
    WRect.left    = (GetSystemMetrics (SM_CXSCREEN) - WRect.right)/2
    WRect.top     = (GetSystemMetrics (SM_CYSCREEN) - WRect.bottom) / 3
   
    hWnd = CreateWindowex(0,szAppname ,"Árbol Fractal - (c) abreojosensamblador.epizy.com", _
    cdVBtnTipo , _
    WRect.left,WRect.top,WRect.right,WRect.bottom, _
    NULL, NULL, hInstance, NULL)
   
    ShowWindow (hWnd, iCmdShow)
    UpdateWindow (hWnd)
   
    While (GetMessage (@msg, NULL, 0, 0))
        TranslateMessage (@msg)
        DispatchMessage (@msg)
    Wend
   
    Return msg.wParam
End Function
winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)

Image
Last edited by hurtado on Jan 25, 2020 15:23, edited 1 time in total.
BasicCoder2
Posts: 3433
Joined: Jan 01, 2009 7:03

Re: Some Variations of a Binary Fractal Tree

Postby BasicCoder2 » Jan 25, 2020 9:32

@hurtado
Looks very much like a real tree. Are you able to add texture to the trunk? Placing Randomize at the start gave lots of better variations.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Variations of a Binary Fractal Tree

Postby hurtado » Jan 25, 2020 10:19

> Placing Randomize at the start gave lots of better variations
Thanks for the tip. I knew that, but I have been oxidizing some knowledge of qbasic. I usually do that with "srand(GetTickCount());"
dodicat
Posts: 6163
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Some Variations of a Binary Fractal Tree

Postby dodicat » Jan 25, 2020 13:02

Nice hurtado.
Using 32 bit colour ulong (or double) will hold all values in fb 32 bit or fb 64 bit.
I avoid using Integer or uinteger for 32 bit colours.
basiccoder2
You can adjust the colour for the second BresLine, which seems mainly the trunk.
for example:
if i>2 then c=rgb(cast(ubyte ptr,@c)[2]+rnd*10,cast(ubyte ptr,@c)[1],cast(ubyte ptr,@c)[0])
BresLine (x + i - p \ (c2*2), y, x1, y1, c)

but you should make all instances of colour ulong.
c in sub fractaltree
c in the last parameter of bresline
and the array miColor(2 to 10) should be ulong.

After all
pMainDIB is Ulong Ptr for the direct pixel plotting, so why use integer? Unless I am missing something.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Variations of a Binary Fractal Tree

Postby hurtado » Jan 25, 2020 13:40

In GDI RGBA has a maximum of 0xFFFFFF = 16,777,215, each main color goes from 0 to 255 = FF being A = 0. Even in the case of A = FF we'd have 0xFFFFFFFF = 4,294,967,295

Being 2^32 = 4,294,967,296

So, using uint is not only enough but the correct, even in the case of 64 bits, that RGBA still has a maximum of 0xFFFFFF = 16,777,215, 4,294,967,295 if you want that is 2^32, because each main color goes from 0 to FF

Maybe pMainDIB should be UInt Ptr instead of Ulong Ptr

Of course, we could access to two colors at the same time in 64 bits:

Code: Select all

    cld
    mov      rdi, [pMainDIB]               ; Points to DIB buffer
    mov      rcx, cdXSize*cdYSize/2        ;DIB elements are dword
    mov      rax, 0xFFBBCC00FFBBCC
    rep      stosq


If we point to qword instead dword, we could overlap the before color, but it if are drawing 0000color in little endian those zeros go at the right. If we move 1 dword we do it right always but at the end that we exced in 1 dword the buffer magnitude.

As I am writing this I look to my c code, pMainDIB is an int point. For paint pourposes uint and int is the same.


Reviewing fb types. ULong seems to be the correct. Is 32 bits long in 32 and 64 bits. Well, you were right
Last edited by hurtado on Jan 25, 2020 14:06, edited 1 time in total.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Variations of a Binary Fractal Tree

Postby hurtado » Jan 25, 2020 13:47

@BasicCoder, the tree is drawed using lines, to add a texture to any object of it, it would be needed to modify the program' structure. Instead of painting with lines, maybe we should calculate the border points, for example for the trunk, divide it in triangles and then using this triangles to add textures. This is an option, but could be others.
Last edited by hurtado on Jan 25, 2020 15:23, edited 1 time in total.
dodicat
Posts: 6163
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Some Variations of a Binary Fractal Tree

Postby dodicat » Jan 25, 2020 14:40

Yea hurtado, I know that integer plods through 0 to 255 in four loops for rgba(r,g,b,a) just as well as ulong.
But as you have seen integer is actually longint in 64 bits.
So, depending on how you use colours (via pointers e.t.c.), strange aberrations can occur flipping between the 64 and 32 bit compilers if you don't simply use ulong to represent 32 bit colours.
paul doe
Posts: 1068
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: Some Variations of a Binary Fractal Tree

Postby paul doe » Jan 25, 2020 16:09

@hurtado: You can alternatively request the correct size in FreeBasic like this:

Code: Select all

'' 32-bit signed
dim as integer<32> _
  a

'' 32-bit unsigned
dim as uinteger<32> _
  b
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Variations of a Binary Fractal Tree

Postby hurtado » Jan 25, 2020 18:09

Good info, thank you guys

Return to “Tips and Tricks”

Who is online

Users browsing this forum: MSN [Bot] and 1 guest