L-system fractals!

Miscellaneous Forums/Blitz Showcase/L-system fractals!

chwaga
 #1
Hi, I just thought I'd share with you some Lindenmayer system fractals a made a month back. The code is sloppy and probably uncommented, but you can make some pretty neat stuff with it.

I only made 2: a (fake) Serpinski triangle, and a Dragon's curve.

Find them here and here

And for the source...

Fractal1.exe:
Graphics3D 1024, 768, 32, 2


Const Rule$ = "F+F-F-F+F"
Const Angle# = 120
Global Length# = 10
Global a# = 0
Global iterations# = 0

Global LString$ = "F"
DrawFractal()
Repeat

	If KeyHit(57) Then KochIt()
	If MouseHit(2) Then Stop 
	
Until KeyHit(1)

End


Function DrawFractal()
	Cls
	RenderWorld()
	Local x1#, y1#, x2#, y2#
	x1 = 0 : y1 = 768
	tmpstr$ = LString$
	
	;Scale the triangle by iteration count
	Length = -7*iterations + 54
	
	For i = 1 To Len(tmpstr)
		If Mid$(tmpstr, i, 1) = "F" Then 
			x2# = x1# + Length# * Cos(a)
			y2# = y1# + Length# * Sin(a)
			Line x1, y1, x2, y2
			x1 = x2 : y1 = y2
		EndIf
		If Mid$(tmpstr, i, 1) = "+" Then 
			a = a - Angle
		EndIf
		If Mid$(tmpstr, i, 1) = "-" Then 
			a = a + Angle
		EndIf
	Next
	
	Flip()
End Function 


Function KochIt()
	tmpstr$ = LString$
	Local x1, y1, x2, y2, a#
	x2 = 0 : y2 = 384
	LString$ = ""
	For i = 1 To Len(tmpstr)
		tmpchr$ = Mid$(tmpstr, i, 1)
		If tmpchr$ = "F" Then 
			LString = LString + Rule$
		ElseIf tmpchr$ = "+"
			LString = LString + "+"
		ElseIf tmpchr$ = "-"
			LString = LString + "-"
		EndIf
	Next
	iterations = iterations+1
	DrawFractal()
End Function


And Fractal2.exe:

Graphics3D 1024, 768, 32, 2


Const Rule$ = "X+YF+"
Const Rule2$ = "-FX-Y"
Const Angle# = 90
Global Length# = 10
Global a# = 0
Global iterations# = 0
Global playerscale# = 1
Global LString$ = "FX"
DrawFractal()
Repeat

	If KeyHit(57) Then KochIt()
	If MouseHit(2) Then Stop 
	If KeyHit(200) Then ScUp()
	If KeyHit(208) Then ScDown()
	
Until KeyHit(1)

End


Function DrawFractal()
	Cls
	RenderWorld()
	Local x1#, y1#, x2#, y2#
	x1 = 640 : y1 = 525
	tmpstr$ = LString$
	

	;Scale it by iteration count
	Length = 100-(iterations*8)*playerscale
	If length =< 0 Then length = 1
	
	For i = 1 To Len(tmpstr)
		If Mid$(tmpstr, i, 1) = "F" Then 
			;COLORS!!!!!!
			c# = (255*i)/Len(tmpstr)
			Color c, -c, c
			


			x2# = x1# + Length# * Cos(a)
			y2# = y1# + Length# * Sin(a)
			Line x1, y1, x2, y2
			x1 = x2 : y1 = y2
		EndIf
		If Mid$(tmpstr, i, 1) = "+" Then 
			a = a - Angle
		EndIf
		If Mid$(tmpstr, i, 1) = "-" Then 
			a = a + Angle
		EndIf
	Next
	
	Text 0, 0, "Iteration " + iterations
	Text 0, 24, "Zoom = " + playerscale
	Flip()
End Function 


Function ScUp()
	playerscale = playerscale - 0.05
	DrawFractal()
End Function

Function ScDown()
	playerscale = playerscale + 0.05
	DrawFractal()
End Function


Function KochIt()
	tmpstr$ = LString$
	LString$ = ""
	For i = 1 To Len(tmpstr)
		tmpchr$ = Mid$(tmpstr, i, 1)
		If tmpchr$ = "X" Then 
			LString = LString + Rule$
		ElseIf tmpchr$ = "Y"
			LString = LString + Rule2$
		ElseIf tmpchr$ = "+"
			LString = LString + "+"
		ElseIf tmpchr$ = "-"
			LString = LString + "-"
		EndIf
	Next
	iterations = iterations+1
	DrawFractal()
End Function


Anyone who wants to modify this so it's more flexible is more than welcome! Try changing the angle values, you get some weird results. Check out the dragon (fractal2) at 75 degrees

chwaga
 #2
