home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TPONG1.ZIP / TPONG1.PAS
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  10.7 KB  |  238 lines
  1. (****************************************************************************)
  2. (*           TPONG-1.PAS        Glenn A. Reiff    74035,400     4/5/85      *)
  3. (*                                                                          *)
  4. (*  Note:  While this program is usable and will provide some fun, the      *)
  5. (*         Paddle control is not as responsive as it is in the original     *)
  6. (*         Basic program.  Also, the side bounces could be better.  If      *)
  7. (*         you are able to make any improvements I'd appreciate knowing     *)
  8. (*         about them.                                                      *)
  9. (****************************************************************************)
  10. type Str80 = string[80];       procedure CENTER(Y:integer; Bt:Str80); forward;
  11. procedure INTRODUCTION;
  12. BEGIN
  13.      clrscr;                    CENTER(5,'TURBO PONG');
  14.      CENTER(8,'This is an adaption to Turbo Pascal of the Basic program  ');
  15.      CENTER(9,'called PChallenge written by Karl Koessel and published in');
  16.      CENTER(10,'a 1982 issue of PC Magazine.                              ');
  17.      CENTER(12,'His was a simplification of Pong, the orignial video game.');
  18.      CENTER(13,'Pong was developed in the early 1970''s by Nolan Bushnell. ');
  19.      CENTER(20,'Tap a Key to Continue');
  20.      writeln; gotoXY(80,25);
  21.      repeat until keypressed;
  22. END; { INTRODUCTION }
  23.  
  24.  
  25. type       CharSet                         = set of Char;
  26.            Str9                            = string[9];
  27.  
  28. var        Paddle                          : Str9;
  29.            StartTime,EndTime,BestTime,Drag : integer;
  30.            Ch                              : char;
  31.  
  32.  
  33. procedure CENTER;
  34.   var  Tab:  integer;
  35.        BEGIN Tab:=(80-Length(Bt)) div 2; gotoXY(Tab,Y); write(Bt); END;
  36.  
  37. Procedure TEXTBORDER (color: integer);
  38.   type    result = record
  39.                     AL,AH,BL,BH,CL,CH,DL,DH:        Byte;
  40.                     BP,SI,DI,DS,ES,Flags:           Integer;
  41.                    end;
  42.   var     registers:        result;
  43.   BEGIN
  44.       With registers do begin
  45.            AH := 11; BH := 0; BL := color; Intr($10,registers); end;
  46.   END; { TEXTBORDER }
  47.  
  48. Procedure BEEP(N : Integer);
  49. BEGIN   Sound(n);  Delay(100);  NoSound; END;
  50.  
  51. function GET_TIME: integer;
  52. type      register = Record
  53.                         AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
  54.                      End;
  55. var       allregs : register;
  56. BEGIN
  57.    allregs.ax := $2C * 256;
  58.    MsDos(allregs);
  59.    GET_TIME := 3600 * (allregs.cx div 256) + 60 * (allregs.cx mod 256) + allregs.dx div 256;
  60. END;  { GET_TIME }
  61.  
  62. procedure CHOOSE(    X,Y    : integer;
  63.                      Prompt : Str80;
  64.                      Term   : CharSet;
  65.                  var TC     : Char    );
  66. var   I  : integer;
  67.       Ch : char;
  68. BEGIN
  69.   lowvideo; gotoXY(X,Y);
  70.   for I:=1 to length(Prompt) do begin
  71.       Ch:=copy(Prompt,I,1);
  72.       if I>4 then begin
  73.         lowvideo;
  74.         if (copy(Prompt,I-2,1)=' ') and (copy(Prompt,I-1,1)=' ') then highvideo;
  75.         if (copy(Prompt,I-1,1)='<') or (copy(Prompt,I-1,1)='/') then highvideo;
  76.       end; { if I>3 }
  77.       write(Ch);
  78.   end; { for I }
  79.   repeat
  80.     Read(Kbd,Ch);
  81.     TC := Upcase(Ch);
  82.     if not (TC in Term) then BEEP(1000);
  83.   until TC in Term;
  84. END; { CHOOSE }
  85.  
  86. procedure RESET(var Drag: integer;  var Paddle: Str9);
  87. BEGIN
  88.      TEXTBORDER(Black); textbackground(Black); clrscr;
  89.      CENTER(10,'Left and right cursor keys move paddle.');
  90.      textcolor(LightCyan);
  91.      CENTER(12,'Input drag factor: (100 is Medium...0 is FAST!)  '); read(Drag);
  92.      CHOOSE(17,14,'Pick a paddle size:  Small,  Medium or  Large  ',['S','M','L'],Ch);
  93.      if Ch = 'S' then Paddle := ' '+chr(27)+' '+chr(26)+' '
  94.        else if Ch = 'M' then Paddle := ' '+chr(27)+'   '+chr(26)+' '
  95.           else if Ch = 'L' then Paddle := ' '+chr(27)+'     '+chr(26)+' ';
  96. END; { RESET }
  97.  
  98. procedure RUN;
  99. label NewBall;
  100. var   Used                                 :   array[1..10] of integer;
  101. var   X,dX,Xpad,Y,dY,B,C,I,J,BallNr,Xstart :   integer;
  102.       Flag                                 :   boolean;
  103.  
  104.                                  procedure RANDOMIZE;
  105.                                  BEGIN
  106.                                       dX := random(7) - random(7);
  107.                                       if dX < 0  then begin
  108.                                         repeat
  109.                                             dX := random(7) - random(7);
  110.                                             if dX=0 then dX:=-1;
  111.                                         until X-6/dX=trunc(X-6/dX)
  112.                                       end; { if dX }
  113.                                       if dX > 0  then begin
  114.                                         repeat
  115.                                             dX := random(7) - random(7);
  116.                                             if dX=0 then dX:=1;
  117.                                         until 59-X/dX=trunc(59-X/dX)
  118.                                       end; { if dX }
  119.                                  END; { RANDOMIZE }
  120.  
  121.                                  procedure POSITION_PADDLE;
  122.                                  BEGIN
  123.                                        gotoXY(Xpad,22); textbackground(LightGray);
  124.                                        textcolor(DarkGray); write(Paddle); textbackground(C);
  125.                                  END; { POSITION_PADDLE }
  126.  
  127.                                  procedure ONKEY;
  128.                                  BEGIN
  129.                                        read(kbd,Ch);
  130.                                        if (Ch = #27) and keypressed then  { it must be a function key }
  131.                                            read(kbd,Ch);
  132.                                        case Ch of
  133.                                         'K':   if Xpad > 7 then begin
  134.                                                  Xpad:=Xpad-3; POSITION_PADDLE;
  135.                                                  gotoXY(Xpad+length(Paddle),22); write('   '); end;
  136.                                         'M':   if Xpad + length(Paddle) < 60 then begin
  137.                                                  Xpad:=Xpad+2; POSITION_PADDLE;
  138.                                                  gotoXY(Xpad-3,22); write('   '); end;
  139.                                        end;   { case }
  140.                                  END; { ONKEY }
  141.  
  142.  
  143. BEGIN
  144.      J := 11; Xpad := 29; C := random(16);
  145.      if (C=0) or (C=1) or (C=6) or (C=7) or (C=8) or (C=9) or (C=12) or (C=15) then C := 2;
  146.      textbackground(C); clrscr; TEXTBORDER(C);
  147.  
  148.      for X:=8 to 17 do begin                                    { Setup  10 Balls }
  149.          J := J + 4; textbackground(red); textcolor(white);
  150.          gotoXY(J,2); write(chr(2)); textbackground(C);
  151.      end; { for X }
  152.      textcolor(Blue);
  153.      for X:=5 to 59 do begin gotoXY(X,3); write(chr(219)); end;  { Draw Backboard }
  154.      for Y:=3 to 21 do begin                                     { Draw Walls     }
  155.         gotoXY(5,Y); write(chr(219),chr(219)); gotoXY(59,Y); write(chr(219),chr(219));
  156.      end;
  157.      POSITION_PADDLE; textcolor(Black);
  158.      gotoXY(5,24);write('Best Time so far is ',BestTime,' seconds.');
  159.      gotoXY(66,3);write('TURBOPONG');gotoXY(66,8);
  160.      gotoXY(63,6);write('Initial Drag ',Drag);
  161.      for I:=1 to 10 do Used[I]:=0;
  162.      BallNr := 10;
  163.      StartTime := GET_TIME;
  164.  
  165.      while BallNr > 0 do begin
  166.        NewBall:  Xstart := 1 + random(10); Flag:=false;
  167.                  for I:=1 to 10 do if Used[I] = Xstart then Flag:=true;
  168.                  if Flag then goto NewBall;
  169.                  Used[BallNr]:=Xstart;
  170.                  Xstart := 11 + 4 * Xstart;
  171.                  gotoXY(Xstart,2); write(' ');
  172.                  X := Xstart; Y := 4; dY := 1; Flag := false;
  173.                  RANDOMIZE;
  174.            while Y < 23 do begin
  175.                  if keypressed then ONKEY;
  176.                  textbackground(C);
  177.                  if (Y > 4) and (X>6) and (X<59) then            { Erase Previous Ball Below }
  178.                      begin gotoXY(X,Y-1); write(' '); end;
  179.                  if (Y<21) and (X>6) and (X<59)then
  180.                      begin gotoXY(X,Y+1); write(' '); end;       { Erase Previous Ball Above }
  181.                  if (Y=21) and (X>=Xpad) and (X<=Xpad+length(Paddle)) then
  182.                      begin gotoXY(X,Y); write(' '); end;         { Erase Ball On Paddle      }
  183.  
  184.                  X:=X + dX;
  185.  
  186.                  textbackground(red); textcolor(white);
  187.                  gotoXY(X,Y);
  188.                  if (X>6) and (X<59) then write(chr(1));         { Print New Ball Position }
  189.                  gotoXY(80,25);
  190.                  if (X <= 7) or (X >=58) then begin
  191.                    BEEP(300+random(80*BallNr)); dX:=-dX; end;    { Side Wall Bounce        }
  192.                  if keypressed then ONKEY;
  193.  
  194.                  if (Y=21) and (X>=Xpad) and (X<=Xpad+length(Paddle)) then
  195.                     begin
  196.                       dY := -dY; BEEP(700);                      { Bounce Off Of Paddle }
  197.                       if dX = 0 then RANDOMIZE;
  198.                  end; { if Y=21 }
  199.  
  200.                  if Y = 22 then begin
  201.                      textbackground(C); gotoXY(X,Y); write(' ');
  202.                      textbackground(red); textcolor(white);      { Park Used Ball       }
  203.                      gotoXY(25+Xstart,Y+2); write(chr(1)); gotoXY(80,25);
  204.                  end;
  205.                  if keypressed then ONKEY;
  206.                  if (Y = 4) and (Flag) then begin                { Bounce Off of Top Backboard }
  207.                      BEEP(300+random(80*BallNr)); Drag := Drag - 5;  { Reduce Amout of Drag    }
  208.                      if dX = 0 then RANDOMIZE; dX := dX + 1;
  209.                      dY := -dY; Y := Y + dY; end
  210.                    else begin Y := Y + dY; Flag := true;
  211.                  end; { if Y }
  212.                  if Drag <0 then Drag := 0;
  213.                  delay(50+Drag);
  214.            end; { while Y }
  215.            BallNr := BallNr - 1; textbackground(C);
  216.      end; { while BallNr }
  217.      gotoXY(1,22); clreol;
  218.      textcolor(Black); gotoXY(63,8); if Drag < 0 then Drag := 0;
  219.      write('Final Drag   ',Drag);
  220.      EndTime := GET_TIME;
  221.      if EndTime - StartTime > BestTime then BestTime := EndTime - StartTime;
  222.      gotoXY(5,24);write('Best Time so far is ',BestTime,' seconds.');
  223.      gotoXY(63,11); write('This Run ',EndTime-StartTime, ' sec.');
  224. END; { RUN }
  225.  
  226. {MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM}
  227. BEGIN
  228.           BestTime := 0; Drag := 0; Paddle := '';
  229.           INTRODUCTION;
  230.           RESET(Drag,Paddle);
  231.           repeat
  232.             RUN;
  233.             CHOOSE(19,22,'    Quit  Reset  Continue   ',['Q','R','C'],Ch);
  234.             if Ch = 'R' then RESET(Drag,Paddle);
  235.           until Ch = 'Q';
  236.           TEXTBORDER(Black); textbackground(Black); clrscr;
  237. END.
  238.