home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TARGET3.ZIP / TARGET3.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-03-29  |  4.3 KB  |  164 lines
  1.  
  2. program Target3;
  3. uses
  4.     Dos, Crt, Graph;
  5. const
  6.     SolidFill : FillPatternType = ($ff,$ff,$ff,$ff,
  7.                                     $ff,$ff,$ff,$ff);
  8. var
  9.     GraphDriver, GraphMode, ErrorCode    : integer;
  10.     Radius, CenterLine                   : integer;
  11.     Repeat1, Repeat2, Repeat3, NewColor  : integer;
  12.     Year, Month, Day, DayOfWeek          : word;
  13.     ThisYear, ThisMonth, ThisDate, Today : string[9];
  14.  
  15. (* This procedure puts a cross-hatch on the screen for linearity testing *)
  16. procedure CrossHatch;
  17. var
  18.     HorizPos : integer;
  19.     VertiPos : integer;
  20. begin
  21.     SetColor(8);
  22.     HorizPos := 1;
  23.     VertiPos := GetMaxY div 29;
  24.     repeat
  25.      MoveTo(HorizPos, VertiPos);
  26.     LineTo(GetMaxX - 1, VertiPos);
  27.     inc(VertiPos, GetMaxY div 29);
  28.     until VertiPos >= GetMaxY;
  29.     HorizPos := GetMaxX div 39;
  30.     VertiPos := 1;
  31.     repeat
  32.     MoveTo(HorizPos, VertiPos);
  33.     LineTo(HorizPos, GetMaxY - 1);
  34.     inc(HorizPos, GetMaxX div 39);
  35.     until HorizPos >= GetMaxX;
  36. end; (* CrossHatch *)
  37.  
  38. (* This procedure draws pie slices on demand *)
  39. procedure NextPie(X, Y, CenterLine : integer; Radius : word);
  40. begin
  41.     PieSlice(X, Y, CenterLine -4, CenterLine +4, Radius);
  42. end; (* NextPie *)
  43.  
  44. (* This procedure gets today's date *)
  45. procedure newdate;
  46. begin
  47.     GetDate(Year, Month, Day, DayOfWeek );
  48.     case DayOfWeek of
  49.         0 : Today      := 'Sunday';
  50.         1 : Today      := 'Monday';
  51.         2 : Today      := 'Tuesday';
  52.         3 : Today      := 'Wednesday';
  53.         4 : Today      := 'Thursday';
  54.         5 : Today      := 'Friday';
  55.         6 : Today      := 'Saturday';
  56.      end;
  57.     case Month of
  58.          1 : ThisMonth := 'January';
  59.          2 : ThisMonth := 'February';
  60.          3 : ThisMonth := 'March';
  61.          4 : ThisMonth := 'April';
  62.          5 : ThisMonth := 'May';
  63.          6 : ThisMonth := 'June';
  64.          7 : ThisMonth := 'July';
  65.          8 : ThisMonth := 'August';
  66.          9 : ThisMonth := 'September';
  67.         10 : ThisMonth := 'October';
  68.         11 : ThisMonth := 'November';
  69.         12 : ThisMonth := 'December';
  70.     end;
  71.     str(Year, ThisYear);
  72.     str(Day , ThisDate);
  73. end; (* NewDate *)
  74.  
  75. (* Main program begins with the test of graphics call up *)
  76. begin
  77.     GraphDriver := Detect;
  78.     InitGraph(GraphDriver, GraphMode, 'D:\Turbo4\Drivers');
  79.     ErrorCode   := GraphResult;
  80.     if ErrorCode <> grOk then
  81.     begin
  82.         Writeln('Graphics error : ');
  83.         Writeln('Program Aborted ...');
  84.     end;
  85.  
  86. (* Set graphic driver to highest VGA mode *)
  87.     SetGraphMode(2);
  88.  
  89. (* Draw the largest rectangle for the systems graphics board *)
  90.     SetBkColor(0);
  91.      Rectangle(0, 0, GetMaxX, GetMaxY);
  92.     CrossHatch;
  93.  
  94. (* Draw a large circle for checking linearity in both axis *)
  95.      SetColor(5);
  96.     Radius := (GetMaxY div 20)*10;
  97.     Circle(GetMaxX div 2, GetMaxY div 2, Radius);
  98.  
  99. (* Set up to draw a peacock of 15 colors *)
  100.     SetColor(15);
  101.     CenterLine := 20;
  102.     Repeat1 := 1;
  103.     Repeat2 := 9;
  104.     Repeat3 := 1;
  105.  
  106. (* Draw the peacock *)
  107.     repeat
  108.         if odd(Repeat1) then
  109.             begin
  110.                 Radius   := (GetMaxY div 16) * 9;
  111.                 NewColor := Repeat3;
  112.                 inc(Repeat3);
  113.             end
  114.         else
  115.             begin
  116.                 Radius   := (GetMaxY div 16) * 11;
  117.                 NewColor := Repeat2;
  118.                     inc(Repeat2);
  119.         end;
  120.  
  121.         SetFillPattern(SolidFill, NewColor);
  122.             NextPie(GetMaxX div 2, GetMaxY - (GetMaxY div 5), CenterLine, Radius);
  123.         Repeat1 := Repeat1 + 1;
  124.         CenterLine := CenterLine + 10;
  125.      until Repeat1 = 16;
  126.  
  127. (* Now for some test circles *)
  128.     Repeat1 := 10;
  129.     repeat
  130.         SetColor(4);
  131.         Radius := GetMaxY div Repeat1;
  132.         Circle(GetMaxX div 8, GetMaxY div 6, Radius);
  133.         SetColor(1);
  134.         Circle((GetMaxX div 8)*7, GetMaxY div 6, Radius);
  135.         SetColor(2);
  136.         Circle((GetMaxX div 8)*7, (GetMaxy div 6)*5, Radius);
  137.         SetColor(14);
  138.         Circle(GetMaxX div 8, (GetMaxY div 6)*5, Radius);
  139.           inc(Repeat1);
  140.     until Repeat1 > 150;
  141.  
  142. (* Provide a title *)
  143.     SetColor(9);
  144.     SetTextJustify(CenterText, CenterText);
  145.     SetTextStyle(DefaultFont, Horizdir, 2);
  146.     OutTextXY(GetMaxX Div 2, (GetMaxY div 30)*3,
  147.                'TARGET3');
  148.     SetTextStyle(DefaultFont, Horizdir, 1);
  149.     OutTextXY(GetMaxX Div 2, (GetMaxY div 30)*27,
  150.             'EGA/VGA Monitor');
  151.     OutTextXY(GetMaxX div 2, (GetMaxY div 30)*28,
  152.             'Test Pattern Generator');
  153.     NewDate;
  154.     OutTextXY(GetMaxX div 2, (GetMaxY div 30)*29,
  155.             Today + ' ' + ThisDate + ' ' + ThisMonth +
  156.             ' ' + ThisYear);
  157.  
  158. (* The drawing is complete ... waiting for release *)
  159.     Readln;
  160.     if KeyPressed then
  161.     ClearDevice;
  162.     CloseGraph;
  163. end. (Target3.pas)
  164.