bah, it's cool and you know it! somebody comment on my day's work!!!!!!

Xzider
 #3
Neat

Torrente
 #4
It's cool, but it's also been done 2 or 3 times on these forums before ;)

It'd be much neater if you made an .exe that could read a file containing the information about the L-system (rules, line-length, angles, etc...), and then saves that image. A lot easier to show your work that way. Also, make support for an arbitrary amount of rules, and then you'll be on a roll.

chwaga
 #5
nah, I'm busy :P

TomToad
 #6
I actually made something like that. It would read the commands from a .txt file, then compute it twice. First time without rendering, to figure out the extreme coordinates, then second time, scaling so it fits perfectly within the window.
Unfortunately it is on my old drive so I don't have it available to show at the moment.

Edit: Found it. Here is the source to the one I wrote.
also it is a Blitz3D program and I never commented the code.

Const TOKEN_EOL = 0
Const TOKEN_COMMAND = 1
Const TOKEN_STRING = 2
Const TOKEN_NUMBER = 3
Const STATE_NEWLINE = 0
Const STATE_INLINE = 1

Type turtle
 Field x#,y#
 Field theta#
 Field pendown
 Field penstuck
End Type
Global turtle.turtle = New turtle
turtle\pendown = True

Type turtlestack
 Field x#,y#
 Field theta#
 Field thetastep#
 Field movestep#
End Type


Type callstack
 Field editline$
 Field position
 Field order
End Type


Type opstack
 Field op
End Type

Global thetastep#
Global movestep#
Global token$
Global level
Global callstack.callstack
Global minx#,miny#,maxx#,maxy#
Dim linedef$(255)
For t = 0 To 255
 linedef$(t) = "default"
Next

