Some Variations of a Binary Fractal Tree

[Bolee]

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.

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.

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.

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).

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.

[paul doe]

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

...
I wanted to upload some screen captures but need to find a free site to host the images.
...

May I suggest ImgBox?

[badidea]

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]

...
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]

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]

@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]

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)

[BasicCoder2]

@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]

> 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]

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]

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

[hurtado]

@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.

[dodicat]

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]

@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]

Good info, thank you guys