CP/M/CPM_CDROM.iso/enterprs/cpm/utils/s/tpaspgm.arc/STARS.PAS

Pascal/Delphi Source File | 1989-09-27 | 12.4 KB | 410 lines

PROGRAM STARS ;
{*
**  PROGRAM TITLE:       SHOOTING STARS
**
**  WRITTEN BY:          MARK J. BORGERSON
**  DATE WRITTEN:        July, 1976
**
**  WRITTEN FOR:         PERSONAL ENJOYMENT
**
**  TRANSLATED:          Translated from BASIC
**                       by Ray Penley, SEPT 1979
**                       16 April 80 - added KEYIN.
**
**  HISTORY:             Originally from Pascal/Z Users' Group
**                       CP/M Users' Group volume 71
**                       Modified for TURBO Pascal -- Wm Meacham, 6/2/84
**                       Further "User friendly" enhancements -- WPM, 6/5/84
*}

TYPE
    VECTOR = ARRAY[1..9] OF INTEGER ;
    STR80 = STRING[80] ;

VAR
    SEED1, SEED2    : INTEGER ;
    STARS, F5       : VECTOR ;
    C               : INTEGER ;
    DONE,REPLY      : BOOLEAN ;

{ -------------------- Screen handling routines -------------------- }

PROCEDURE KEYIN(VAR CIX : CHAR) ;
    BEGIN
        READ (KBD,CIX)                  { For TURBO Pascal -- WPM, 6/2/84}
    END ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE WRITE_STR (ST:STR80 ; COL,ROW:INTEGER) ;
    BEGIN
        GOTOXY (COL,ROW) ;
        WRITE (ST)
    END ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE PAUSE ;
    {Prints message on line 24, waits for user response}
    VAR CH : CHAR ;
    BEGIN
        WRITE_STR ('PRESS SPACE BAR TO CONTINUE',21,24) ;
        REPEAT
                KEYIN (CH)
        UNTIL CH = CHR($20) ;
        WRITE_STR ('                           ',21,24)
    END ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE READ_BOOL (VAR BOOL:BOOLEAN; COL,ROW:INTEGER) ;
  { Inputs "Y" OR "N" to boolean at row and column specified,
    prints "YES" or "NO"}

    VAR
        CH:CHAR ;

    BEGIN
        GOTOXY (COL, ROW) ;
        WRITE ('   ') ;
        GOTOXY (COL, ROW) ;
        REPEAT
                KEYIN (CH)
        UNTIL (CH IN ['Y', 'y', 'N', 'n']) ;
        IF (CH = 'Y') OR (CH = 'y') THEN
            BEGIN
                WRITE ('YES') ;
                BOOL := TRUE
            END
        ELSE
            BEGIN
                WRITE ('NO ') ;
                BOOL := FALSE
            END
    END ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE BEEP ;
    BEGIN
        WRITE (CHR(7))
    END ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

{ PROCEDURE CLRSCR ;
    Clear screen & home cursor -- Built-in TURBO procedure }

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE CLREOS ;
{         !!!  Device dependent routine !!!          }
    BEGIN
        WRITE ( CHR($17) )  {Clear to end of screen on Kaypro & ADM-3A}
    END ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE SKIP(LINES:INTEGER) ;
    VAR
        I : INTEGER ;
    BEGIN
        FOR I := 1 TO LINES DO WRITELN
    END {---of SKIP---} ;

{ -------------------- Routines for the game as such -------------------- }

PROCEDURE INSTRUCTIONS ;
    VAR
        I : INTEGER ;
    BEGIN
        CLRSCR ;
        WRITELN('If you like brain teasers then you''re in for some fun.') ;
        WRITELN('The object of this puzzle is to solve a 3 X 3 matrix such that') ;
        WRITELN('*s appear in all positions except in the center which will be ''.') ;
        WRITELN('The positions on the matrix board are referred to as follows:') ;
        WRITELN('      7   8   9') ;
        WRITELN('      4   5   6') ;
        WRITELN('      1   2   3    -- just like your numeric keypad.') ;
        WRITELN('When a * is made a '', its immediate neighbors change state,') ;
        WRITELN('that is: *s become ''s and vice versa.') ;
        WRITELN('In addition, changing a corner position also changes the center') ;
        WRITELN('position;  changing the center position also changes the outside') ;
        WRITELN('middle positions.') ;
        WRITELN ;
        WRITELN('You will be asked if you want to change the default initial board.') ;
        WRITELN('Answer "N" to get the same board each time you play.') ;
        WRITELN ;
        WRITELN('Type 0 to quit.  Have fun!') ;
        PAUSE ;
    END {---of INSTRUCTIONS---} ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE HEADING ;
    VAR
        ANS : BOOLEAN ;
    BEGIN
        CLRSCR ;
        WRITELN(' ':20, '***  SHOOTING STARS  ***') ;
        SKIP(2) ;
        WRITE ('Do you want instructions? (Y/N)') ;
        READ_BOOL (ANS, 33, 4) ;
        IF ANS THEN INSTRUCTIONS
    END {---of HEADING---} ;

