home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FACILIS1.ZIP / DEFENSE.PAS next >
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  10.0 KB  |  359 lines
  1. Program Defense;
  2.  
  3. {
  4.   Program     : DEFENSE
  5.   Written by  : John R. Naleszkiewicz
  6.   Date        : August 21, 1985
  7. }
  8.  
  9. Const
  10.   Version    = 1.2;
  11.   Xmin       = 2;
  12.   Xmax       = 74;
  13.   Ymin       = 1;
  14.   Ymax       = 23;
  15.   NumStars   = 8;
  16.  
  17. Type
  18.   StarType   = RECORD
  19.                  X,Y         : integer;
  20.                END;
  21.  
  22. Var
  23.   won, lost  : boolean;
  24.   ShotDown   : boolean;
  25.   continue   : boolean;
  26.   x,y,i      : integer;
  27.   NewX, NewY : integer;
  28.   Rate       : integer;
  29.   down       : integer;
  30.   Eshots     : integer;
  31.   Tshots     : integer;
  32.   shots      : integer;
  33.   ship       : string[5];
  34.   blowup     : array[1..6] of string[9];
  35.   Ym,Yp      : array[13..Ymax] of integer;
  36.   Star       : array[1..NumStars] of StarType;
  37.   ch,ESC     : char;
  38.  
  39. Function GetChar : char;
  40. Var
  41.   ch : char;
  42.  
  43. Begin
  44.   read ( ch );       { for use with Facilis }
  45. {
  46.   read ( KBD, ch );  { for use with TurboPascal }
  47.   GetChar := ch;
  48. End;
  49.  
  50. Procedure DrawShip ( NewX, NewY : integer );
  51. Begin
  52.   GotoXY ( x, y );
  53.   write ('     ');
  54.   x := NewX;
  55.   y := NewY;
  56.   if ( x>Xmax ) OR ( x<Xmin ) OR ( y>Ymax ) OR ( y<Ymin ) then
  57.     lost := true
  58.   else
  59.     Begin
  60.       GotoXY ( x, y );
  61.       write ( ship )
  62.     End;
  63.   TextColor ( 3 );
  64.   GotoXY ( 40, 12 );
  65.   write ( '+' );
  66.   TextColor ( 14 );
  67. End;
  68.  
  69. Procedure ShiftStars( Xinc, Yinc : integer );
  70. Var
  71.   num,j : integer;
  72.  
  73. Begin
  74.   for num:=1 to NumStars do
  75.     Begin
  76.       GotoXY ( Star[num].X, Star[num].Y );
  77.       write ( ' ' );
  78.       Star[num].X := Star[num].X + Xinc;
  79.       Star[num].Y := Star[num].Y + Yinc;
  80.       if (Star[num].X < Xmin) then
  81.         Star[num].X := Xmax
  82.       else
  83.         if (Star[num].X > Xmax) then
  84.           Star[num].X := Xmin;
  85.       if (Star[num].Y < Ymin) then
  86.         Star[num].Y := Ymax
  87.       else
  88.         if (Star[num].Y > Ymax) then
  89.           Star[num].Y := Ymin;
  90.       TextColor ( 15 );
  91.       GotoXY ( Star[num].X, Star[num].Y );
  92.       write ( '∙' );
  93.       TextColor ( 14 );
  94.       GotoXY ( 40, 12 );
  95.     End;
  96. End;
  97.  
  98. Procedure Action ( Rate : integer );
  99. Var
  100.   ch  : char;
  101.   i,j : integer;
  102.  
  103. Begin
  104.   Repeat
  105.     if keypressed then
  106.       Begin
  107.         TextColor ( 3 );
  108.         GotoXY ( 40, 12 );
  109.         ch := GetChar;
  110.         GotoXY ( 40, 12 );
  111.         if (ch=ESC) AND keypressed then
  112.           Begin
  113.             ch := GetChar;
  114.             GotoXY ( 40, 12 );
  115.             write ( '+' );
  116.             TextColor ( 14 );
  117.             if (ch='H') OR (ch='P') OR (ch='K') OR (ch='M') OR (ch='R') then
  118.               case ch of
  119.                 'H' : Begin
  120.                         ShiftStars ( 0, 1 );
  121.                         DrawShip ( x, y+1 );  { Up arrow }
  122.                         Rate := Rate-50;
  123.                       End;
  124.                 'P' : Begin
  125.                         ShiftStars ( 0, -1 );
  126.                         DrawShip ( x, y-1 );  { Down arrow }
  127.                         Rate := Rate-50;
  128.                       End;
  129.                 'K' : Begin
  130.                         ShiftStars ( 1, 0 );
  131.                         DrawShip ( x+1, y );  { Left arrow }
  132.                         Rate := Rate-50;
  133.                       End;
  134.                 'M' : Begin
  135.                         ShiftStars ( -1, 0 );
  136.                         DrawShip ( x-1, y );  { Right arrow }
  137.                         Rate := Rate-50;
  138.                       End;
  139.                 'R' : Begin                 { Insert key }
  140.                         shots := shots + 1;
  141.                         Rate := Rate-50;
  142.                         TextColor ( 12 );
  143.                         for i:=Ymax downto 13 do
  144.                           Begin
  145.                             GotoXY ( Ym[i], i );
  146.                             write ( '/' );
  147.                             GotoXY ( Yp[i], i );
  148.                             write ( '\' );
  149.                           End;
  150.                         GotoXY ( 40, 12 );
  151.                         write ( '^' );
  152.                         delay ( 100 );
  153.                         TextColor ( 14 );
  154.                         for i:=Ymax downto 13 do
  155.                           Begin
  156.                             GotoXY ( Ym[i], i );
  157.                             write ( ' ' );
  158.                             GotoXY ( Yp[i], i );
  159.                             write ( ' ' );
  160.                           End;
  161.                         GotoXY ( 40, 12 );
  162.                         write ( ' ' );
  163.                         if (y=12) AND ( (x>35) AND (x<41) ) then
  164.                           Begin
  165.                             for i:=1 to 10 do
  166.                               Begin
  167.                                 if odd( i ) then
  168.                                   TextColor ( 12 )
  169.                                 else
  170.                                   TextColor ( 14 );
  171.                                 delay ( 50 );
  172.                                 GotoXY ( x, y );
  173.                                 write ( ship );
  174.                               End;
  175.                             x := x-2;
  176.                             for i:=1 to 6 do
  177.                               for j:=1 to 6 do
  178.                                 Begin
  179.                                   if odd ( j ) then
  180.                                     TextColor ( 12 )
  181.                                   else
  182.                                     TextColor ( 14 );
  183.                                   delay ( 5 );
  184.                                   GotoXY ( x, y );
  185.                                   write ( blowup[i] );
  186.                                 End;
  187.                             GotoXY ( x, y );
  188.                             write ( '     ' );
  189.                             Delay ( 1000 );
  190.                             TextColor ( 14 );
  191.                             won := true;
  192.                           End;
  193.                       End;  { Case of ' ' }
  194.               End;  { Case }
  195.           End  { if ESC AND keypressed }
  196.         else
  197.           Begin
  198.             GotoXY ( 40, 12 );
  199.             write ( '+' );
  200.             TextColor ( 14 );
  201.           End;
  202.       End;  { if keypressed }
  203.     Rate := Rate-1;
  204.   Until Rate<1;
  205. End;
  206.  
  207. Function NotNeg ( Value : integer ) : integer;
  208. Begin
  209.   if Value > 0 then
  210.     NotNeg := Value
  211.   else
  212.     NotNeg := 0;
  213. End;
  214.  
  215. Function Fire ( Rate : integer ) : boolean;
  216. Var
  217.   delta : real;
  218.   i     : integer;
  219.  
  220. Begin
  221.   if random < 0.05 then
  222.     Begin
  223.       Eshots := Eshots + 1;
  224.       delta := NotNeg(7 - abs( 38-x )) * NotNeg(7 - (2 * abs( 12-y ))) / 100.0;
  225.       if random < delta then
  226.         Fire := true
  227.       else
  228.         Fire := false;
  229.       TextColor ( 13 );
  230.       for i:= y+1 to Ymax do
  231.         Begin
  232.           GotoXY ( x+2, i );
  233.           write ( '│' );
  234.         End;
  235.       Delay ( 200 );
  236.       TextColor ( 14 );
  237.       for i:= y+1 to Ymax do
  238.         Begin
  239.           GotoXY ( x+2, i );
  240.           write ( ' ' );
  241.         End;
  242.     End
  243.   else
  244.     Fire := false;
  245. End;
  246.  
  247. Procedure StartUp;
  248. Begin
  249.   x := Xmin;
  250.   y := Ymin;
  251.   shots := 0;
  252.   Eshots := 0;
  253.   won := false;
  254.   NewX := trunc ( random * (Xmax-10) + Xmin + 5 );
  255.   NewY := trunc ( random * (Ymax-6) + Ymin + 3 );
  256.   ClrScr;
  257.   ShiftStars ( 0, 0 );  { Draw the stars }
  258.   DrawShip ( NewX, NewY );
  259. End;
  260.  
  261. BEGIN
  262.   ESC := chr(27);
  263.   ship := '├─o─┤';
  264.   blowup[1] := '  ╞═o═╡';
  265.   blowup[2] := '  ╠═O═╣';
  266.   blowup[3] := ' ╠ ═O═ ╣';
  267.   blowup[4] := '├ ═ O ═ ┤';
  268.   blowup[5] := ': - ░ - :';
  269.   blowup[6] := '    ·    ';
  270.  
  271.   for i:=13 to Ymax do
  272.     Begin
  273.       Yp[i] := 40-12+i;
  274.       Ym[i] := 40+12-i;
  275.     End;
  276.  
  277.   for i:=1 to NumStars do
  278.     Begin
  279.       Star[i].X := trunc ( random * Xmax + 1 );
  280.       Star[i].Y := trunc ( random * Ymax + 1 );
  281.     End;
  282.  
  283.   ClrScr;
  284.   GotoXY ( 1, 10 );
  285.   writeln ( 'DEFENSE Version ', version: 3:1 );
  286.   writeln;
  287.   writeln ( 'Use the cursor control keys to move' );
  288.   writeln ( 'the aiming target in  the center of' );
  289.   writeln ( 'screen.  Use the Ins key to fire.' );
  290.   writeln;
  291.   writeln ( 'Strike any key when ready...' );
  292.   ch := GetChar;
  293.   continue := true;
  294.   while continue do
  295.     Begin
  296.       down := 0;
  297.       Tshots := 0;
  298.       lost := false;
  299.       ShotDown := false;
  300.       Randomize;
  301.       Rate := 500;
  302.       StartUp;
  303.       while NOT lost do
  304.         Begin
  305.           Action ( Rate );
  306.           if won then
  307.             Begin
  308.               ClrScr;
  309.               GotoXY ( 1, 5 );
  310.               down := down + 1;
  311.               Tshots := Tshots + shots;
  312.               writeln ( '  Enemy Shot Down : ', down:4 );
  313.               writeln ( 'Shots Enemy Fired : ', Eshots:4 );
  314.               writeln;
  315.               writeln ( '      Shots Fired : ', shots:4 );
  316.               writeln ( 'Total Shots Fired : ',Tshots:4 );
  317.               writeln ( '   Hit Percentage : ', down/Tshots*100 : 4:0 );
  318.               writeln;
  319.  
  320.               Rate := trunc ( Rate * ((shots/10.0) + 0.55) );
  321.               if Rate < 1 then
  322.                 Rate := 1;
  323.               writeln ( '       New Rating : ', 1000-Rate:4 );
  324.               for i:= 10 downto 1 do
  325.                 Begin
  326.                   GotoXY ( 1, 20 );
  327.                   write ( i:2, ' Seconds to next encounter...' );
  328.                   delay ( 1000 );
  329.                 End;
  330.               Startup;
  331.             End;
  332.           DrawShip ( x+trunc( random * 4.0 - 2.0), y+trunc(random * 4.0 - 2.0) );
  333.           ShotDown := Fire ( Rate );
  334.           if ShotDown then
  335.             lost := true;
  336.         End;
  337.       ClrScr;
  338.       GotoXY ( 1, 12 );
  339.       if ShotDown then
  340.         Begin
  341.           writeln ( 'He must have gotten a lucky shot, ''cause he got' );
  342.           writeln ( 'your ship dead center and blew it to pieces...' );
  343.         End
  344.       else
  345.         Begin
  346.           writeln ( 'The enemy was able to get around your defenses' );
  347.           writeln ( 'and destroy you from behind...');
  348.         End;
  349.       writeln;
  350.       writeln ( 'Better luck next time.' );
  351.       writeln;
  352.       writeln ( 'Final Rating : ',1000-Rate:4 );
  353.       writeln;
  354.       writeln ( 'Would you like to try again? (Y/N)' );
  355.       if UpCase ( GetChar )<>'Y' then
  356.         continue := false;
  357.     End
  358. END.
  359.