home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB16.ZIP / SNAKE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-15  |  4.5 KB  |  229 lines
  1. program Snake(input,output);
  2.  
  3. label
  4.  
  5. StartSnake, ExitSnake;
  6.  
  7. const
  8.  
  9. os = '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>';
  10. ys = '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
  11.  
  12. type
  13.  
  14. strg1 = string[37];
  15.  
  16. var
  17.  
  18. p, d                                : array[1..2] of integer;
  19. z1                                  : strg1;
  20. a, b, c, di, high, i, n, pt, q, z   : integer;
  21. r                                   : real;
  22. ch                                  : char;
  23. Quit, RoundOver                     : boolean;
  24. Monitor                             : char;
  25. Segment                             : integer;
  26.  
  27. procedure SetupAndInitializeVariables;
  28.  
  29. label
  30.  
  31. ExitSetup;
  32.  
  33. begin
  34.     textmode(2); clrscr;
  35.     randomize;
  36.     n:=0;
  37.     Quit:=false; RoundOver:=false;
  38.     writeln(os,'Snake',ys);
  39.     write('Enter Value for Delay (Q for Quit) : ');
  40.     readln(z1);
  41.     clrscr;
  42.     if (z1='Q') or (z1='q') then
  43.     begin
  44.          Quit:=true;
  45.          goto ExitSetup;
  46.     end;
  47.     if z1='' then z:=0
  48.     else
  49.          val(z1,z,q);
  50.     a:=219; b:=177;
  51.     c:=c+1;
  52.     p[1]:=2010; p[2]:=1990;
  53.     d[1]:=2;    d[2]:=-2;
  54.     r:=0.7;
  55.     for i:=1 to 80 do
  56.     begin
  57.          mem[segment:(i-1)*2]:=178;
  58.          mem[segment:(i-1)*2+3840]:=178;
  59.     end;
  60.     for i:=2 to 24 do
  61.     begin
  62.          mem[segment:(i-1)*160]:=178;
  63.          mem[segment:158+((i-1)*160)]:=178;
  64.     end;
  65. ExitSetup:
  66.     gotoxy(1,1);
  67. end;
  68.  
  69. procedure MoveUp;
  70. begin
  71.     d[1]:=-160;
  72. end;
  73.  
  74. procedure MoveLeft;
  75. begin
  76.     d[1]:=-2;
  77. end;
  78.  
  79. procedure MoveRight;
  80. begin
  81.     d[1]:=2;
  82. end;
  83.  
  84. procedure MoveDown;
  85. begin
  86.     d[1]:=160;
  87. end;
  88.  
  89. procedure PollKeybd;
  90. begin
  91.     if keypressed then
  92.     begin
  93.          read(kbd,ch);
  94.          if (ch=#27) and keypressed then
  95.          begin
  96.               read(kbd,ch);
  97.               if ch = #72 then MoveUp;
  98.               if ch = #75 then MoveLeft;
  99.               if ch = #77 then MoveRight;
  100.               if ch = #80 then MoveDown;
  101.          end;
  102.     end;
  103. end;
  104.  
  105. procedure SnakeTwoChangeDirection;
  106.  
  107. label
  108.  
  109. ExitSTCD, point0, point1;
  110.  
  111. begin
  112.     if (mem[segment:p[2]+d[2]]=32) and (random<r) then goto ExitSTCD;
  113.     if abs(d[2])=2 then
  114.     begin
  115.          d[2]:=160;
  116.          goto point0;
  117.     end;
  118.     if abs(d[2])=160 then
  119.     begin
  120.          d[2]:=2;
  121.          goto point0;
  122.     end;
  123.     if (mem[segment:p[2]]<2000) and (d[2]=160) then
  124.          d[2]:=-d[2];
  125.     goto point1;
  126. point0:
  127.     di:=p[2] div 160;
  128.     if di>12 then
  129.          d[2]:=-d[2];
  130. point1:
  131.     if mem[segment:d[2]+p[2]]<>32 then
  132.          d[2]:=-d[2];
  133. ExitSTCD:
  134. end;
  135.  
  136. procedure WinningTone;
  137. begin
  138.     i:=200;
  139.     while i<300 do
  140.     begin
  141.          sound(i);
  142.          delay(55);
  143.          i:=i+20;
  144.     end;
  145.     nosound; delay(110);
  146.     for i:=1 to 2 do
  147.     begin
  148.          sound(400);
  149.          delay(165);
  150.          sound(600);
  151.          delay(220);
  152.          nosound;
  153.     end;
  154. end;
  155.  
  156. procedure LosingTone;
  157. begin
  158.     i:=100;
  159.     while i>50 do
  160.     begin
  161.          sound(i);
  162.          delay(55);
  163.          i:=i-5;
  164.     end;
  165.     for i:=1 to 8 do
  166.     begin
  167.          sound(37);
  168.          delay(70);
  169.          sound(39);
  170.          delay(70);
  171.     end;
  172.     nosound;
  173. end;
  174.  
  175. procedure UpdateSnakes;
  176.  
  177. label
  178.  
  179. PlayerLost, PlayerWon, PostScoreInfo, ExitUpdateSnakes;
  180.  
  181. begin
  182.     p[1]:=p[1] + d[1];
  183.     p[2]:=p[2] + d[2];
  184.     r:=r+(1-r)/20; n:=n+1;
  185.     if mem[segment:p[1]]<>32 then goto PlayerLost;
  186.     if mem[segment:p[2]]<>32 then goto PlayerWon;
  187.     SnakeTwoChangeDirection;
  188.     delay(z);
  189.     goto ExitUpdateSnakes;
  190. PlayerLost:
  191.     write('You Lose   '); n:=n div 10; LosingTone; goto PostScoreInfo;
  192. PlayerWon:
  193.     write('You Win    '); WinningTone; goto PostScoreInfo;
  194. PostScoreInfo:
  195.     delay(400);
  196.     if n>high then high:=n;
  197.     pt:=pt+n; i:=pt div c;
  198.     writeln('Score: ',n,'  Average Score: ',i,'  High Score: ',high);
  199.     RoundOver:=true;
  200.     delay(2000);
  201. ExitUpdateSnakes:
  202.     mem[segment:p[1]]:=a;
  203.     mem[segment:p[2]]:=b;
  204. end;
  205.  
  206. BEGIN
  207.     pt:=0; c:=0; high:=0; n:=0;
  208.     Monitor := 'c';
  209.     Write('Do you have a color or monochrome monitor? (c,m)  ');
  210.     Readln(Monitor);
  211.     if monitor in ['M','m'] then
  212.      segment := $b000
  213.     else
  214.      segment := $b800;
  215. StartSnake:
  216.     SetupAndInitializeVariables;
  217.     if Quit=true then
  218.          goto ExitSnake;
  219.     repeat
  220.          UpdateSnakes;
  221.          PollKeybd;
  222.     until RoundOver=true;
  223.     goto StartSnake;
  224. ExitSnake:
  225.     i:=pt div c;
  226.     writeln('Average Score: ',i,'  High Score: ',high);
  227.     writeln('Thanksssss for playing Sssssnake!');
  228. end.
  229.