home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB29.ZIP / TURBLE.LBR / HEXDEMO.PQS / hexdemo.pas
Encoding:
Pascal/Delphi Source File  |  1985-03-03  |  4.9 KB  |  171 lines
  1. {$I turble.pas}
  2. {$i GetPut.pas}
  3. {$i Paint.pas}
  4.  
  5. var
  6.   Ch : Char;
  7.   Hexagon : Storage;
  8.   Got, Drawn, Long, Erase, GetPut : Boolean;
  9.   I, DistV, DistH, Resolute, Intersect, Color, Palet : Integer;
  10.   DistS, ResoluteS, EraseS, IntersectS, ProgS : String[12];
  11.  
  12. Procedure Default;                     {Set defaults.                   }
  13. begin
  14.   Long      := True;
  15.   Resolute  := 5;
  16.   Erase     := False;
  17.   Intersect := 3;
  18.   Palet     := 0;
  19.   Color     := 1;
  20. end;
  21.  
  22. Procedure Drawit;                      {Draw the hexagon.               }
  23. begin
  24.   Pencolor(none);
  25.   Moveto(CenterX + 1, CenterY - 4);
  26.   Pencolor(Color);
  27.   for I := 1 to 6 do
  28.     begin
  29.       Poly(3,20);
  30.       Turn(60);
  31.     end;
  32.   Case Resolute of                     {Paint the appropriate sections. }
  33.     4:  begin
  34.           paint(StartX + 5,StartY,Color,1);
  35.           paint(StartX - 5,StartY,Color,1);
  36.           paint(StartX + 2,StartY - 10,Color,2);
  37.           paint(StartX - 2,StartY + 10,Color,2);
  38.         end;
  39.     5:  begin
  40.           paint(StartX + 5,StartY,Color,1);
  41.           paint(StartX - 2,StartY - 10,Color,2);
  42.           paint(StartX - 2,StartY + 10,Color,3);
  43.         end;
  44.     6:  begin
  45.           paint(StartX + 3,StartY - 10,Color,1);
  46.           paint(StartX - 10,StartY,Color,1);
  47.           paint(StartX + 3,StartY + 10,Color,1);
  48.         end;
  49.   end; {Case}
  50. end;
  51.  
  52. Procedure MoveIt;                      {Move the hexagon.               }
  53. begin
  54.   If not Got then
  55.     begin
  56.       Get(CenterX-16,CenterY-24,32,40,Hexagon,'');
  57.       If Erase then Put(Hexagon,CenterX - 16,CenterY-24,b,'');
  58.       Got := True;
  59.     end;
  60.   Put(Hexagon,CenterX + DistH,CenterY - 24 + DistV,Intersect,'');
  61. end;
  62.  
  63. Procedure SetEmUp;                     {Set all the parameters.         }
  64. begin
  65.   If Long then                         {Parameter for Distance.         }
  66.     begin
  67.       Randomize;
  68.       DistV := Random(100);
  69.       Randomize;
  70.       DistH := Random(120);
  71.       If Odd(Random(2)) then DistH := -DistH;
  72.       If Resolute = 6 then
  73.         begin
  74.           DistH := DistH * 2;
  75.           DistV := DistV * 2;
  76.         end;
  77.       DistS := 'Long';
  78.     end
  79.   else
  80.     begin
  81.       DistS := 'Short';
  82.       DistV := 0;
  83.       DistH := 0;
  84.     end;
  85.   Case Resolute of                     {Parameter for Resolution.       }
  86.     4 : ResoluteS := 'Medium';
  87.     5 : ResoluteS := 'Medium Color';
  88.     6 : ResoluteS := 'High';
  89.   end; {Case}
  90.   If Erase then EraseS := 'On' else EraseS := 'Off';   {Flag for Erase. }
  91.   Case Intersect of                    {Parameter for Intersect.        }
  92.     1 : IntersectS := 'AND';
  93.     2 : IntersectS := 'OR';
  94.     3 : IntersectS := 'XOR';
  95.     4 : IntersectS := 'NOT';
  96.     5 : IntersectS := 'EQU';
  97.   end; {Case}
  98. end;
  99.  
  100. Procedure Menu;                        {Print menu.                     }
  101. begin
  102.   Mode(Resolute);
  103.   Palettor(Palet);
  104.   PenColor(Color);
  105.   Writeln('Distance  (D)   ',DistS);
  106.   writeln('Mode      (M)   ',ResoluteS);
  107.   writeln('Erase     (E)   ',EraseS);
  108.   writeln('Intersect (I)   ',IntersectS);
  109.   writeln('Palette   (P)   Palette ',Palet);
  110.   writeln('Pencolor  (C)   Color ',Color);
  111.   writeln('Go        (G)');
  112.   writeln('Quit      (Q)');
  113.   Drawn := False;
  114.   Got := False;
  115. end;
  116.                                         
  117. Procedure Choose;                      {Choose parameters.              }
  118. begin
  119.   read(kbd,ch);
  120.   Case UpCase(ch) of
  121.     'D' : If Long then Long := False else Long := True;
  122.     'M' : begin
  123.             Color := 1;
  124.             If Resolute = 5 then Palet := 15 else Palet := 0;
  125.             If Resolute = 6 then Resolute := 4 else Resolute := Resolute + 1;
  126.           end;
  127.     'E' : If Erase then Erase := False else Erase := True;
  128.     'I' : begin
  129.             If Intersect > 5 then Intersect := Intersect - 5;
  130.             If Intersect = 5 then Intersect := 1
  131.               else Intersect := Intersect + 1;
  132.           end;
  133.     'P' : Case Resolute of
  134.             4 : If Palet >= 1 then Palet := 0 else Palet := 1;
  135.             5 : If Palet >= 3 then Palet := 0 else Palet := Palet + 1;
  136.             6 : If Palet >= 15 then Palet := 1 else Palet := Palet + 1;
  137.           end;
  138.     'C' : Case Resolute of
  139.             4, 5 : If Color = 3 then Color := 1 else Color := Color + 1;
  140.             6    : Color := 1;
  141.           end; {Case}
  142.     'G' : begin
  143.             If not Drawn then
  144.               begin
  145.                 DrawIt;
  146.                 Drawn := True;
  147.               end;
  148.             MoveIt;
  149.           end;
  150.   end; {Case}
  151.   While UpCase(Ch) <> 'Q' do           
  152.     begin
  153.       SetEmUp;                         {Set parameters.                }
  154.       If UpCase(Ch) <> 'G' then Menu;  {Print menu.                    }
  155.       Choose;                          {Choose parameters -- recursive.}
  156.     end;
  157. end;
  158.  
  159. begin
  160.   Default;
  161.   SetEmUp;
  162.   Menu;
  163.   Choose;                   {Most work done in one recursive procedure.}
  164.   ClrScr;
  165. end.
  166.  
  167.  
  168.  
  169.  
  170. 
  171.