(*============================================================*

   Procedures SEEDRAND and RANDM implement a Fibonacci series
   Random number generator.  Written for PASCAL/Z By Raymond E.
   Penley, September 1979.   Add these lines to your program --

       VAR  SEED1, SEED2 : INTEGER ;

   Within the body of the main program but
   BEFORE calling RANDM --

       SEEDRAND ;

 *============================================================*)

PROCEDURE SEEDRAND ;
{ Initial values for SEED1 and SEED2 may be input here  }
    VAR
        ANS : BOOLEAN ;
    BEGIN
        SEED1 := 10946 ;
        SEED2 := 17711 ;
        CLRSCR ;
        WRITE ('Do you want to change the default initial board? (Y/N)') ;
        READ_BOOL (ANS, 56, 1) ;
        IF ANS THEN
            BEGIN
                SEED1 := RANDOM (MAXINT) ;    {Built-in TURBO function}
                SEED2 := RANDOM (MAXINT)
            END
    END {--- of SEEDRAND ---} ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

FUNCTION RANDM : INTEGER ;

  { RANDM will return numbers from 0 to 32767.
    Call RANDM using the following convention:
         Range                 Use
          0 - 32        RANDM DIV 1000
          0 - 327        RANDM DIV 100
          0 - 32767        RANDM

    GLOBAL
        SEED1, SEED2 : INTEGER  }

    CONST
        HALFINT = 16383 ; { 1/2 OF MAXINT }
    VAR
        HALF1, HALF2, HALFADD : INTEGER ;

    BEGIN
        HALF1 := SEED1 DIV 2 ;
        HALF2 := SEED2 DIV 2 ;
        IF (HALF1+HALF2) >= HALFINT THEN
                HALFADD := HALF1 + HALF2 - HALFINT
        ELSE
                HALFADD := HALF1 + HALF2 ;
        SEED1 := SEED2 ;
        SEED2 := HALFADD * 2 ; { Restore from previous DIVision }
        RANDM := SEED2
    END {---of RANDM---} ;

(*============================================================*)

