Die Geschwindigkeit ist garantiert noch steigerbar, reicht hier für mich
aber aus.
Die Engine:
Code: Alles auswählen
;**
;* Library to calculate and draw the lindenmayer systems._
;* © 2006 by Remi Meier_
;* _
;* ALL STRINGS are expected as ASCII, NOT UNICODE!
;** /onlydll
;** /notstart _
;** /noglobals
EnableExplicit
; return #true to stop
Prototype.l CallBackProc(Percentage.f)
#MAX_AXIOMS = 10 ;* Maximum number of axioms/rules
Structure AXIOM
Name.s ;* the name (i. c. F)
Expr.s ;* the expression (i. c. [+F]-F)
EndStructure
Structure CALCULATEINFO
; [in]
cbFunc.CallBackProc ;* [in]Callback procedure, return #true to stop calculations:<br> Prototype.l CallBackProc(Percentage.f)<br>Can be Null
startAxiom.s ;* [in]starting state / entry point for program iterations
axioms.AXIOM[#MAX_AXIOMS] ;* [in]the axioms/rules
nbIterations.l ;* [in]number of iterations to do
; [out]
way.s ;* [out]the calculated way of the turtle.
EndStructure
;** lscalculate
;* you can start it as a thread, but don't forget that a too high nbIterations
;* will cause problems. The callback procedure will be called several times each iteration,
;* but that can be too few. Nevertheless, you should not kill the thread, this
;* can cause program crashes!
ProcedureDLL LSCalculate(*info.CALCULATEINFO)
Protected d.s, i.l, z.l, n.l
Protected Percentage.f
*info\way = *info\startAxiom
If *info\nbIterations >= 0
For i = 1 To *info\nbIterations
z = 0
For n = 0 To #MAX_AXIOMS - 1
If *info\axioms[n]\Name
d.s = RSet(Str(z), 4, "0")
; F+F+X -> F+F+01
*info\way = ReplaceString(*info\way, *info\axioms[n]\Name, d)
If *info\cbFunc And *info\cbFunc(Percentage)
Break 2
EndIf
z + 1
Else
Break
EndIf
Next
z = 0
For n = 0 To #MAX_AXIOMS - 1
If *info\axioms[n]\Name
; F+F+1 -> F+F+ [+X]
d.s = RSet(Str(z), 4, "0")
*info\way = ReplaceString(*info\way, d, *info\axioms[n]\Expr)
If *info\cbFunc And *info\cbFunc(Percentage)
Break 2
EndIf
z + 1
Else
Break
EndIf
Next
Percentage = i / *info\nbIterations
Next
EndIf
EndProcedure
;- Lindenmayer-Zeichnen
Structure DRAWINFO
cbFunc.CallBackProc ;* [in]Callback procedure, return #true to stop calculations:<br> Prototype.l CallBackProc(Percentage.f)
hdc.l ;* [in]HDC to draw on.
dx.l ;* [in]starting x position = x
dy.l ;* [in]starting y position = y
dAngleInc.f ;* [in]Angle increment / Turning angle
dDirect.f ;* [in]starting direction / angle
dLineWidth.l;* [in]line width
dLineLength.f ;* [in]line length
dLineLengthFactor.f ;* [in]line length factor
dAngleIncInc.f ;* [in]turning angle increment
FColor.l ;* [in]gradient's starting color
FFColor.l ;* [in]gradient's ending color
DrawingRoute.s ;* [in]the way of the turtle, NOT UNICODE!
EndStructure
Structure _LSDRAWINGSTATE
x.f
y.f
Direct.f
AngleInc.f
AngleIncInc.f
LineWidth.l
LineWidthInc.l
LineLength.f
LineLengthFactor.f
Reverse.l
EndStructure
Global NewList LSStack._LSDRAWINGSTATE()
Global __hDC.l, __pen.l, __hPenOld.l, __Color.l, __MaxDepth.l, __hBrush.l, __Brush.l
Global GLOB.DRAWINFO
Procedure.l LSGetGradientColor(Color1.l, Color2.l, Ratio.f)
Protected r1.l, g1.l, b1.l, r2.l, g2.l, b2.l
Protected r.l, g.l, b.l
r1 = Red(Color1)
g1 = Green(Color1)
b1 = Blue(Color1)
r2 = Red(Color2)
g2 = Green(Color2)
b2 = Blue(Color2)
r = r1 + (r2 - r1) * Ratio
g = g1 + (g2 - g1) * Ratio
b = b1 + (b2 - b1) * Ratio
ProcedureReturn RGB(r, g, b)
EndProcedure
Procedure LSLine(x,y,x1,y1)
MoveToEx_(__hDC,x,y,0)
LineTo_(__hDC,x1,y1)
EndProcedure
Procedure LSSetDrawingState(x.l, y.l)
If CountList(LSStack()) < 1
AddElement(LSStack())
Else
LastElement(LSStack())
EndIf
LSStack()\x = x
LSStack()\y = y
LSStack()\AngleInc = GLOB\dAngleInc
LSStack()\Direct = GLOB\dDirect
LSStack()\LineWidth = GLOB\dLineWidth
LSStack()\LineWidthInc = 1
LSStack()\LineLength= GLOB\dLineLength
LSStack()\Reverse = 1
LSStack()\LineLengthFactor = GLOB\dLineLengthFactor
LSStack()\AngleIncInc = GLOB\dAngleIncInc
EndProcedure
;{ Declares
Declare LSForD()
Declare LSFor()
Declare LSTL()
Declare LSTR()
Declare LSRD()
Declare LSPUS()
Declare LSPOS()
Declare LSILW()
Declare LSDLW()
Declare LSDD()
Declare LSOP()
Declare LSCP()
Declare LSMLL()
Declare LSDLL()
Declare LSSD()
Declare LSDA()
Declare LSIA()
Declare LSCA(*p.Byte)
Declare LSCLL(*p.Byte)
;}
Procedure LSAnalyzeDepth(s.s)
Protected *p.Byte, current.l, max.l
current = 1
max = 1
*p = @s
If *p
While *p\b
If *p\b = '['
current + 1
If current > max
max = current
EndIf
ElseIf *p\b = ']'
current - 1
EndIf
*p + 1
Wend
EndIf
ProcedureReturn max
EndProcedure
;** lsdraw
;* Draws on a given HDC, you can draw in a thread. Mostly faster and less problematic than
;* LSCalculate(). For more info see LSCalculate().
ProcedureDLL LSDraw(*info.DRAWINFO)
Protected *p.Byte, n.l, max.l, x.l, y.l, Percentage.f
CopyMemory(*info, @GLOB, SizeOf(DRAWINFO) - 4) ; without String!
x = *info\dx
y = *info\dy
ClearList(LSStack())
LSSetDrawingState(x, y)
*p = @*info\DrawingRoute
max = Len(*info\DrawingRoute)
__hDC = *info\hdc
__MaxDepth = LSAnalyzeDepth(*info\DrawingRoute)
__Color = GLOB\FColor
__pen = CreatePen_(#PS_SOLID, LSStack()\LineWidth, __Color)
__hPenOld = SelectObject_(__hDC, __pen)
__Brush = CreateSolidBrush_(__Color)
__hBrush = SelectObject_(__hDC, __Brush)
If *p <> 0
While *p\b
If *info\cbFunc And *info\cbFunc(Percentage)
Break
EndIf
Select *p\b
Case 'F'
LSForD()
Case 'f'
LSFor()
Case '+'
LSTL()
Case '-'
LSTR()
Case '|'
LSRD()
Case '['
LSPUS()
Case ']'
LSPOS()
Case '#'
LSILW()
Case '!'
LSDLW()
Case '@'
LSDD()
Case '{'
LSOP()
Case '}'
LSCP()
Case '>'
LSMLL()
Case '<'
LSDLL()
Case '&'
LSSD()
Case '('
LSDA()
Case ')'
LSIA()
Case '%'
*p = LSCA(*p)
Case '$'
*p = LSCLL(*p)
EndSelect
*p + 1
n + 1
Percentage = n / max
Wend
EndIf
DeleteObject_(__pen)
SelectObject_(__hDC, __hPenOld)
DeleteObject_(__Brush)
SelectObject_(__hDC, __hBrush)
EndProcedure
#PIOVER180 = 3.14159262 / 180.0
Procedure LSForD()
Protected k.f, x.f, y.f
If CountList(LSStack()) > 0
k.f = LSStack()\Direct * #PIOVER180
x.f = LSStack()\x + Sin(k) * LSStack()\LineLength
y.f = LSStack()\y + Cos(k) * LSStack()\LineLength
LSLine(LSStack()\x, LSStack()\y, x, y);, Stack()\LineWidth)
LSStack()\x = x
LSStack()\y = y
EndIf
EndProcedure
Procedure LSFor()
Protected k.f, x.f, y.f
If CountList(LSStack()) > 0
k.f = LSStack()\Direct * #PIOVER180
x.f = LSStack()\x + Sin(k) * LSStack()\LineLength
y.f = LSStack()\y + Cos(k) * LSStack()\LineLength
LSStack()\x = x
LSStack()\y = y
EndIf
EndProcedure
Procedure LSTL()
If CountList(LSStack()) > 0
LSStack()\Direct + LSStack()\AngleInc * LSStack()\Reverse
EndIf
EndProcedure
Procedure LSTR()
If CountList(LSStack()) > 0
LSStack()\Direct - LSStack()\AngleInc * LSStack()\Reverse
EndIf
EndProcedure
Procedure LSRD()
If CountList(LSStack()) > 0
LSStack()\Direct + 180
EndIf
EndProcedure
Procedure LSPUS()
Protected *p._LSDRAWINGSTATE, n.l
n = CountList(LSStack())
If n > 0
*p._LSDRAWINGSTATE = AllocateMemory(SizeOf(_LSDRAWINGSTATE))
CopyMemory(@LSStack(), *p, SizeOf(_LSDRAWINGSTATE))
AddElement(LSStack())
CopyMemory(*p, @LSStack(), SizeOf(_LSDRAWINGSTATE))
FreeMemory(*p)
DeleteObject_(__Brush)
DeleteObject_(__pen)
__Color = LSGetGradientColor(GLOB\FColor, GLOB\FFColor, n / __MaxDepth)
__pen = CreatePen_(#PS_SOLID,LSStack()\LineWidth, __Color)
__Brush = CreateSolidBrush_(__Color)
SelectObject_(__hDC,__pen)
SelectObject_(__hDC, __Brush)
EndIf
EndProcedure
Procedure LSPOS()
Protected n.l
n = CountList(LSStack())
If n > 1
DeleteElement(LSStack())
DeleteObject_(__Brush)
DeleteObject_(__pen)
__Color = LSGetGradientColor(GLOB\FColor, GLOB\FFColor, n / __MaxDepth)
__pen = CreatePen_(#PS_SOLID,LSStack()\LineWidth, __Color)
__Brush = CreateSolidBrush_(__Color)
SelectObject_(__hDC,__pen)
SelectObject_(__hDC, __Brush)
EndIf
EndProcedure
Procedure LSILW()
If CountList(LSStack()) > 0
LSStack()\LineWidth + LSStack()\LineWidthInc
DeleteObject_(__pen)
__pen = CreatePen_(#PS_SOLID, LSStack()\LineWidth, __Color)
SelectObject_(__hDC, __pen)
EndIf
EndProcedure
Procedure LSDLW()
If CountList(LSStack()) > 0
LSStack()\LineWidth - LSStack()\LineWidthInc
DeleteObject_(__pen)
__pen = CreatePen_(#PS_SOLID,LSStack()\LineWidth, __Color)
SelectObject_(__hDC, __pen)
EndIf
EndProcedure
Procedure LSDD()
If CountList(LSStack()) > 0
;MoveToEx_(__hDC,Stack()\x,Stack()\y,0)
Ellipse_(__hDC, Int(LSStack()\x-LSStack()\LineWidth), Int(LSStack()\y-LSStack()\LineWidth), Int(LSStack()\x+LSStack()\LineWidth), Int(LSStack()\y+LSStack()\LineWidth))
;Circle(Stack()\x, Stack()\y, Stack()\LineWidth, __Color) ; doesn't work because of the thread.
EndIf
EndProcedure
Procedure LSOP()
If CountList(LSStack()) > 0
;- not implemented
EndIf
EndProcedure
Procedure LSCP()
If CountList(LSStack()) > 0
;- not implemented
EndIf
EndProcedure
Procedure LSMLL()
If CountList(LSStack()) > 0
LSStack()\LineLength * LSStack()\LineLengthFactor
EndIf
EndProcedure
Procedure LSDLL()
If CountList(LSStack()) > 0
LSStack()\LineLength / LSStack()\LineLengthFactor
EndIf
EndProcedure
Procedure LSSD()
If CountList(LSStack()) > 0
If LSStack()\Reverse = 1
LSStack()\Reverse = -1
Else
LSStack()\Reverse = 1
EndIf
EndIf
EndProcedure
Procedure LSDA()
If CountList(LSStack()) > 0
LSStack()\AngleInc - LSStack()\AngleIncInc
EndIf
EndProcedure
Procedure LSIA()
If CountList(LSStack()) > 0
LSStack()\AngleInc + LSStack()\AngleIncInc
EndIf
EndProcedure
Procedure LSCA(*p.Byte)
Protected s.s
s = ""
*p + 1
While *p\b And ((*p\b > 47 And *p\b < 58) Or *p\b = '.')
s + Chr(*p\b)
*p + 1
Wend
*p - 1
If s <> ""
LSStack()\AngleInc = ValF(s) ;+ Stack()\Direct
EndIf
ProcedureReturn *p
EndProcedure
Procedure LSCLL(*p.Byte)
Protected s.s
s = ""
*p + 1
While *p\b And ((*p\b > 47 And *p\b < 58) Or *p\b = '.')
s + Chr(*p\b)
*p + 1
Wend
*p - 1
If s <> ""
LSStack()\LineLength = ValF(s)
EndIf
ProcedureReturn *p
EndProcedure
Code: Alles auswählen
IncludeFile "Lindenmayer-Lib.pb"
DisableExplicit
CreateImage(1, 500, 500)
hdc = StartDrawing(ImageOutput(1)) ;>
Box(0, 0, 500, 500, 0)
lmayer.CALCULATEINFO
With lmayer
\cbFunc = 0
\startAxiom = "Z"
\axioms[0]\Name = "Z"
\axioms[0]\Expr = "[++++++++++++++++++ffffffff------------------Z][++++++++++++++++++ffff------------------FFX][FFX]"
\axioms[1]\Name = "X"
\axioms[1]\Expr = "F[+++blatt][---------------blatt]-X"
\axioms[2]\Name = "blatt"
\axioms[2]\Expr = "F++++++++++++F++++++++++++++++++++++++F++++++++++++F"
\nbIterations = 10
EndWith
LSCalculate(@lmayer)
ldraw.DRAWINFO
With ldraw
\cbFunc = 0
\hdc = hdc
\dx = 420
\dy = 250
\dAngleInc = 5
\dDirect = 180
\dLineWidth = 1
\dLineLength = 5
\dLineLengthFactor = 0.8
\dAngleIncInc = 0.2
\FColor = $FF
\FFColor = 0
\DrawingRoute = lmayer\way
EndWith
LSDraw(@ldraw)
StopDrawing() ;<
OpenWindow(0, 200, 200, 500, 500, "L-System Test")
CreateGadgetList(WindowID(0))
ImageGadget(1, 0, 0, 500, 500, ImageID(1))
Repeat
Until WaitWindowEvent() = #PB_Event_CloseWindowViel Spass damit
Danke! Hab noch nachträglich einen kleinen Bug ent-