Function TForward(distance#)
DebugLog "forward"

 x# = turtle\x + Cos(turtle\theta) * distance
 y# = turtle\y + Sin(turtle\theta) * distance
 If turtle\pendown = True Then Line turtle\x,turtle\y,x,y

 turtle\x = x
 turtle\y = y
 If x < minx Then minx = x
 If x > maxx Then maxx = x
 If y < miny Then miny = y
 If y > maxy Then maxy = y
End Function

Function TRight(angle#)
 turtle\theta = turtle\theta + angle
 While turtle\theta > 180
  turtle\theta = turtle\theta - 360
 Wend
 While turtle\theta < -179
  turtle\theta = turtle\theta + 360
 Wend
End Function

Function TLeft(angle#)
 turtle\theta = turtle\theta - angle
 While turtle\theta < -179
  turtle\theta = turtle\theta + 360
 Wend
 While turtle\theta > 180
  turtle\theta = turtle\theta - 360
 Wend
End Function

Function TPenUp()
 If turtle\penstuck = False Then turtle\pendown = False
 DebugLog turtle\pendown
End Function

Function TPenDown()
 If turtle\penstuck = False Then turtle\pendown = True
DebugLog turtle\pendown
End Function

Function TPush()
 turtlestack.turtlestack = New turtlestack
 turtlestack\x = turtle\x
 turtlestack\y = turtle\y
 turtlestack\theta = turtle\theta
 turtlestack\thetastep = thetastep
 turtlestack\movestep = movestep
End Function

Function TPop()
 turtlestack.turtlestack = Last turtlestack
 If turtlestack = Null Then RuntimeError "Turtle stack underflow error!!"
 turtle\x = turtlestack\x
 turtle\y = turtlestack\y
 turtle\theta = turtlestack\theta
 thetastep = turtlestack\thetastep
 movestep = turtlestack\movestep
 Delete turtlestack
End Function

Function parse()
callstack.callstack = New callstack
callstack\editline = linedef(0)
callstack\position = 1
callstack\order = 0
Repeat
 While callstack\position > Len(callstack\editline)
  Delete callstack
  callstack.callstack = Last callstack
  If callstack = Null Then Return
  DebugLog "returning to "+callstack\editline+" position "+callstack\position
 Wend
 c$ = Mid(callstack\editline,callstack\position,1)
 DebugLog "testing "+c$
 callstack\position = callstack\position + 1
 If Asc(c$) <> - 1
  If linedef(Asc(c$)) = "default" Or callstack\order = 1
   Select(c$)
   Case "f"
    DebugLog "f"
    TForward(movestep)
   Case "g"
    DebugLog "g"
    TPenUp()
    TForward(movestep)
    TPenDown()
   Case "["
    TPush()
   Case "]"
    TPop()
   Case "!"
    thetastep = -thetastep
   Case "-"
    DebugLog "-"
    TRight(thetastep)
   Case "+"
    DebugLog "+"
    TLeft(thetastep)
   Case "@"
    numvalue# = 0.0
    position2 = callstack\position
    tc$ = Mid(callstack\editline,position2,1)
    While ((tc$ >= "0" And tc <= "9") Or tc = ".") And position2 <= Len(callstack\editline)
     position2 = position2 + 1
     tc$ = Mid(callstack\editline,position2,1)
    Wend
    numvalue = Mid(callstack\editline,callstack\position,position2-callstack\position)
    movestep = movestep * numvalue
   End Select
  Else
   DebugLog "calling "+c$
   order = callstack\order
   callstack.callstack = New callstack
   callstack\editline = linedef(Asc(c$))
   callstack\position = 1 
   If order = 0
    callstack\order = level
   Else
    callstack\order = order - 1
   End If
  End If
 End If
Forever
End Function

Graphics 1024,768,32,0

Cls
com$ = CommandLine()
If com$ <> ""
 filename$ = Mid(com,2,Len(com)-2)
Else
 filename$ = Input("Input file To parse: ")
End If
lineno = 0

filein = ReadFile(filename)
If filein = 0 Then RuntimeError "error opening file "+filename
While Not Eof(filein)
 c$ = Lower(ReadLine(filein))
 lineno = lineno + 1
 position = 0
 Repeat
  If position > Len(c$) Then Exit
  position = position + 1
 Until Mid(c$,position,1) <> " "
 If position <= Len(c$)
  c$ = Right(c$,(Len(c$)-position)+1)
  Select Left(c$,5)
  Case "angle"
   numvalue# = 0
   position = 7
   position2 = 7
   If Len(c$) > 6 
    tc$ = Mid(c$,position2,1)
    While ((tc$ >= "0" And tc <= "9") Or tc = ".") And position2 <= Len(c$)
     position2 = position2 + 1
     tc$ = Mid(c$,position2,1)
    Wend
    numvalue = Mid(c$,position,position2-position)
   End If
   DebugLog "Angle " + numvalue +" "+ position+" " + position2
   If numvalue = 0 Or numvalue >= 360 Then RuntimeError "line "+lineno+": Angle must be >0 And <360"
   thetastep = numvalue
  Case "axiom"
   If linedef(0) = "default" Then linedef(0) = ""
   position = 6
   Repeat
    tc$ = Mid(c$,position,1)
    position = position + 1
   Until (tc$ <> " " And tc$ <> "=") Or position > Len(c$)
   position = position - 1
   If position <= Len(c$)
    While position <= Len(c$) And Mid(c$,position,1) <> " " And Mid(c$,position,1) <> ";"
     linedef(0) = linedef(0) + Mid(c$,position,1)
     position = position + 1
    Wend
   Else
    RuntimeError "Axiom not defined"
   End If
   DebugLog linedef(0)
  Default
   DebugLog "here"
   tc$ = Left(c$,1)
   If tc <> ";"
    position = 2
    While Mid(c$,position,1) = " " And position <= Len(c$)
     position = position + 1
    Wend
    If Mid(c$,position,1) <> "=" Or position > Len(c$) Then RuntimeError "line "+lineno+": missing ="
    position = position + 1
    If linedef(Asc(tc)) = "default" Then linedef(Asc(tc)) = ""
    While position <= Len(c$)
     While Mid(c$,position,1) = " " And position <= Len(c$)
      position = position + 1
     Wend
     If position <= Len(c$)
      If Mid(c$,position,1) <> ";"
       linedef(Asc(tc)) = linedef(Asc(tc)) + Mid(c$,position,1)
       position = position + 1
      Else
       Exit
      End If
     End If
    Wend
    DebugLog tc+"="+linedef(Asc(tc))
   End If
    
  End Select
  
 End If
   
Wend

Repeat
 Cls
 level = Input("Level? ")
 If level = 0 Then Exit
 Cls
 Print "Thinking......"

 turtle\x = 0
 turtle\y = 0
 turtle\theta = -90
 movestep = 10
 TPenUp()
; turtle\penstuck = True
 minx# = 0
 miny# = 0
 maxx# = 0
 maxy# = 0
 parse()
 Cls
 maxx = maxx - minx
 maxy = maxy - miny

 If maxx/maxy > 1.333333333333
  scale# = 1023.0/maxx
 Else
  scale# = 767.0/maxy
 End If

 turtle\x = -minx*scale
 turtle\y = -miny*scale
 turtle\theta = -90
 movestep = 10*scale
 turtle\penstuck = False
 TPenDown()
 parse()
WaitKey()
Forever


Here is hilbert.ls
angle 90
axiom=x
x=-yf+xfx+fy-
y=+xf-yfy-fx+


Axel Wheeler
 #7
Very cool. Even if it's been done before, nothing stretches your brain like implementing something like this.

I would add a percent complete indicator and a cancel option during processing.

Well done Chwaga!