home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol019 / stars.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  6KB  |  266 lines
  1.  
  2. (***************************************************************
  3. *
  4. *        STARS---game
  5. *
  6. *  Donated by Ray Penley, June 1980
  7. *
  8. ****************************************************************)
  9.  
  10.  
  11. PROGRAM SHOOTINGSTARS;
  12. (*
  13. **  PROGRAM TITLE:    SHOOTING STARS
  14. **
  15. **  WRITTEN BY:        MARK J. BORGERSON
  16. **  DATE WRITTEN:    JUL 1976
  17. **
  18. **  WRITTEN FOR:    PERSONAL ENJOYMENT
  19. **
  20. **  TRANSLATED:        Translated from BASIC
  21. **             by Ray Penley, SEPT 1979
  22. **            16 April 80 - added KEYIN.
  23. **
  24. *)
  25.  
  26. TYPE
  27.   VECTOR = ARRAY[1..9] OF INTEGER;
  28. Var
  29.   seed1, seed2:    INTEGER;
  30.   stars, F5:    VECTOR;
  31.   C:        INTEGER;
  32.  
  33. Procedure KEYIN(VAR CIX : char); EXTERNAL;
  34.  
  35. Procedure INSTRUCTIONS;
  36. Var
  37.   I : INTEGER;
  38. BEGIN
  39. Writeln;
  40. Writeln('If you like brain teasers then you''re in for some fun.');
  41. Writeln('The object of this puzzle is to solve a 3 X 3 matrix such that');
  42. Writeln('*''s appeas in all positions except in the center which will be');
  43. Writeln('''. The positions on the matrix board are referred to by ROWS');
  44. Writeln('then COLUMNS. The upper right hand position would be referred');
  45. Writeln('to as; 1,3.');
  46. Writeln('When a * is made a '', its immediate neighbors change state,');
  47. Writeln('then is: *''s become '' and vice versa.');
  48. Writeln('In addition, changing corner positions also changes the center');
  49. Writeln('position; changing center position also changes outside');
  50. Writeln('middle positions. Have FUN!');
  51. Writeln;
  52.     (* TIMING LOOP *)
  53.   For I:=1 to 5000 do ;
  54. END(*---of INSTRUCTIONS---*);
  55.  
  56. Procedure SKIP(LINES:INTEGER);
  57. Var
  58.   I : INTEGER;
  59. BEGIN
  60.   FOR I := 1 TO LINES DO Writeln
  61. END(*---of SKIP---*);
  62.  
  63. Procedure HEADING;
  64. Var
  65.   A : INTEGER;
  66. BEGIN
  67.   Writeln(' ':20, '***  SHOOTING STARS  ***');
  68.   SKIP(2);
  69.   Writeln('DO YOU WANT INSTRUCTIONS (YES=1 NO=0)');
  70.   READ(A);
  71.   IF A=1 THEN INSTRUCTIONS
  72. END(*---of HEADING---*);
  73.  
  74. Procedure CLEAR;
  75. (*    !!!  DEVICE DEPENDENT ROUTINE !!!    *)
  76. BEGIN
  77.   Write( CHR(26) )
  78. END(*---of CLEAR---*);
  79.  
  80. Procedure HOMEUP;
  81. (*    !!!  DEVICE DEPENDENT ROUTINE !!!    *)
  82. BEGIN
  83.   Write( CHR(30) )
  84. END(*---of HOMEUP---*);
  85.  
  86. (*=================================================*
  87.    Implement a Fibonacci series Random number generator.
  88.    Written for PASCAL/Z By Raymond E. Penley, September 1979
  89.    Add these lines to your program
  90.  
  91. Var  seed1, seed2 : INTEGER;
  92.  
  93.     Within the body of the main program but
  94.     BEFORE calling RANDOM:
  95.    SEEDRAND;
  96. *=================================================*)
  97.  
  98. Procedure SEEDRAND;
  99. (* INITIAL VALUES FOR seed1 AND seed2 MAY BE
  100.    INPUT HERE  *)
  101. BEGIN
  102.    seed1 := 10946;
  103.    seed2 := 17711
  104. END;
  105.  
  106. FUNCTION RANDOM : INTEGER;
  107. (**
  108.    RANDOM will return numbers from 0 to 32767.
  109.    Call RANDOM using the following convention:
  110.      Range         Use
  111.       0 - 32    RANDOM DIV 1000
  112.       0 - 327    RANDOM DIV 100
  113.           0 - 32767    RANDOM
  114.  
  115. GLOBAL
  116.    seed1, seed2 : INTEGER
  117. **)
  118. CONST
  119.   HALFINT = 16383; (* 1/2 OF MAXINT *)
  120. Var
  121.   HALF1, HALF2, HALFADD : INTEGER;
  122.  
  123. BEGIN
  124.   HALF1 := seed1 DIV 2;
  125.   HALF2 := seed2 DIV 2;
  126.   IF (HALF1+HALF2) >= HALFINT THEN
  127.     HALFADD := HALF1 + HALF2 - HALFINT
  128.   ELSE
  129.     HALFADD := HALF1 + HALF2;
  130.   seed1 := seed2;
  131.   seed2 := HALFADD * 2;(* Restore from previous DIVision *)
  132.   RANDOM := seed2
  133. END(*---of RANDOM---*);
  134.  
  135. Procedure INITIALIZE;
  136. BEGIN
  137.   CLEAR;
  138.   C := 0;  (* SHOT COUNTER *)
  139.   stars[1] := (-23);    F5[1] := 1518;
  140.   stars[2] := (-3);    F5[2] := 1311;
  141.   stars[3] := (-19);    F5[3] := 570;
  142.   stars[4] := (-11);    F5[4] := 3289;
  143.   stars[5] :=    2;    F5[5] := 2310;
  144.   stars[6] := (-5);    F5[6] := 1615;
  145.   stars[7] := (-13);    F5[7] := 2002;
  146.   stars[8] := (-7);    F5[8] := 1547;
  147.   stars[9] := (-17);    F5[9] := 1190;
  148. END(*---of INITIALIZE---*);
  149.  
  150. Procedure LOAD;
  151. Var
  152.   I, X7 : INTEGER;
  153. BEGIN
  154.   FOR I := 1  TO 9 DO
  155.     BEGIN
  156.     X7 := ( RANDOM DIV 100 );
  157.     IF X7 > 200 THEN stars[I] := (-stars[I]);
  158.     END  (*FOR*)
  159. END(*---of LOAD---*);
  160.  
  161. Procedure BOARD;
  162. Var
  163.   J : INTEGER;
  164. BEGIN
  165.   HOMEUP;
  166.   WRITE(' ':20);
  167.   FOR J := 1 TO 9 DO
  168.     BEGIN
  169.       IF stars[ J ] < 0 THEN WRITE( '''        ');
  170.       IF stars[ J ] > 0 THEN WRITE( '*        ');
  171.       IF J MOD 3 = 0 THEN
  172.       BEGIN
  173.       SKIP(3);
  174.       WRITE(' ':20)
  175.     END(*IF*)
  176.     END(*FOR*);
  177.   Writeln
  178. END(*---of BOARD---*);
  179.  
  180. Procedure PLAYTHEGAME;
  181. Var
  182.   D, X        : INTEGER;
  183.   ENDOFGAME : BOOLEAN;
  184.  
  185.     FUNCTION CHECK : INTEGER;
  186.     (*
  187.      Check to if the F value for the shot can be evenly
  188.      divided by the stars value for each position. If the
  189.      stars value divides into F without a remainder, the
  190.      STAR or black hole is inverted (its sign is changed).
  191.     GLOBAL
  192.       X    :INTEGER;
  193.       stars, F5 :VECTOR   *)
  194.     Var
  195.       B1, K, Z5 :INTEGER;
  196.     BEGIN
  197.       B1 := 0;
  198.       FOR K := 1 TO 9 DO
  199.         BEGIN
  200.           Z5 := ( F5[ X ] DIV stars[ K ] ) * stars[ K ];
  201.           IF Z5 = F5[ X ] THEN stars[ K ] := (-stars[ K ])
  202.         END; (*FOR*)
  203.       FOR K := 1 TO 9 DO
  204.         B1 := B1 +stars[ K ];
  205.       CHECK := B1
  206.     END(*---of CHECK---*);
  207.  
  208.     Procedure INPUT;
  209.     (*
  210.     GLOBAL
  211.       C, X :INTEGER
  212.       stars   :VECTOR    *)
  213.     Var
  214.       CIX : Char;
  215.       ERROR : BOOLEAN;
  216.     BEGIN
  217.       REPEAT
  218.         ERROR := FALSE;(*Turn ERROR flag off for REPEAT *)
  219.         WRITE('Your Shot ');
  220.         KEYIN(CIX);
  221.         X := (ORD(CIX) -ORD('0'));
  222.         Writeln;
  223.         C := C +1;
  224.         IF (X<1) OR (X>9) THEN
  225.           ERROR := TRUE
  226.         ELSE
  227.           IF stars[ X ] <= 0 THEN
  228.             BEGIN
  229.           Writeln('You can only Shoot Stars');
  230.           ERROR := TRUE
  231.         END(* else *)
  232.       UNTIL NOT ERROR;
  233.       Writeln
  234.     END(*---of INPUT---*);
  235.  
  236. BEGIN  (* PLAYTHEGAME *)
  237.   ENDOFGAME := FALSE;
  238.   REPEAT
  239.     INPUT;
  240.     D := CHECK;
  241.     BOARD;
  242.     IF D = (-100) THEN
  243.       BEGIN
  244.     Writeln('You lost!!!');
  245.     ENDOFGAME := TRUE
  246.       END
  247.     ELSE
  248.       IF D=96 THEN
  249.     BEGIN
  250.       Writeln('You WIN!!!');
  251.       Writeln('You fired', C:3, ' shots');
  252.       ENDOFGAME := TRUE
  253.     END
  254.   UNTIL ENDOFGAME
  255. END(*---of PLAYTHEGAME---*);
  256.  
  257. BEGIN (* MAIN PROGRAM *)
  258.   HEADING;
  259.   CLEAR;
  260.   INITIALIZE;
  261.   SEEDRAND; (* seed the Random Number Generator *)
  262.   LOAD;
  263.   BOARD;
  264.   PLAYTHEGAME
  265. END(*---of SHOOTING STARS---*).
  266.