Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBLE.ZIP/TURBLE2.PAS

Pascal/Delphi Source File | 1986-03-31 | 5.8 KB | 255 lines

    {Draws a tree shape.  Notice that although the parameter is type
     real, this is only for the convenience of the procedure.  You can
     enter integer parameters.}

Procedure Tree(Height : Real);

Var
  SizeFork : Integer;

Procedure Vee;
begin
  Turn(-45);
  Go(SizeFork);
  Go(-SizeFork);
  Turn(90);
  Go(SizeFork);
  Go(-SizeFork);
  Turn(-45);
end;

Procedure Branch;
begin
  Go(SizeFork + SizeFork div 2);
  Vee;
  Go(SizeFork + SizeFork div 2);
  Vee;
  Go(SizeFork);
  Go(-4 * SizeFork);
end;

Procedure Bush;
Var I : Integer;
begin
  Turn(-60);
  For I := 1 to 4 do
    begin
      Branch;
      Turn(30);
    end;
  Branch;
  Turn(-60);
end;

begin
  SizeFork := Round(Height / 9);
  Go(5 * SizeFork);
  Bush;
  Go(-5 * SizeFork);
end;


    {Draws a spiral.  Since this is a continuous figure, it needs an
     artificial exit to prevent it from spiraling into infinity.}

Procedure Spiral(Side, Angle, Increment : Integer);

Label Exit;
Var
  I : integer;

begin
  For I := 1 to 32000 do      {The number 32000 prevents it from going...  }
    begin                     {forever if you forget to stop it.           }
      Go(side);
      Turn(angle);
      Side := Side + Increment;
      If Keypressed then Goto Exit;  {Here's the exit.  It won't work if...}
    end;                             {the U+ directive is on.              }
Exit : end;


   {Draws spirals that inverts until it turns itself inside out.  Makes
    interesting patterns.}

Procedure InSpiral(Side, Angle, Increment : Integer);

Label Exit;

begin
  Go(side);
  Turn(angle);
  If Keypressed then Goto Exit;     {Exit won't work with U+ directive on.}
  InSpiral(Side, Angle + Increment, Increment);  {Calls itself.           }
exit : end;


   {Draws a crude snowflake. }

Procedure SnowFlake(Size, Level : Real);

Procedure Side(Size, Level : Real);

Label Exit;

Procedure Call;
begin
  Side(Size / 3, Level - 1);
end;

begin
  If Level = 0 then
    begin
      Go(Round(Size));
      Goto Exit;
    end;
  Call;
  Turn(-60);
  Call;
  Turn(120);
  Call;
  Turn(-60);
  Call;
Exit : end;

Var
  I : Integer;

begin
  Pencolor(None);
  Turn(-45);
  Go(Round(Size) div 2);
  Turn(45);
  Pencolor(On);
  For I := 1 to 3 do
    begin
      Turn(120);
      Side(Size,Level);
    end;
end;


   {The following procedures draw circles using the turtle graphics
    system.  Circles drawn in this manner are not particularly accurate.
    A more accurate (but often slower) routine is provided later. First
    a left circle and a right circle.}

Procedure LCircle(Radius : Integer);
Var
  I : Integer;

Procedure LBitArc(Radius : Integer);      {Draw a ten-degree left arc.    }
begin
  Turn(-5);
  Go(Round(Radius * Pi / 18));
  Turn(-5);
end;

begin
  For I := 1 to 36 do LBitArc(Radius);    {Draw 36 ten-degree arcs.       }
end;


Procedure RCircle(Radius : Integer);

Var
  I : Integer;

Procedure RBitArc(Radius : Integer);      {Draw a ten-degree right arc.   }
begin
  Turn(5);
  Go(Round(Radius * Pi / 18));
  Turn(5);
end;

begin
  For I := 1 to 36 do RBitArc(Radius);    {Draw 36 ten-degree arcs.       }
end;

   {And here is a routine that draws a circle using the starting point
    as the center of the circle.  The previous circle routines start
    at a point on the edge of the circle.}

Procedure CCircle(Radius : Integer);

Var
  I, Buffer : Integer;

begin
  Buffer := ColorOfPen;
  Pencolor(None);
  Go(-Radius);
  Turn(90);
  Pencolor(Buffer);
  LCircle(Radius);
  Pencolor(None);
  Turn(-90);
  Go(Radius);
  PenColor(Buffer);
end;


   {This is a real circle routine.  It does not use turtle graphics concepts.
    While the previous circle procedures draw polygons with very short sides,
    this procedure actually plots each point on the circle.  It does eight
    quadrants simultaneously to cut down on real number calculations.  You
    can change the Raggedness constant to speed up drawing, but your circle
    will be looser (fewer dots).}

Procedure Circle(Radius : Integer);
Var
  X, Y, dX, dY : Integer;
  dA, Rad45, Angle  : Real;

Const
  Raggedness = 1;         {Increase to make circle faster and more ragged.}

Procedure QuadDot;              {Draw eight points in different quadrants.}
begin
  dot(X + dX,Y + dY);
  dot(X - dX,Y + dY);
  dot(X + dX,Y - dY);
  dot(X - dX,Y - dY);
  dot(X + dY,Y + dX);
  dot(X - dY,Y + dX);
  dot(X + dY,Y - dX);
  dot(X - dY,Y - dX);
end;

begin
  X := StartX; Y := StartY;
  Dot(X + Radius,Y); Dot(X - Radius,Y);           {Draw first four points.}
  Dot(X,Y + Radius); Dot(X,Y - Radius);
  dA := Raggedness / Radius;                      {Calculate the angle.   }
  Rad45 := 45 * pi / 180;
  Angle := dA;
  While Angle <= Rad45 do
    begin
      dX := round(Radius * cos(Angle));           {Calculate a dot.       }
      dY := round(Radius * sin(Angle));
      QuadDot;                                    {Draw the quadrants.    }
      Angle := Angle + dA;                        {Increment.             }
    end;
end;


   {Here's a procedure that uses circles.}

Procedure Slinky(Size, Bend : Integer);

Label Exit;
Var
  Buffer : Integer;

begin
  If KeyPressed then Goto Exit;        {Won't exit if U+ directive is on.}
  RCircle(Size);
  Buffer := ColorOfPen;                {Save color so you can move...    }
  Pencolor(None);                      {...without drawing.              }
  Turn(90);
  Go(10);
  Turn(-90 + Bend);
  Pencolor(Buffer);
  Slinky(Size, Bend);                  {Slinky calls itself.             }
Exit : end;