PROCEDURE INITIALIZE ;
    BEGIN
        CLRSCR ;
        C := 0 ;  { SHOT COUNTER }
        STARS[1] := (-23) ;       F5[1] := 1518 ;
        STARS[2] := (-3) ;        F5[2] := 1311 ;
        STARS[3] := (-19) ;       F5[3] := 570 ;
        STARS[4] := (-11) ;       F5[4] := 3289 ;
        STARS[5] :=    2 ;        F5[5] := 2310 ;
        STARS[6] := (-5) ;        F5[6] := 1615 ;
        STARS[7] := (-13) ;       F5[7] := 2002 ;
        STARS[8] := (-7) ;        F5[8] := 1547 ;
        STARS[9] := (-17) ;       F5[9] := 1190 ;
        WRITE_STR ('7        8        9', 21, 14) ;
        WRITE_STR ('4        5        6', 21, 17) ;
        WRITE_STR ('1        2        3', 21, 20) ;
        WRITE_STR ('0 - Quit', 21, 22)
    END {---of INITIALIZE---} ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE LOAD ;
    VAR
        I, X7 : INTEGER ;
    BEGIN
        FOR I := 1  TO 9 DO
            BEGIN
                X7 := ( RANDM DIV 100 ) ;
                IF X7 > 200 THEN STARS[I] := (-STARS[I])
            END
    END {---of LOAD---} ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE BOARD ;
    VAR
        J : INTEGER ;
    BEGIN
        GOTOXY (1,1) ;
        WRITE(' ':20) ;
        FOR J := 7 TO 9 DO
            BEGIN
                IF STARS[ J ] < 0 THEN WRITE( '''        ') ;
                IF STARS[ J ] > 0 THEN WRITE( '*        ')
            END ;
        SKIP(3) ;
        WRITE(' ':20) ;
        FOR J := 4 TO 6 DO
            BEGIN
                IF STARS[ J ] < 0 THEN WRITE( '''        ') ;
                IF STARS[ J ] > 0 THEN WRITE( '*        ')
            END ;
        SKIP(3) ;
        WRITE(' ':20) ;
        FOR J := 1 TO 3 DO
            BEGIN
                IF STARS[ J ] < 0 THEN WRITE( '''        ') ;
                IF STARS[ J ] > 0 THEN WRITE( '*        ')
            END ;
        SKIP(4)
    END {---of BOARD---} ;

{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }

PROCEDURE PLAYTHEGAME ;

    VAR
        D, X            : INTEGER ;
        ENDOFGAME, QUIT : BOOLEAN ;

    {   --------------------   }

    FUNCTION CHECK : INTEGER ;

      { Check to if the F value for the shot can be evenly
        divided by the stars value for each position. If the
        stars value divides into F without a remainder, the
        STAR or black hole is inverted (its sign is changed).

        GLOBAL
            X         : INTEGER ;
            STARS, F5 : VECTOR  ; }

        VAR
            B1, K, Z5 : INTEGER ;
        BEGIN
            B1 := 0 ;
            FOR K := 1 TO 9 DO
                BEGIN
                    Z5 := ( F5[ X ] DIV STARS[ K ] ) * STARS[ K ] ;
                    IF Z5 = F5[ X ] THEN STARS[ K ] := (-STARS[ K ])
                END ;
            FOR K := 1 TO 9 DO
                    B1 := B1 +STARS[ K ] ;
            CHECK := B1
        END {---of CHECK---} ;

    {   --------------------   }

    PROCEDURE INPUT ;

      { GLOBAL
            C, X  : INTEGER ;
            STARS : VECTOR  ;  }

        VAR
            CIX   : CHAR ;
            ERROR : BOOLEAN ;
            I     : INTEGER ;

        BEGIN
            REPEAT
                    ERROR := FALSE ;
                    WRITE_STR('Your Shot ',1,11) ;
                    KEYIN(CIX) ;
                    IF CIX='0' THEN
                            QUIT := TRUE
                    ELSE
                        BEGIN
                            X := ( ORD(CIX) - ORD('0') ) ;
                            WRITELN ;
                            C := C + 1 ;
                            IF (X<1) OR (X>9) THEN
                                    ERROR := TRUE
                            ELSE IF STARS[ X ] <= 0 THEN
                                BEGIN
                                    BEEP ;
                                    WRITE_STR('You can only Shoot Stars',1,12) ;
                                    FOR I := 0 TO 16000 DO ; {DO NOTHING}
                                    WRITE_STR('                        ',1,12) ;
                                    ERROR := TRUE
                                END
                        END
            UNTIL NOT ERROR ;
            WRITELN
        END {---of INPUT---} ;

    {   --------------------   }

BEGIN  { PLAYTHEGAME }
        ENDOFGAME := FALSE ;
        QUIT := FALSE ;
        REPEAT
                INPUT ;
                IF QUIT THEN
                    BEGIN
                        WRITELN ('GAME TERMINATED          ') ;
                        ENDOFGAME := TRUE
                    END
                ELSE
                    BEGIN
                        D := CHECK ;
                        BOARD ;
                        IF D = (-100) THEN
                            BEGIN
                                WRITELN('You lost!!!') ;
                                ENDOFGAME := TRUE
                            END
                        ELSE IF D=96 THEN
                            BEGIN
                                WRITELN('You WIN!!!') ;
                                WRITELN('You fired', C:3, ' shots') ;
                                ENDOFGAME := TRUE
                            END
                    END
        UNTIL ENDOFGAME
    END {---of PLAYTHEGAME---} ;

{ -------------------- The main program -------------------- }

BEGIN { STARS }
    DONE := FALSE ;
    REPEAT
            HEADING ;
            SEEDRAND ; { Seed the Random Number Generator }
            INITIALIZE ;
            LOAD ;
            BOARD ;
            PLAYTHEGAME ;
            CLREOS ;
            WRITE_STR ('Would you like to play again?', 1, 13) ;
            READ_BOOL (REPLY, 31, 13) ;
            IF NOT REPLY THEN
                    DONE := TRUE
    UNTIL DONE
END {---of STARS---}.
          WRITELN('You lost!!!') ;
                                ENDOFGAME := TRUE
                            END