HP Prime для всех

English  Русский 
Lindenmayer Fractals graphics-app screenshot}}
Название Lindenmayer Fractals
Описание Uses the Lindenmayer System to build fractals on screen, with 28 Lindenmayer fractals.
Автор Patrice Torchet

Исходный код (скачать):

Исходный код отформатирован программными средствами сайта

Строки с ICON ресурсами были обрезаны.

// Fractale : Lindenmayer system // V 1.5 02/2013 EXPORT LSangle, LSdir, LSaxiom, LSaxiomOrg, LSgen, LSrules, LSNum; Xmin, Xmax, Ymin, Ymax, Timing; Stk, Clr; 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 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; LSline(x1, y1, x2, y2, ndx) BEGIN IF Clr == 0 THEN ndx := 0; END; LINE_P(320 / (Xmax-Xmin) * (x1-Xmin), 240 / (Ymax-Ymin) * (Ymax-y1), 320 / (Xmax-Xmin) * (x2-Xmin), 240 / (Ymax-Ymin) * … END; LSdraw(Axiom) BEGIN LOCAL Scan, Code, LineC, LineT; LOCAL Xp, Yp, Ap, Xt, Yt; RECT(); StkInit(); Xmin := 0; Xmax := 0; Ymin := 0; Ymax := 0; Xp := 0; Yp := 0; Ap := LSdir; LineT := 0; 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); Xmin := MIN(Xmin, Xp); Xmax := MAX(Xmax, Xp); Ymin := MIN(Ymin, Yp); Ymax := MAX(Ymax, Yp); IF Code = "F" THEN LineT := LineT+1; END; END; IF Code = "-" THEN Ap := Ap- LSangle; END; IF Code = "+" THEN Ap := Ap+ LSangle; END; IF Code = "[" THEN StkPush(Xp); StkPush(Yp); StkPush(Ap); END; IF Code = "]" THEN Ap := StkPop(); Yp := StkPop(); Xp := StkPop(); END; END; Xmin := Xmin-1; Xmax := Xmax+1; Ymin := Ymin-1; Ymax := Ymax+1; StkInit(); Xp := 0; Yp := 0; Ap := LSdir; LineC := 0; FOR Scan FROM 1 TO dim(Axiom) DO Code := mid(Axiom, Scan, 1); IF Code = "F" OR Code = "G" THEN Xt := Xp; Yt := Yp; Xp := Xp+ sin(Ap); Yp := Yp+ cos(Ap); IF Code = "F" THEN LSline(Xt, Yt, Xp, Yp, LineC/LineT); LineC := LineC+1; END; END; IF Code = "-" THEN Ap := Ap- LSangle; END; IF Code = "+" THEN Ap := Ap+ LSangle; END; IF Code = "[" THEN StkPush(Xp); StkPush(Yp); StkPush(Ap); END; IF Code = "]" THEN Ap := StkPop(); Yp := StkPop(); Xp := StkPop(); END; END; END; LSnext(Axiom) BEGIN 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; Timing := (Ticks-Timing) /3600000; RETURN Rep; END; LSinit(Nr) BEGIN IF Nr == 0 THEN // Choose RETURN {"Hilbert", "Dragon", "Koch SnowFlake", "Sierpinski Triangle", "H Tree Mandelbrot", "Gosper curve", "Sierpinski c… END; IF Nr == 1 THEN // Hilbert LSangle := 360/4; LSdir := 90; LSaxiom := "A"; LSrules := {{"A", "-BF+AFA+FB-"}, {"B", "+AF-BFB-FA+"}}; END; IF Nr == 2 THEN // Dragon LSangle := 360/4; LSdir := 90; LSaxiom := "FX"; LSrules := {{"X", "X+YF+"}, {"Y", "-FX-Y"}, {"F", ""}}; END; IF Nr == 3 THEN // Koch SnowFlake LSangle := 360/6; LSdir := 90; LSaxiom := "F--F--F"; LSrules := {{"F", "F+F--F+F"}}; END; IF Nr == 4 THEN // Sierpinski Triangle LSangle := 360/6; LSdir := -90; LSaxiom := "AF"; LSrules := {{"A", "BF-AF-B"}, {"B", "AF+BF+A"}}; END; IF Nr == 5 THEN // HTree Mandelbrot LSangle := 360/4; LSdir := 0; LSaxiom := "A"; LSrules := {{"A", "[-BFA]+BFA"}, {"B", "C"}, {"C", "BFB"}}; END; IF Nr == 6 THEN // 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 == 7 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 == 8 THEN // Hilbert II curve LSangle := 360/4; LSdir := 90; LSaxiom := "X"; LSrules := {{"X", "XFYFX+F+YFXFY-F-XFYFX"}, {"Y", "YFXFY-F-XFYFX+F+YFXFY"}}; END; IF Nr == 9 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+… END; IF Nr == 10 THEN // Moore Curve LSangle := 360/4; LSdir := 0; LSaxiom := "LFL+F+LFL"; LSrules := {{"L", "-RF+LFL+FR-"}, {"R", "+LF-RFR-FL+"}}; END; IF Nr == 11 THEN // Plant LSangle := 360/16; LSdir := 90; LSaxiom := "F"; LSrules := {{"F", "FF-[-F+F+F]+[+F-F-F]"}}; END; LSaxiomOrg := LSaxiom; LSgen := 0; 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(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("C: Color/Black"); PRINT("+: Next generation"); END; EXPORT LSystem() BEGIN LOCAL Kb, View, Tmp; HAngle := 1; View := 0; Clr := 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 == 16 THEN Clr := 1- Clr; END; IF Kb == 50 THEN LSaxiom := LSnext(LSaxiom); LSgen := LSgen+ 1; END; UNTIL Kb == 4; END;

Комментарии