home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FACILIS1.ZIP / STARS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  8.4 KB  |  329 lines
  1. program stars;
  2. {*
  3. **  PROGRAM TITLE:       SHOOTING STARS
  4. **
  5. **  WRITTEN BY:          MARK J. BORGERSON
  6. **  DATE WRITTEN:        July, 1976
  7. **
  8. **  WRITTEN FOR:         PERSONAL ENJOYMENT
  9. **
  10. **  TRANSLATED:          Translated from BASIC
  11. **                       by Ray Penley, SEPT 1979
  12. **
  13. **  HISTORY:             Originally from Pascal/Z Users' Group
  14. **                       CP/M Users' Group volume 71
  15. **                       Modified for TURBO Pascal -- Wm Meacham, 6/5/84
  16. **                       Adapted for Facilis -- Anthony Marcy, Mar 1985
  17. *}
  18.  
  19. type
  20.   vector = array[1..9] of integer;
  21.   str80 = string[80];
  22.  
  23. var
  24.    seed1,seed2: integer;
  25.       stars,f5: vector;
  26.              c: integer;
  27.     done,reply: boolean;
  28.           hole: char;
  29.  
  30. { -------------------- Screen handling routines -------------------- }
  31.  
  32. procedure keyin(var cix: char);
  33.   begin
  34.     read(cix)
  35.   end;
  36.  
  37.  
  38. procedure write_str (st: str80; col,row: integer);
  39.   begin
  40.     gotoxy(col,row);
  41.     write(st)
  42.   end;
  43.  
  44.  
  45. procedure pause;    {Prints message on line 24, waits for user response}
  46.   var ch: char;
  47.   begin
  48.     write_str('PRESS SPACE BAR TO CONTINUE',21,24);
  49.     repeat
  50.       keyin(ch)
  51.     until ch = chr($20);
  52.     write_str('                           ',21,24)
  53.   end;
  54.  
  55.  
  56. procedure read_bool(var bool: boolean; col,row: integer);
  57.   { Inputs "Y" OR "N" to boolean at row and column specified,
  58.     prints "YES" or "NO"}
  59.  
  60.   var ch: char;
  61.  
  62.   begin
  63.     gotoxy(col,row);
  64.     write('   ') ;
  65.     gotoxy(col,row);
  66.     repeat
  67.       keyin(ch)
  68.     until  (ch='Y') or (ch='y') or (ch='N') or (ch='n');
  69.     gotoxy(col,row);
  70.     if (ch = 'Y') or (ch = 'y')
  71.     then begin
  72.         write ('YES');
  73.         bool := true
  74.       end
  75.     else begin
  76.         write('NO ');
  77.         bool := false
  78.       end
  79.   end;  {read_bool}
  80.  
  81.  
  82. procedure clreos;
  83.   begin
  84.     write_str('                   ',21,14);
  85.     write_str('                   ',21,17);
  86.     write_str('                   ',21,20);
  87.     write_str('        ',21,22);
  88.   end;
  89.  
  90.  
  91. procedure skip(lines: integer);
  92.   var  i: integer;
  93.   begin
  94.     for i := 1 to lines do writeln;
  95.   end;
  96.  
  97. { -------------------- Routines for the game as such -------------------- }
  98.  
  99. procedure instructions;
  100.   var  i: integer;
  101.   begin
  102.     clrscr;
  103.     writeln('If you like brain teasers then you''re in for some fun.');
  104.     writeln('The object of this puzzle is to solve a 3 X 3 matrix to make');
  105.     textcolor(6); write('*'); textcolor(3);
  106.     write('s appear in all positions except in the center which will be ');
  107.     textcolor(9); write(hole); textcolor(3);
  108.     writeln('.');
  109.     writeln('The positions on the matrix board are referred to as follows:');
  110.     writeln('      7   8   9');
  111.     writeln('      4   5   6');
  112.     writeln('      1   2   3    -- just like your numeric keypad.');
  113.     write('When you shoot a ');
  114.     textcolor(6); write('*'); textcolor(3);
  115.     write(' it becomes a ');
  116.     textcolor(9); write(hole); textcolor(3);
  117.     writeln(', and its immediate neighbors change state;');
  118.     write('that is, ');
  119.     textcolor(6); write('*'); textcolor(3);
  120.     write('s become ');
  121.     textcolor(9); write(hole); textcolor(3);
  122.     writeln('s and vice versa.');
  123.     writeln('In addition, changing a corner position also changes the center position;');
  124.     writeln('changing the center position also changes the outside middle positions.');
  125.     write('You lose the game when there are no more ');
  126.     textcolor(6); write('*'); textcolor(3);
  127.     writeln('s to shoot.');
  128.     writeln('It can always be done in fewer than a dozen shots.');
  129.     writeln;
  130.     writeln('Make sure NumLock is in numeric mode.');
  131.     writeln;
  132.     writeln;
  133.     writeln('Have fun, and good luck!');
  134.     pause;
  135.   end;
  136.  
  137.  
  138. procedure heading;
  139.   var  ans: boolean;
  140.   begin
  141.     hole := chr(249);  { black hole symbol }
  142.     clrscr;
  143.     textcolor(3);
  144.     writeln(' ':20, '***  SHOOTING STARS  ***');
  145.     skip(2);
  146.     write('Do you want instructions? (Y/N)');
  147.     read_bool(ans,33,4);
  148.     if ans then instructions;
  149.   end;
  150.  
  151.  
  152. function randm: integer;     { RANDM will return numbers from 0 to 32767 }
  153.   begin
  154.     randm := random(maxint);
  155.   end;
  156.  
  157.  
  158. procedure initialize;
  159.   begin
  160.     clrscr;
  161.     c := 0 ;  { shot counter }
  162.     stars[1] := -23;       f5[1] := 1518;
  163.     stars[2] :=  -3;       f5[2] := 1311;
  164.     stars[3] := -19;       f5[3] :=  570;
  165.     stars[4] := -11;       f5[4] := 3289;
  166.     stars[5] :=   2;       f5[5] := 2310;
  167.     stars[6] :=  -5;       f5[6] := 1615;
  168.     stars[7] := -13;       f5[7] := 2002;
  169.     stars[8] :=  -7;       f5[8] := 1547;
  170.     stars[9] := -17;       f5[9] := 1190;
  171.     write_str('7        8        9',21,14);
  172.     write_str('4        5        6',21,17);
  173.     write_str('1        2        3',21,20);
  174.     write_str('0 - Quit',21,22);
  175.   end;
  176.  
  177.  
  178. procedure load;
  179.   var  i,x7,sum: integer;
  180.   begin
  181.     repeat
  182.       sum := 0;
  183.       for i := 1 to 9 do begin
  184.         x7 := randm div 100;
  185.         if x7 > 200 then stars[i] := -stars[i];
  186.         sum := sum + stars[i];
  187.       end
  188.     until (sum<>96) and (sum<>-100);
  189.   end;
  190.  
  191.  
  192. procedure board;
  193.   var j: integer;
  194.   begin
  195.     gotoxy(1,1);
  196.     write(' ':20);
  197.     for j := 7 to 9 do begin
  198.       if stars[j] < 0 then begin textcolor(9); write(hole+'        '); end
  199.       else begin textcolor(6); write('*        '); end
  200.     end;
  201.     skip(3);
  202.     write(' ':20);
  203.     for j := 4 to 6 do begin
  204.       if stars[j] < 0 then begin textcolor(9); write(hole+'        '); end
  205.       else begin textcolor(6); write('*        '); end
  206.     end;
  207.     skip(3);
  208.     write(' ':20);
  209.     for j := 1 to 3 do begin
  210.       if stars[j] < 0 then begin textcolor(9); write(hole+'        '); end
  211.       else begin textcolor(6); write('*        '); end
  212.     end;
  213.     skip(4);
  214.     textcolor(3);
  215.   end;
  216.  
  217.  
  218. procedure playthegame;
  219.  
  220.   var
  221.     d,x: integer;
  222.     endofgame,quit: boolean;
  223.  
  224.   function check: integer;
  225.  
  226.     { Check to if the F value for the shot can be evenly
  227.       divided by the stars value for each position. If the
  228.       stars value divides into F without a remainder, the
  229.       STAR or black hole is inverted (its sign is changed). }
  230.  
  231.     var b1,k,z5: integer;
  232.     begin
  233.       b1 := 0;
  234.       for k := 1 to 9 do begin
  235.         z5 := (f5[x] div stars[k]) * stars[k];
  236.         if z5 = f5[x] then stars[k] := -stars[k]
  237.       end;
  238.       for k := 1 to 9 do
  239.         b1 := b1 + stars[k];
  240.       check := b1
  241.     end;
  242.  
  243.  
  244.   procedure input;
  245.  
  246.     var
  247.         cix: char;
  248.       error: boolean;
  249.           i: integer;
  250.  
  251.     begin
  252.       repeat
  253.         error := false;
  254.         write_str('             ',1,11);
  255.         write_str('Your Shot ',1,11);
  256.         keyin(cix);
  257.         if cix='0'
  258.         then quit := true
  259.         else
  260.           begin
  261.             x := (ord(cix) - ord('0'));
  262.             writeln;
  263.             c := c + 1;
  264.             if (x<1) or (x>9)
  265.             then error := true
  266.             else if stars[x] <= 0 then
  267.               begin
  268.                 write_str('You can only Shoot Stars',1,12);
  269.                 sound(60);
  270.                 delay(500);
  271.                 nosound;
  272.                 delay(400);
  273.                 write_str('                        ',1,12);
  274.                 error := true
  275.               end
  276.           end
  277.       until not error;
  278.       writeln;
  279.     end;  { of input }
  280.  
  281.  
  282.  
  283.   begin  { playthegame }
  284.     endofgame := false;
  285.     quit := false;
  286.     repeat
  287.       input;
  288.       if quit
  289.       then begin
  290.           write_str('                   ',1,11); writeln;
  291.           writeln('GAME TERMINATED          ');
  292.           endofgame := true
  293.         end
  294.       else begin
  295.           d := check;
  296.           board;
  297.           if d = -100
  298.           then begin
  299.               writeln('You lost!!!');
  300.               endofgame := true
  301.             end
  302.           else if d=96
  303.           then begin
  304.               textcolor(12); writeln('You WIN!!! ') ; textcolor(3);
  305.               writeln('You fired ', c:1, ' shots.');
  306.               endofgame := true
  307.             end
  308.         end
  309.     until endofgame
  310.   end;   { of playthegame }
  311.  
  312. { -------------------- The main program -------------------- }
  313.  
  314. begin   { stars }
  315.   done := false;
  316.   repeat
  317.     heading;
  318.     initialize;
  319.     load;
  320.     board;
  321.     playthegame;
  322.     clreos;
  323.     write_str('Would you like to play again?', 1, 13);
  324.     read_bool(reply, 31, 13);
  325.     if not reply then done := true;
  326.   until done
  327. end.
  328. uld you like to play again?', 1, 13);
  329.