Code:
#pragma mode( separator(.,;) integer(h64) )
// Fractal : Lindenmayer system
// V 1.5 02/2013
// V 2.0 08/2014 taking advantage of Rev 6030
// and more fractals
// simplify and speedup
EXPORT LSangle, LSdir, LSaxiom, LSaxiomOrg, LSgen, LSrules, LSNum;
Stk, Clr, Aspect, LPoints, LLines, Timing;
//EXPORT Xmin, Xmax, YMin, YMax;
// Stack functions
StkInit()
BEGIN
Stk:= {0};
END;
StkPush(val)
BEGIN
Stk:= CONCAT(Stk, {val});
END;
StkPop()
BEGIN
LOCAL Tmp;
Tmp:= Stk(SIZE(Stk));
Stk:= SUB(Stk,1,SIZE(Stk)-1);
RETURN Tmp;
END;
LSclr(Ndx)
BEGIN // Color for a segment
Ndx:= ROUND(Ndx*186,0);
IF Ndx < 31 THEN RETURN RGB(0,0,Ndx*8); END;
IF Ndx < 62 THEN RETURN RGB(0,(Ndx-31)*8,31*8); END;
IF Ndx < 93 THEN RETURN RGB(0,31*8,(92-Ndx)*8); END;
IF Ndx < 124 THEN RETURN RGB((Ndx-93)*8,31*8,0); END;
IF Ndx < 155 THEN RETURN RGB(31*8,(154-Ndx)*8,0); END;
IF Ndx < 186 THEN RETURN RGB(31*8,0,(Ndx-155)*8); END;
RETURN RGB(31*8,0,31*8);
END;
LSdraw(Axiom)
BEGIN
LOCAL Scan, Code, LineT, Xp, Yp, Ap, Tmp;
IF SIZE(LPoints) == 0 THEN
StkInit(); Xp:= 0; Yp:= 0; Ap:= LSdir;
Xmin:= 0; Xmax:= 0; Ymin:= 0; Ymax:= 0;
LPoints:= {{0},{0}}; LLines:= {}; LineT:= 1;
FOR Scan FROM 1 TO dim(Axiom) DO
Code:= mid(Axiom,Scan,1);
IF Code = "F" OR Code = "G" THEN
Xp:= Xp+ sin(Ap); Yp:= Yp+ cos(Ap);
IF Code = "F" THEN LPoints[1]:= CONCAT(LPoints[1], Xp); LPoints[2]:= CONCAT(LPoints[2], Yp); LLines:= CONCAT(LLines,{{LineT,SIZE(LPoints[1]),#0}}); LineT:= SIZE(LPoints[1]); END;
END;
IF Code = "-" THEN Ap:= Ap- LSangle; END;
IF Code = "+" THEN Ap:= Ap+ LSangle; END;
IF Code = "|" THEN Ap:= Ap+ 180; END;
IF Code = "[" THEN StkPush(Xp); StkPush(Yp); StkPush(Ap); StkPush(LineT); END;
IF Code = "]" THEN LineT:= StkPop(); Ap:= StkPop(); Yp:= StkPop(); Xp:= StkPop(); END;
END;
IF SIZE(LPoints) > 1 THEN
// échelle
Xmin := MIN(LPoints[1])-1; Xmax := MAX(LPoints[1])+1;
Ymin := MIN(LPoints[2])-1; Ymax := MAX(LPoints[2])+1;
CASE
IF Aspect == 0 THEN END;
IF (Xmax- Xmin)*3 < (Ymax- Ymin)*4 THEN Tmp:= ((Ymax- Ymin)*4/3 - (Xmax- Xmin))/2; Xmin:= Xmin-Tmp; Xmax:= Xmax+Tmp; END;
IF (Xmax- Xmin)*3 > (Ymax- Ymin)*4 THEN Tmp:= ((Xmax- Xmin)*3/4 - (Ymax- Ymin))/2; Ymin:= Ymin-Tmp; Ymax:= Ymax+Tmp; END;
END;
IF Clr == 1 THEN // couleur
FOR Xp FROM 1 TO SIZE(LLines) DO
LLines[Xp,3]:= LSclr(Xp/SIZE(LLines));
END;
END;
LPoints[1]:= 320/(Xmax-Xmin)*(LPoints[1]-Xmin);
LPoints[2]:= 240/(Ymax-Ymin)*(Ymax-LPoints[2]);
LPoints;
Tmp:= {}; // transposition liste de listes
FOR Xp FROM 1 TO SIZE(LPoints[1]) DO
Tmp:= CONCAT(Tmp,{{LPoints[1,Xp],LPoints[2,Xp]}});
END;
LPoints:= Tmp;
END;
END;
RECT();
IF SIZE(LPoints) > 1 THEN
LINE_P(LPoints,LLines,[[1,0],[0,1]]);
END;
RETURN;
END;
LSnext(Axiom)
BEGIN // Calc next generation
LOCAL LSalpha, Scan, Pos, Rep;
Timing:=Ticks;
LSalpha:= "";
FOR Scan FROM 1 TO SIZE(LSrules) DO
LSalpha:= LSalpha+ LSrules(Scan,1);
END;
Rep:= "";
FOR Scan FROM 1 TO dim(Axiom) DO
Pos:= instring(LSalpha, mid(Axiom,Scan,1));
IF Pos THEN
Rep:= Rep+ LSrules(Pos,2);
ELSE
Rep:= Rep+ mid(Axiom,Scan,1);
END;
END;
LPoints:= {};
Timing:= (Ticks-Timing) /3600000;
RETURN Rep;
END;
LSinit(Nr)
BEGIN // init a new fractal root
IF Nr == 0 THEN // Choose
RETURN {"Hilbert curve", "Hilbert curve II", "Moore Curve", "Penrose Tiling", "Harter-Heighway dragon", "Terdragon", "Mandelbrot H Tree", "Sierpinski curve", "Sierpinski arrowhead curve", "Sierpinski Sieve", "Sierpinski carpet", "Peano-Gosper curve", "Quadratic Gosper curve", "Peano curve", "Koch SnowFlake", "Quadratic Koch island", "Koch curve", "Quadratic Koch curve", "Koch antisnowflake", "Minkowski sausage", "Cross-stitch curve", "Anticross-stitch curve", "Penta Plexity", "McWorter's Pentigree", "Pentadentrite", "Kristall", "Plant 1", "Plant 2"};
END;
IF Nr == 1 THEN // Hilbert curve
LSangle:= 360/4;
LSdir:= 90;
LSaxiom:= "A";
LSrules:= {{"A", "-BF+AFA+FB-"}, {"B", "+AF-BFB-FA+"}};
END;
IF Nr == 2 THEN // Hilbert curve II
LSangle:= 360/4;
LSdir:= 90;
LSaxiom:= "X";
LSrules:= {{"X", "XFYFX+F+YFXFY-F-XFYFX"}, {"Y", "YFXFY-F-XFYFX+F+YFXFY"}};
END;
IF Nr == 3 THEN // Moore Curve
LSangle:= 360/4;
LSdir:= 0;
LSaxiom:= "LFL+F+LFL";
LSrules:= {{"L", "-RF+LFL+FR-"}, {"R", "+LF-RFR-FL+"}};
END;
IF Nr == 4 THEN // Penrose Tiling
LSangle:= 360/10;
LSdir:= 0;
LSaxiom:= "[7]++[7]++[7]++[7]++[7]";
LSrules:= {{"6", "8F++9F----7F[-8F----6F]++"}, {"7", "+8F--9F[---6F--7F]+"}, {"8", "-6F++7F[+++8F++9F]-"}, {"9", "--8F++++6F[+9F++++7F]--7F"}, {"F", ""}};
END;
IF Nr == 5 THEN // Harter-Heighway dragon
LSangle:= 360/4;
LSdir:= 90;
LSaxiom:= "FX";
LSrules:= {{"X", "X+YF+"}, {"Y", "-FX-Y"}, {"F", ""}};
END;
IF Nr == 6 THEN // Terdragon
LSangle:= 360/3;
LSdir:= 90;
LSaxiom:= "F";
LSrules:= {{"F", "F+F-F"}};
END;
IF Nr == 7 THEN // Mandelbrot H Tree
LSangle:= 360/4;
LSdir:= 0;
LSaxiom:= "A";
LSrules:= {{"A", "[-BFA]+BFA"}, {"B","C"},{"C","BFB"}};
END;
IF Nr == 8 THEN // Sierpinski curve
LSangle:= 360/4;
LSdir:= 0;
LSaxiom:= "F+XF+F+XF";
LSrules:= {{"X", "XF-F+F-XF+F+XF-F+F-X"}};
END;
IF Nr == 9 THEN // Sierpinski Triangle
LSangle:= 360/6;
LSdir:= -90;
LSaxiom:= "AF";
LSrules:= {{"A", "BF-AF-B"}, {"B","AF+BF+A"}};
END;
IF Nr == 10 THEN // Sierpinski Sieve
LSangle:= 360/6;
LSdir:= -90;
LSaxiom:= "FXF++FF++FF";
LSrules:= {{"F", "FF"}, {"X","++FXF--FXF--FXF++"}};
END;
IF Nr == 11 THEN // Sierpinski carpet
LSangle:= 360/4;
LSdir:= -45;
LSaxiom:= "F";
LSrules:= {{"F", "F+F-F-FF-F-F-GF"}, {"G","GGG"}};
END;
IF Nr == 12 THEN // Peano-Gosper curve
LSangle:= 360/6;
LSdir:= 0;
LSaxiom:= "XF";
LSrules:= {{"X", "X+YF++YF-FX--FXFX-YF+"}, {"Y","-FX+YFYF++YF+FX--FX-Y"}};
END;
IF Nr == 13 THEN // Quadratic Gosper curve
LSangle:= 360/4;
LSdir:= -90;
LSaxiom:= "-YF";
LSrules:= {{"X", "XFX-YF-YF+FX+FX-YF-YFFX+YF+FXFXYF-FX+YF+FXFX+YF-FXYF-YF-FX+FX+YFYF-"}, {"Y","+FXFX-YF-YF+FX+FXYF+FX-YFYF-FX-YF+FXYFYF-FX-YFFX+FX+YF-YF-FX+FX+YFY"}};
END;
IF Nr == 14 THEN // Peano curve
LSangle:= 360/4;
LSdir:= 45;
LSaxiom:= "F";
LSrules:= {{"F", "F+F-F-F-F+F+F+F-F"}};
END;
IF Nr == 15 THEN // Koch SnowFlake
LSangle:= 360/6;
LSdir:= 90;
LSaxiom:= "F--F--F";
LSrules:= {{"F", "F+F--F+F"}};
END;
IF Nr == 16 THEN // Quadratic Koch island
LSangle:= 360/4;
LSdir:= 0;
LSaxiom:= "F+F+F+F";
LSrules:= {{"F", "F+F-F-FF+F+F-F"}};
END;
IF Nr == 17 THEN // Koch curve
LSangle:= 360/6;
LSdir:= -90;
LSaxiom:= "F";
LSrules:= {{"F", "F+F--F+F"}};
END;
IF Nr == 18 THEN // Quadratic Koch curve
LSangle:= 360/4;
LSdir:= -90;
LSaxiom:= "F";
LSrules:= {{"F", "F+F-F-F+F"}};
END;
IF Nr == 19 THEN // Koch antisnowflake
LSangle:= 360/6;
LSdir:= 90;
LSaxiom:= "F++F++F";
LSrules:= {{"F", "F+F--F+F"}};
END;
IF Nr == 20 THEN // Minkowski sausage
LSangle:= 360/4;
LSdir:= -90;
LSaxiom:= "F";
LSrules:= {{"F", "F+F-F-FF+F+F-F"}};
END;
IF Nr == 21 THEN // Cross-stitch curve
LSangle:= 360/4;
LSdir:= 90;
LSaxiom:= "F+F+F+F";
LSrules:= {{"F", "F-F+F+F-F"}};
END;
IF Nr == 22 THEN // Anticross-stitch curve
LSangle:= 360/4;
LSdir:= 90;
LSaxiom:= "F-F-F-F";
LSrules:= {{"F", "F-F+F+F-F"}};
END;
IF Nr == 23 THEN // Penta Plexity
LSangle:= 360/10;
LSdir:= -90;
LSaxiom:= "F++F++F++F++F";
LSrules:= {{"F", "F++F++F|F-F++F"}};
END;
IF Nr == 24 THEN // McWorter's Pentigree
LSangle:= 360/10;
LSdir:= 90;
LSaxiom:= "F";
LSrules:= {{"F", "+F++F----F--F++F++F-"}};
END;
IF Nr == 25 THEN // Pentadentrite
LSangle:= 360/5;
LSdir:= 90;
LSaxiom:= "F";
LSrules:= {{"F", "F+F-F--F+F+F"}};
END;
IF Nr == 26 THEN // Kristall
LSangle:= 360/4;
LSdir:= -90;
LSaxiom:= "F";
LSrules:= {{"F", "F+F--G+F-F++G-F"}, {"G","GGG"}};
END;
IF Nr == 27 THEN // Plant 1
LSangle:= 360/16;
LSdir:= 90;
LSaxiom:= "F";
LSrules:= {{"F", "FF-[-F+F+F]+[+F-F-F]"}};
END;
IF Nr == 28 THEN // Plant 2
LSangle:= 360/18;
LSdir:= 90;
LSaxiom:= "F";
LSrules:= {{"F", "F[+F]F[-F][F]"}};
END;
LSaxiomOrg:= LSaxiom; LSgen:= 0;
LPoints:= {};
END;
LSymb()
BEGIN
LOCAL Tmp, Scan;
RECT();
TEXTOUT_P("Fractal: Lindenmayer System",0,10,2);
TEXTOUT_P("Curve Name",0,40);
TEXTOUT_P("Angle",0,60);
TEXTOUT_P("Direction",0,80);
TEXTOUT_P("Generation",0,100);
TEXTOUT_P("Axiom",0,120);
TEXTOUT_P("Rules",0,140);
TEXTOUT_P(":",100,40);
TEXTOUT_P(":",100,60);
TEXTOUT_P(":",100,80);
TEXTOUT_P(":",100,100);
TEXTOUT_P(":",100,120);
TEXTOUT_P(":",100,140);
Tmp:= LSinit(0);
TEXTOUT_P(STRING(Xmin)+" "+STRING(Xmax)+" "+STRING(Ymin)+" "+STRING(Ymax),10,20);
TEXTOUT_P(Tmp(LSNum),120,40);
TEXTOUT_P(STRING(LSangle),120,60);
TEXTOUT_P(STRING(LSdir),120,80);
TEXTOUT_P(STRING(LSgen),120,100);
TEXTOUT_P(STRING(→HMS(Timing)),140,100);
TEXTOUT_P(LSaxiomOrg,120,120);
FOR Scan FROM 1 TO SIZE(LSrules) DO
TEXTOUT_P(LSrules(Scan,1)+ "->"+ LSrules(Scan,2), 120,120+Scan*20);
END;
END;
LHelp()
BEGIN
PRINT();
PRINT("Fractal: Lindenmayer System");
PRINT("");
PRINT("Symb first: Fractal information");
PRINT("Symb again: Choose new fractal");
PRINT("Help: this screen");
PRINT("Plot: Plot the curve");
PRINT("A: Aspect ratio/Full Screen");
PRINT("C: Color/Black");
PRINT("+: Next generation");
END;
EXPORT LSystem()
BEGIN
LOCAL Kb, View, Tmp;
HAngle:=1; View:= 0; Clr:= 1; Aspect:=1; Timing:=0;
LSNum:= 1; LSinit(LSNum);
REPEAT
IF View == 0 THEN LSymb(); END;
IF View == 1 THEN LSdraw(LSaxiom); END;
IF View == 6 THEN LHelp(); END;
REPEAT
Kb:= WAIT(0);
UNTIL Kb <> -1;
IF Kb == 1 AND View == 0 THEN CHOOSE(LSNum, "Fractal", LSinit(0)); IF LSNum == 0 THEN LSNum:= 1; END; LSinit(LSNum); END;
IF Kb == 1 AND View <> 0 THEN View:= 0; END;
IF Kb == 3 THEN View:= 6; END;
IF Kb == 6 THEN View:= 1; END;
IF Kb == 14 THEN Aspect:= 1- Aspect; LPoints:= {}; END;
IF Kb == 16 THEN Clr:= 1- Clr; LPoints:= {}; END;
IF Kb == 50 THEN LSaxiom:= LSnext(LSaxiom); LSgen:= LSgen+ 1; END;
UNTIL Kb==4;
LSaxiom:= ""; LPoints:= {}; LLines:= {};
END;