home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / ENTERPRS / CPM / UTILS / S / TPASPGM.ARC / STARS.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-27  |  13KB  |  410 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. **                       16 April 80 - added KEYIN.
  13. **
  14. **  HISTORY:             Originally from Pascal/Z Users' Group
  15. **                       CP/M Users' Group volume 71
  16. **                       Modified for TURBO Pascal -- Wm Meacham, 6/2/84
  17. **                       Further "User friendly" enhancements -- WPM, 6/5/84
  18. *}
  19.  
  20. TYPE
  21.     VECTOR = ARRAY[1..9] OF INTEGER ;
  22.     STR80 = STRING[80] ;
  23.  
  24. VAR
  25.     SEED1, SEED2    : INTEGER ;
  26.     STARS, F5       : VECTOR ;
  27.     C               : INTEGER ;
  28.     DONE,REPLY      : BOOLEAN ;
  29.  
  30. { -------------------- Screen handling routines -------------------- }
  31.  
  32. PROCEDURE KEYIN(VAR CIX : CHAR) ;
  33.     BEGIN
  34.         READ (KBD,CIX)                  { For TURBO Pascal -- WPM, 6/2/84}
  35.     END ;
  36.  
  37. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  38.  
  39. PROCEDURE WRITE_STR (ST:STR80 ; COL,ROW:INTEGER) ;
  40.     BEGIN
  41.         GOTOXY (COL,ROW) ;
  42.         WRITE (ST)
  43.     END ;
  44.  
  45. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  46.  
  47. PROCEDURE PAUSE ;
  48.     {Prints message on line 24, waits for user response}
  49.     VAR CH : CHAR ;
  50.     BEGIN
  51.         WRITE_STR ('PRESS SPACE BAR TO CONTINUE',21,24) ;
  52.         REPEAT
  53.                 KEYIN (CH)
  54.         UNTIL CH = CHR($20) ;
  55.         WRITE_STR ('                           ',21,24)
  56.     END ;
  57.  
  58. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  59.  
  60. PROCEDURE READ_BOOL (VAR BOOL:BOOLEAN; COL,ROW:INTEGER) ;
  61.   { Inputs "Y" OR "N" to boolean at row and column specified,
  62.     prints "YES" or "NO"}
  63.     
  64.     VAR
  65.         CH:CHAR ;
  66.  
  67.     BEGIN
  68.         GOTOXY (COL, ROW) ;
  69.         WRITE ('   ') ;
  70.         GOTOXY (COL, ROW) ;
  71.         REPEAT
  72.                 KEYIN (CH)
  73.         UNTIL (CH IN ['Y', 'y', 'N', 'n']) ;
  74.         IF (CH = 'Y') OR (CH = 'y') THEN
  75.             BEGIN
  76.                 WRITE ('YES') ;
  77.                 BOOL := TRUE
  78.             END
  79.         ELSE
  80.             BEGIN
  81.                 WRITE ('NO ') ;
  82.                 BOOL := FALSE
  83.             END
  84.     END ;
  85.  
  86. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  87.  
  88. PROCEDURE BEEP ;
  89.     BEGIN
  90.         WRITE (CHR(7))
  91.     END ;
  92.  
  93. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  94.  
  95. { PROCEDURE CLRSCR ;
  96.     Clear screen & home cursor -- Built-in TURBO procedure }
  97.  
  98. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  99.  
  100. PROCEDURE CLREOS ;
  101. {         !!!  Device dependent routine !!!          }
  102.     BEGIN
  103.         WRITE ( CHR($17) )  {Clear to end of screen on Kaypro & ADM-3A}
  104.     END ;
  105.  
  106. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  107.  
  108. PROCEDURE SKIP(LINES:INTEGER) ;
  109.     VAR
  110.         I : INTEGER ;
  111.     BEGIN
  112.         FOR I := 1 TO LINES DO WRITELN
  113.     END {---of SKIP---} ;
  114.  
  115. { -------------------- Routines for the game as such -------------------- }
  116.  
  117. PROCEDURE INSTRUCTIONS ;
  118.     VAR
  119.         I : INTEGER ;
  120.     BEGIN
  121.         CLRSCR ;
  122.         WRITELN('If you like brain teasers then you''re in for some fun.') ;
  123.         WRITELN('The object of this puzzle is to solve a 3 X 3 matrix such that') ;
  124.         WRITELN('*s appear in all positions except in the center which will be ''.') ;
  125.         WRITELN('The positions on the matrix board are referred to as follows:') ;
  126.         WRITELN('      7   8   9') ;
  127.         WRITELN('      4   5   6') ;
  128.         WRITELN('      1   2   3    -- just like your numeric keypad.') ;
  129.         WRITELN('When a * is made a '', its immediate neighbors change state,') ;
  130.         WRITELN('that is: *s become ''s and vice versa.') ;
  131.         WRITELN('In addition, changing a corner position also changes the center') ;
  132.         WRITELN('position;  changing the center position also changes the outside') ;
  133.         WRITELN('middle positions.') ;
  134.         WRITELN ;
  135.         WRITELN('You will be asked if you want to change the default initial board.') ;
  136.         WRITELN('Answer "N" to get the same board each time you play.') ;
  137.         WRITELN ;
  138.         WRITELN('Type 0 to quit.  Have fun!') ;
  139.         PAUSE ;
  140.     END {---of INSTRUCTIONS---} ;
  141.  
  142. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  143.  
  144. PROCEDURE HEADING ;
  145.     VAR
  146.         ANS : BOOLEAN ;
  147.     BEGIN
  148.         CLRSCR ;
  149.         WRITELN(' ':20, '***  SHOOTING STARS  ***') ;
  150.         SKIP(2) ;
  151.         WRITE ('Do you want instructions? (Y/N)') ;
  152.         READ_BOOL (ANS, 33, 4) ;
  153.         IF ANS THEN INSTRUCTIONS
  154.     END {---of HEADING---} ;
  155.  
  156. (*============================================================*
  157.  
  158.    Procedures SEEDRAND and RANDM implement a Fibonacci series
  159.    Random number generator.  Written for PASCAL/Z By Raymond E.
  160.    Penley, September 1979.   Add these lines to your program --
  161.  
  162.        VAR  SEED1, SEED2 : INTEGER ;
  163.  
  164.    Within the body of the main program but
  165.    BEFORE calling RANDM --
  166.  
  167.        SEEDRAND ;
  168.  
  169.  *============================================================*)
  170.  
  171. PROCEDURE SEEDRAND ;
  172. { Initial values for SEED1 and SEED2 may be input here  }
  173.     VAR
  174.         ANS : BOOLEAN ;
  175.     BEGIN
  176.         SEED1 := 10946 ;
  177.         SEED2 := 17711 ;
  178.         CLRSCR ;
  179.         WRITE ('Do you want to change the default initial board? (Y/N)') ;
  180.         READ_BOOL (ANS, 56, 1) ;
  181.         IF ANS THEN
  182.             BEGIN
  183.                 SEED1 := RANDOM (MAXINT) ;    {Built-in TURBO function}
  184.                 SEED2 := RANDOM (MAXINT)
  185.             END
  186.     END {--- of SEEDRAND ---} ;
  187.  
  188. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  189.  
  190. FUNCTION RANDM : INTEGER ;
  191.  
  192.   { RANDM will return numbers from 0 to 32767.
  193.     Call RANDM using the following convention:
  194.          Range                 Use
  195.           0 - 32        RANDM DIV 1000
  196.           0 - 327        RANDM DIV 100
  197.           0 - 32767        RANDM
  198.  
  199.     GLOBAL
  200.         SEED1, SEED2 : INTEGER  }
  201.  
  202.     CONST
  203.         HALFINT = 16383 ; { 1/2 OF MAXINT }
  204.     VAR
  205.         HALF1, HALF2, HALFADD : INTEGER ;
  206.  
  207.     BEGIN
  208.         HALF1 := SEED1 DIV 2 ;
  209.         HALF2 := SEED2 DIV 2 ;
  210.         IF (HALF1+HALF2) >= HALFINT THEN
  211.                 HALFADD := HALF1 + HALF2 - HALFINT
  212.         ELSE
  213.                 HALFADD := HALF1 + HALF2 ;
  214.         SEED1 := SEED2 ;
  215.         SEED2 := HALFADD * 2 ; { Restore from previous DIVision }
  216.         RANDM := SEED2
  217.     END {---of RANDM---} ;
  218.  
  219. (*============================================================*)
  220.  
  221. PROCEDURE INITIALIZE ;
  222.     BEGIN
  223.         CLRSCR ;
  224.         C := 0 ;  { SHOT COUNTER }
  225.         STARS[1] := (-23) ;       F5[1] := 1518 ;
  226.         STARS[2] := (-3) ;        F5[2] := 1311 ;
  227.         STARS[3] := (-19) ;       F5[3] := 570 ;
  228.         STARS[4] := (-11) ;       F5[4] := 3289 ;
  229.         STARS[5] :=    2 ;        F5[5] := 2310 ;
  230.         STARS[6] := (-5) ;        F5[6] := 1615 ;
  231.         STARS[7] := (-13) ;       F5[7] := 2002 ;
  232.         STARS[8] := (-7) ;        F5[8] := 1547 ;
  233.         STARS[9] := (-17) ;       F5[9] := 1190 ;
  234.         WRITE_STR ('7        8        9', 21, 14) ;
  235.         WRITE_STR ('4        5        6', 21, 17) ;
  236.         WRITE_STR ('1        2        3', 21, 20) ;
  237.         WRITE_STR ('0 - Quit', 21, 22)
  238.     END {---of INITIALIZE---} ;
  239.  
  240. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  241.  
  242. PROCEDURE LOAD ;
  243.     VAR
  244.         I, X7 : INTEGER ;
  245.     BEGIN
  246.         FOR I := 1  TO 9 DO
  247.             BEGIN
  248.                 X7 := ( RANDM DIV 100 ) ;
  249.                 IF X7 > 200 THEN STARS[I] := (-STARS[I])
  250.             END
  251.     END {---of LOAD---} ;
  252.  
  253. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  254.  
  255. PROCEDURE BOARD ;
  256.     VAR
  257.         J : INTEGER ;
  258.     BEGIN
  259.         GOTOXY (1,1) ;
  260.         WRITE(' ':20) ;
  261.         FOR J := 7 TO 9 DO
  262.             BEGIN
  263.                 IF STARS[ J ] < 0 THEN WRITE( '''        ') ;
  264.                 IF STARS[ J ] > 0 THEN WRITE( '*        ')
  265.             END ;
  266.         SKIP(3) ;
  267.         WRITE(' ':20) ;
  268.         FOR J := 4 TO 6 DO
  269.             BEGIN
  270.                 IF STARS[ J ] < 0 THEN WRITE( '''        ') ;
  271.                 IF STARS[ J ] > 0 THEN WRITE( '*        ')
  272.             END ;
  273.         SKIP(3) ;
  274.         WRITE(' ':20) ;
  275.         FOR J := 1 TO 3 DO
  276.             BEGIN
  277.                 IF STARS[ J ] < 0 THEN WRITE( '''        ') ;
  278.                 IF STARS[ J ] > 0 THEN WRITE( '*        ')
  279.             END ;
  280.         SKIP(4)
  281.     END {---of BOARD---} ;
  282.  
  283. { ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
  284.  
  285. PROCEDURE PLAYTHEGAME ;
  286.  
  287.     VAR
  288.         D, X            : INTEGER ;
  289.         ENDOFGAME, QUIT : BOOLEAN ;
  290.  
  291.     {   --------------------   }
  292.  
  293.     FUNCTION CHECK : INTEGER ;
  294.  
  295.       { Check to if the F value for the shot can be evenly
  296.         divided by the stars value for each position. If the
  297.         stars value divides into F without a remainder, the
  298.         STAR or black hole is inverted (its sign is changed).
  299.  
  300.         GLOBAL
  301.             X         : INTEGER ;
  302.             STARS, F5 : VECTOR  ; }
  303.  
  304.         VAR
  305.             B1, K, Z5 : INTEGER ;
  306.         BEGIN
  307.             B1 := 0 ;
  308.             FOR K := 1 TO 9 DO
  309.                 BEGIN
  310.                     Z5 := ( F5[ X ] DIV STARS[ K ] ) * STARS[ K ] ;
  311.                     IF Z5 = F5[ X ] THEN STARS[ K ] := (-STARS[ K ])
  312.                 END ;
  313.             FOR K := 1 TO 9 DO
  314.                     B1 := B1 +STARS[ K ] ;
  315.             CHECK := B1
  316.         END {---of CHECK---} ;
  317.  
  318.     {   --------------------   }
  319.  
  320.     PROCEDURE INPUT ;
  321.  
  322.       { GLOBAL
  323.             C, X  : INTEGER ;
  324.             STARS : VECTOR  ;  }
  325.  
  326.         VAR
  327.             CIX   : CHAR ;
  328.             ERROR : BOOLEAN ;
  329.             I     : INTEGER ;
  330.  
  331.         BEGIN
  332.             REPEAT
  333.                     ERROR := FALSE ;
  334.                     WRITE_STR('Your Shot ',1,11) ;
  335.                     KEYIN(CIX) ;
  336.                     IF CIX='0' THEN
  337.                             QUIT := TRUE
  338.                     ELSE
  339.                         BEGIN
  340.                             X := ( ORD(CIX) - ORD('0') ) ;
  341.                             WRITELN ;
  342.                             C := C + 1 ;
  343.                             IF (X<1) OR (X>9) THEN
  344.                                     ERROR := TRUE
  345.                             ELSE IF STARS[ X ] <= 0 THEN
  346.                                 BEGIN
  347.                                     BEEP ;
  348.                                     WRITE_STR('You can only Shoot Stars',1,12) ;
  349.                                     FOR I := 0 TO 16000 DO ; {DO NOTHING}
  350.                                     WRITE_STR('                        ',1,12) ;
  351.                                     ERROR := TRUE
  352.                                 END
  353.                         END
  354.             UNTIL NOT ERROR ;
  355.             WRITELN
  356.         END {---of INPUT---} ;
  357.  
  358.     {   --------------------   }
  359.  
  360. BEGIN  { PLAYTHEGAME }
  361.         ENDOFGAME := FALSE ;
  362.         QUIT := FALSE ;
  363.         REPEAT
  364.                 INPUT ;
  365.                 IF QUIT THEN
  366.                     BEGIN
  367.                         WRITELN ('GAME TERMINATED          ') ;
  368.                         ENDOFGAME := TRUE
  369.                     END
  370.                 ELSE
  371.                     BEGIN
  372.                         D := CHECK ;
  373.                         BOARD ;
  374.                         IF D = (-100) THEN
  375.                             BEGIN
  376.                                 WRITELN('You lost!!!') ;
  377.                                 ENDOFGAME := TRUE
  378.                             END
  379.                         ELSE IF D=96 THEN
  380.                             BEGIN
  381.                                 WRITELN('You WIN!!!') ;
  382.                                 WRITELN('You fired', C:3, ' shots') ;
  383.                                 ENDOFGAME := TRUE
  384.                             END
  385.                     END
  386.         UNTIL ENDOFGAME
  387.     END {---of PLAYTHEGAME---} ;
  388.  
  389. { -------------------- The main program -------------------- }
  390.  
  391. BEGIN { STARS }
  392.     DONE := FALSE ;
  393.     REPEAT
  394.             HEADING ;
  395.             SEEDRAND ; { Seed the Random Number Generator }
  396.             INITIALIZE ;
  397.             LOAD ;
  398.             BOARD ;
  399.             PLAYTHEGAME ;
  400.             CLREOS ;
  401.             WRITE_STR ('Would you like to play again?', 1, 13) ;
  402.             READ_BOOL (REPLY, 31, 13) ;
  403.             IF NOT REPLY THEN
  404.                     DONE := TRUE
  405.     UNTIL DONE
  406. END {---of STARS---}.
  407.           WRITELN('You lost!!!') ;
  408.                                 ENDOFGAME := TRUE
  409.                             END
  410.