old/PAS/Fractals/Lsystems.pas

Unit Lsystems;
				InterFace
Uses Graph;

const
  MaxStack = 100;
  MaxBuf = 10000;

type
 PLsys = ^TLsys;
 PS    = ^String;
 TLsys = record
   Axiom    : string;
   Comment  : string;
   Turns    : integer;
   RulesTable : array [0..255] of PS;
 end;

 Tpos = record
   x, y, a : real;
 end;

Function  CreateLsys(aAxiom, aComment : string; aTurns : integer):PLsys;
Procedure AddRule(var aFrac : PLsys; aCh : char; aRule:string);
Procedure DestroyLsys(var aFrac : PLsys);
Function  Calculate(var aFrac:PLsys; aStage : integer):string;
Function  Advance(var aFrac:PLsys; PrevName : string):string;
Procedure DrawLsys(fName : string; var aFrac : PLsys);

			Implementation
Function CreateLsys;
var RET:PLsys;i:byte;
begin
  New(RET);
  RET^.Axiom := aAxiom;
  RET^.Comment := aComment;
  RET^.Turns := aTurns;
  for i:=0 to 255 do RET^.RulesTable[i]:=nil;
  CreateLsys := RET;
end;{CreateLsys}
{--------------------------------------------}
Procedure AddRule;
begin
  if aFrac = nil then begin writeln('AddRule Error: Fractal undefined'); halt(255);end;
  if aFrac^.RulesTable[Ord(aCh)] <> nil then Dispose(aFrac^.RulesTable[Ord(aCh)]);
  New(aFrac^.RulesTable[Ord(aCh)]);
  aFrac^.RulesTable[Ord(aCh)]^ := aRule;
end;{AddRule}
{--------------------------------------------}
Function Calculate;
var
 A    : FILE;
 CH   : char;
 N1   : string;
 I    : integer;
begin
  n1:='1.!!!';
  if odd(aStage) then Calculate := '2.!!!'
  else Calculate := '1.!!!';

  Assign(A,'1.!!!');
  Rewrite(A,1);
  BlockWrite(A,Ptr(Seg(aFrac^.Axiom),Ofs(aFrac^.Axiom)+1)^,Length(aFrac^.Axiom));
  Close(A);
  For i := 1 to aStage do
   begin
     N1:=Advance(aFrac,N1);
   end;
end;{Calculate}
{--------------------------------------------}
Function Advance;
type PFILE=^FILE;
var
 A,B  : PFILE;
 Out  : string;
 CH   : char;
 I    : integer;
begin
  New(A);NEW(B);
  if PrevName = '1.!!!' then out:='2.!!!'
  else out:='1.!!!';
  Advance := out;
  Assign(A^,PrevName);
  Assign(B^,Out);

  Reset(A^,1);
  Rewrite(B^,1);
  repeat
    BlockRead(A^,CH,1);
    if aFrac^.RulesTable[Ord(ch)] <> nil then BlockWrite(B^,Ptr(Seg(aFrac^.RulesTable[Ord(ch)]^),
      Ofs(aFrac^.RulesTable[Ord(ch)]^)+1)^,Length(aFrac^.RulesTable[Ord(ch)]^))
    else BlockWrite(B^,Ch,1);
  until EOF(A^);
  Close(A^);
  Close(B^);
  Erase(A^);
  Dispose(A);Dispose(B);
end;{Advance}
{--------------------------------------------}
Procedure DestroyLsys;
var i:byte;
begin
  for i:=0 to 255 do if aFrac^.RulesTable[i] <> nil then
    Dispose(aFrac^.RulesTable[i]);
  Dispose(aFrac);
end;{DestroyLsys}
{-------------------------------------------}
Procedure DrawLsys;
type TBuf = array [1..MaxBuf] of char;
Var
  Step : real;
  StackPos : integer;
  Stack : array [1..MaxStack] of Tpos;
  Buffer  : ^TBuf;
  BufPos,NumRead:1..MaxBuf;
  C : Tpos;
  Ip  : FILE;
  dx, dy,cx,cy : real;
  da  : real;
  MaxX,MinX,MaxY,MinY : real;
begin
  Step := 100.0;
  da := 2*PI/aFrac^.Turns;
  New(Buffer);
  Assign(ip,fName);
  Reset(ip,1);
  BlockRead(ip,Buffer^,MaxBuf,NumRead);
  BufPos:=1;
  StackPos:=1;
  dx:=step;dy:=0;C.x:=0;c.y:=0;c.a:=0;
  MaxX:=0;MaxY:=0;MinX:=0;MinY:=0;
  repeat
    case Buffer^[BufPos] of
     'F': begin
            c.x := c.x + dx;
            c.y := c.y + dy;
            If C.X > MaxX then MaxX := c.x;
            If C.X < MinX then MinX := c.x;
            If C.Y > MaxY then MaxY := c.y;
            If C.Y < MinY then MinY := c.y;
          end;
     '+': begin
            c.a := c.a - da;
            if c.a > 2*PI then c.a:=c.a-2*Pi;
            if c.a < 0 then    c.a:=c.a+2*Pi;
            dx := cos(c.a)*Step;
            dy := sin(c.a)*Step;
          end;
     '-': begin
            c.a := c.a + da;
            if c.a > 2*PI then c.a:=c.a-2*Pi;
            if c.a < 0 then    c.a:=c.a+2*Pi;
            dx := cos(c.a)*Step;
            dy := sin(c.a)*Step;
          end;
     '[': begin
            If StackPos > MaxStack then
             begin
               CloseGraph;
               WriteLN('Stack overflow');
               Halt(210);
             end;
            Stack[StackPos] := C;
            Inc(StackPos);
          end;
     ']': begin
            If StackPos = 1 then
             begin
               CloseGraph;
               WriteLN('Stack error');
               Halt(200);
             end;
            Dec(StackPos);
            C:=Stack[StackPos];
            dx := cos(c.a)*Step;
            dy := sin(c.a)*Step;
          end;
    end;
    Inc(BufPos);
    if BufPos = NumRead+1 then
     begin
       BlockRead(ip,Buffer^,MaxBuf,NumRead);
       BufPos:=1;
     end;
    if NumRead = 0 then break;
  until false;
  if (MaxY=MinY) and (MaxX=MaxY) then
  begin
   Exit;
  end;
  if (MaxX-MinX)/(MaxY-MinY) > 4/3 then
    Step := 61300/(MaxX-MinX)
  else
    step := 46000/(MaxY-MinY);

  cx := (MaxX+MinX)*step/200;
  cy := (MaxY+MinY)*step/200;

  Seek(ip,0);
  BlockRead(ip,Buffer^,MaxBuf,NumRead);
  BufPos:=1;
  StackPos:=1;
  dx:=step;dy:=0;C.x:=0;c.y:=0;c.a:=0;
  OutTextXY(10,5,aFrac^.Comment);
  repeat
    case Buffer^[BufPos] of
     'F': begin
            moveto(round(320-cx+c.x),round(240+cy-c.y));
            c.x := c.x + dx;c.y := c.y + dy;
            LineTo(round(320-cx+c.x),round(240+cy-c.y))
          end;
     '+': begin
            c.a := c.a - da;
            if c.a > 2*PI then c.a:=c.a-2*Pi;
            if c.a < 0 then    c.a:=c.a+2*Pi;
            dx := cos(c.a)*Step;
            dy := sin(c.a)*Step;
          end;
     '-': begin
            c.a := c.a + da;
            if c.a > 2*PI then c.a:=c.a-2*Pi;
            if c.a < 0 then    c.a:=c.a+2*Pi;
            dx := cos(c.a)*Step;
            dy := sin(c.a)*Step;
          end;
     '[': begin
            If StackPos > MaxStack then
             begin
               WriteLN('Stack overflow');
               Halt(210);
             end;
            Stack[StackPos] := C;
            Inc(StackPos);
          end;
     ']': begin
            If StackPos = 1 then
             begin
               WriteLN('Stack error');
               Halt(200);
             end;
            Dec(StackPos);
            C:=Stack[StackPos];
            dx := cos(c.a)*Step;
            dy := sin(c.a)*Step;
          end;
    end;
    Inc(BufPos);
    if BufPos = NumRead+1 then
     begin
       BlockRead(ip,Buffer^,MaxBuf,NumRead);
       BufPos:=1;
     end;
    if NumRead = 0 then break;
  until false;
  close(ip);
  Dispose(Buffer);
end; {DrawLsys}
{--------------------------------------------}
END.