Black Box 4/BlackBox.cdr/progbas/animals.arj/ANIMALS.BAS

BASIC Source File | 1991-09-29 | 12KB | 436 lines

' Program Name : ANIMALS
' Author       : Bill Buckels
' Date         : September 28, 1991
' Purpose      : A rewrite of the APPLESOFT ANIMALS PROGRAM
'                in QuickBASIC 4.5

'This is a classic program and really doesn't deserve to die.
'It wasn't a great game but is definitely reminiscent of a
'period of computing history that had its own ambience and charm.
'I hope that my rewrite hasn't mutated it beyond all recognition.

DIM MASK(8)                    ' a logical bitmask array

CONST FONTSEG = &HFFA6         ' romfont segment
CONST ROMFONT = &HE            ' romfont offset
CONST WHITESPACE = 32
CONST MONOCHROME = &HB000      ' address for the monochrome adapter
CONST CGA = &HB800             ' address for the cga
CONST BLACK = 0                ' color constants
CONST BLUE = 1
CONST RED = 4
CONST WHITE = 7
CONST LCYAN = 11
CONST BWHITE = 15


COMMON SHARED MASK(), SCREENSEG
DECLARE SUB FATFRAME (INSTRING$, FGR%, BGR%)
DECLARE SUB BIGLETTERS (INSTRING$, ROW%, FGR%, BGR%)
DECLARE SUB MIDPRINT (TXT$, RW%, CL%, FG%, BG%)

'CHECK FOR MONOCHROME DISPLAY


DEF SEG = MONOCHROME                  'clear the screen and
CLS                                   'try to read a whitespace
A = PEEK(0)                           'if it's not there assume
IF NOT A = WHITESPACE THEN
                SCREENSEG = CGA       'we have a color adapter
ELSE
     PRINT "Sorry... CGA Required."
     SYSTEM
END IF
DEF SEG

MASK(0) = &H80
MASK(1) = &H40
MASK(2) = &H20
MASK(3) = &H10
MASK(4) = &H8
MASK(5) = &H4
MASK(6) = &H2
MASK(7) = &H1
QT$ = CHR$(34)


COLOR BWHITE, BLUE
CLS

RESTORE TITLEDATA
        READ TXT$
        FATFRAME TXT$, WHITE, RED
        READ TXT$
        BIGLETTERS TXT$, 2, RED, WHITE
        ROW% = 11
        COL% = 39
        READ TXT$
        WHILE NOT TXT$ = "END OF TITLE"
              MIDPRINT TXT$, ROW%, COL%, BWHITE, BLUE
              ROW% = ROW% + 1
              READ TXT$
        WEND

RESTORE SONGDATA
        READ TXT$
        WHILE NOT TXT$ = "END OF SONG"
              PLAY TXT$
              READ TXT$
        WEND

  '=======================| INITIALIZATION SECTION |======================

  ON ERROR GOTO ERRORHANDLER
  WIDTH 40
  COLOR BWHITE, BLUE
  CLS
  MIDPRINT "DO YOU WANT INSTRUCTIONS ?(Y/N)", 12, 21, BWHITE, BLUE

  DONE = 0
  WHILE DONE = 0
    A$ = UCASE$(INPUT$(1))
    IF A$ = "Y" OR A$ = "N" OR A$ = CHR$(27) THEN DONE = 1
  WEND
  CLS

  IF A$ = CHR$(27) THEN
                  COLOR WHITE, BLACK
                  WIDTH 80
                  PRINT "Have a Nice Dos!"
                  SYSTEM
  END IF



  IF A$ = "N" THEN
              ROW% = 12
              COL% = 20
  ELSE
        RESTORE INSTRUCTIONS
        ROW% = 6
        COL% = 20
        READ TXT$
        WHILE NOT TXT$ = "END OF INSTRUCTIONS"
              MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
              ROW% = ROW% + 1
              READ TXT$
        WEND
  END IF


  MIDPRINT "DO YOU WANT TO DELETE OLD GAMES?", ROW%, COL%, BWHITE, BLUE
  ROW% = ROW% + 1
  MIDPRINT "ERASE ALL PREVIOUS ANIMALS (Y/N)", ROW%, COL%, BWHITE, BLUE
  DONE = 0
  WHILE DONE = 0
    A$ = UCASE$(INPUT$(1))
    IF A$ = "Y" OR A$ = "N" THEN DONE = 1
  WEND

  IF A$ = "Y" THEN
     OPEN "ANIMALS.LST" FOR OUTPUT AS #1
     PRINT #1, "DOES IT LIVE IN THE WATER"  'question
     PRINT #1, "Y"                          'response
     PRINT #1, "FROG"                       'match
     CLOSE #1
  END IF


DO
START:

  ON ERROR GOTO ERRORFILER
  OPEN "ANIMALS.LST" FOR INPUT AS #1
  ON ERROR GOTO ERRORHANDLER

  '======================| PLAY THE GAME |=====================


  CNT = 1

  WHILE NOT EOF(1)
    '================| step 1. get a question for a yes or no answer
    '================|         and the answer and the guess
    LINE INPUT #1, QUESTION$
    LINE INPUT #1, YESNO$
    LINE INPUT #1, ANI$
    CNT = CNT + 1

    '================| step 2. ask the question. get the response.
    CLS
    ROW% = 12
    TXT$ = QUESTION$ + " ?"
    MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
    DONE = 0
    WHILE DONE = 0
      A$ = UCASE$(INPUT$(1))
      IF A$ = "Y" OR A$ = "N" THEN DONE = 1
    WEND

    IF A$ = YESNO$ THEN

        '====| step 3. if it matches the measured response make a guess
        COLOR BWHITE, BLUE
        PRINT A$
        ROW% = ROW% + 1
        TXT$ = "ARE YOU THINKING OF A " + ANI$ + " ?"
        MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE

        DONE = 0
        WHILE DONE = 0
           A$ = UCASE$(INPUT$(1))
           IF A$ = "Y" OR A$ = "N" THEN DONE = 1
        WEND

        '===========| step 4. did we guess correctly |==================
        '===========|         if yes we did...       |==================
        IF A$ = "Y" THEN
          CLOSE #1
          CLS
          ROW% = 12
          MIDPRINT "I GOT IT RIGHT!!!", ROW%, COL%, BWHITE, BLUE
          ROW% = ROW% + 1
          MIDPRINT "WANT TO PLAY AGAIN ? (Y/N)", ROW%, COL%, BWHITE, BLUE
          DONE = 0
          WHILE DONE = 0
             A$ = UCASE$(INPUT$(1))
             IF A$ = "Y" OR A$ = "N" THEN DONE = 1
          WEND
          IF A$ = "N" THEN
                         COLOR WHITE, BLACK
                         WIDTH 80
                         PRINT "Have a Nice Dos!"
                         SYSTEM
          ELSE GOTO START
          END IF
        END IF
     END IF
  WEND
  CLOSE #1

  'If I Don't Know What The Animal is, I ask and update the data file

  '=================| step 1. get the new name |=====================
  CLS
  ROW% = 10
  TXT$ = "ALL RIGHT, I GIVE UP."
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  ROW% = ROW% + 1
  TXT$ = "WHAT ANIMAL ARE YOU THINKING OF ?"
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  COLOR BWHITE, BLUE
  A$ = ""
  WHILE LEN(A$) < 1
        LOCATE ROW% + 2, 1
        INPUT "", A$
  WEND
  NEW$ = UCASE$(LTRIM$(RTRIM$(A$)))


  '===============| step 2. get the new question |================
  CLS
  ROW% = 10
  TXT$ = "PLEASE TYPE A QUESTION THAT WOULD"
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  ROW% = ROW% + 1
  TXT$ = "DISTINGUISH BETWEEN A " + ANI$
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  ROW% = ROW% + 1
  TXT$ = "AND A " + NEW$ + "."
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  COLOR BWHITE, BLUE
  A$ = ""
  WHILE LEN(A$) < 1
        LOCATE ROW% + 2, 1
        INPUT "", A$
  WEND
  QUESTION$ = UCASE$(LTRIM$(RTRIM$(A$)))

  '===========| step 3. get the new answer |======================
  CLS
  ROW% = 12
  TXT$ = "WHAT IS THE Y or N ANSWER ?"
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  ROW% = ROW% + 1
  TXT$ = QT$ + QUESTION$ + " ?" + QT$
  MIDPRINT TXT$, ROW%, COL%, LCYAN, BLUE
  DONE = 0
  WHILE DONE = 0
             YESNO$ = UCASE$(INPUT$(1))
             IF YESNO$ = "Y" OR YESNO$ = "N" THEN DONE = 1
  WEND

  '===========| step 4. print the new record to file |============
  OPEN "ANIMALS.LST" FOR APPEND AS #1
  PRINT #1, QUESTION$
  PRINT #1, YESNO$
  PRINT #1, NEW$
  CLOSE #1

  '===========| step 5. find out if they want to play again |=====
  CLS
  ROW% = 10
  TXT$ = "I NOW KNOW" + STR$(CNT) + " ANIMALS!"
  MIDPRINT TXT$, ROW%, COL%, BWHITE, BLUE
  ROW% = ROW% + 2
  TXT$ = "WANT TO PLAY AGAIN ? (Y/N)"
  MIDPRINT TXT$, ROW%, COL%, BWHITE, BLUE
  DONE = 0
  WHILE DONE = 0
      A$ = UCASE$(INPUT$(1))
      IF A$ = "Y" OR A$ = "N" THEN DONE = 1
  WEND

LOOP UNTIL A$ = "N"
COLOR WHITE, BLACK
WIDTH 80
PRINT "Have a Nice Dos!"
SYSTEM



ERRORHANDLER:
     RESUME NEXT

ERRORFILER:

  'IF THE FILE IS NOT FOUND
  'CREATE A NEW DATA FILE

  OPEN "ANIMALS.LST" FOR OUTPUT AS #1
  PRINT #1, "DOES IT LIVE IN THE WATER"
  PRINT #1, "Y"
  PRINT #1, "FROG"
  CLOSE #1
  OPEN "ANIMALS.LST" FOR INPUT AS #1
  RESUME NEXT



TITLEDATA:

DATA "*"
DATA "ANIMALS"
DATA "A PROGRAM THAT LEARNS ABOUT VARIOUS ANIMALS FROM THE USER."
DATA "FIRST DRAFT 1978 BY APPLE COMPUTER INC.* UPDATED: OCTOBER 1983 BY WHS"
DATA "IBM-PC VERSION BY BILL BUCKELS 1991"
DATA ""
DATA "BASICALLY, THIS PROGRAM ILLUSTRATES THE USE OF A"
DATA "BINARY TREE STRUCTURE. SINCE THE ANSWER TO A QUESTION MUST"
DATA "EITHER BE A YES OR NO, WE  WILL TRAVERSE THE TREE EITHER"
DATA "LEFT OR RIGHT. IF WE DO NOT GUESS THE ANIMAL CORRECTLY,"
DATA "WE SIMPLY GET THE NEW ANIMAL  AND A QUESTION TO DISTINGUISH"
DATA "IT FROM OTHER ANIMALS, AND UPDATE THE TREE STRUCTURE."
DATA ""
DATA "ORIGINAL PROGRAM IDEA: WHO KNOWS?"
DATA "END OF TITLE"

SONGDATA:

'The Song "Animal Fair"
  DATA "mbmsO3T140"
  DATA "e12g12g16g12a6f12g4p8"
  DATA "e12g12g16g12a6g12f4p8"
  DATA "g12b12b16b12b6"
  DATA "g12b12b16b12b6"
  DATA "a12g12g16g12a6f12g4p8"

  DATA "e12g12g16g12a6f12g4p8"
  DATA "e12g12g16g12a6g12f4p8"
  DATA "g12b12b16b12b6"
  DATA "g12b12b16b12b6"
  DATA "a12g12g16g12a6b12>c4<p8"
  DATA "END OF SONG"

INSTRUCTIONS:

  DATA "*INSTRUCTIONS*"
  DATA ""
  DATA "YOU WILL THINK OF AN ANIMAL, AND I WILL"
  DATA "TRY TO GUESS WHAT ANIMAL YOU ARE"
  DATA "THINKING OF.  I WILL DO THIS BY ASKING"
  DATA "YOU A SERIES OF QUESTIONS ABOUT YOUR"
  DATA "ANIMAL, TO WHICH YOU RESPOND EITHER"
  DATA "Y OR N."
  DATA ""
  DATA "IF I DO NOT GUESS WHAT YOUR ANIMAL IS,"
  DATA "I WILL ASK YOU A FEW QUESTIONS SO THAT"
  DATA "NEXT TIME I WILL KNOW YOUR ANIMAL."
  DATA ""
  DATA "END OF INSTRUCTIONS"

SUB BIGLETTERS (INSTRING$, ROW%, FGR%, BGR%) STATIC

     DEF SEG = FONTSEG
     TARGET = LEN(INSTRING$)

     ATTR = BGR% * 2 ^ 4 + FGR%
     '
     LINEBASE = ROW% * 160 + 80 - (TARGET * 8) 'midscreen

     FOR SCANLINE = 0 TO 7              'loop for each scanline
       ROW% = LINEBASE + (SCANLINE * 160)
                                        'offset into the framebuffer
      FOR BYTE = 1 TO TARGET            'write one full scanline

        SEED = ASC(MID$(INSTRING$, BYTE, 1))'use the ascii value for the key
        OFFSET = (SEED * 8) + SCANLINE  'by bytes per char + scanlines
        CHAR = PEEK(ROMFONT + OFFSET)   'get the template from the rom

        DEF SEG = SCREENSEG             'point to the framebuffer
        COL = ROW% + ((BYTE - 1) * 16)  'add char position to the offset
        ATT = COL + 1                   'the attribute for the char

      FOR NIBBLE = 0 TO 7               'nibble the bits, lite if lit
        IF (CHAR AND MASK(NIBBLE)) THEN POKE COL, SEED: POKE ATT, ATTR
        COL = COL + 2                   'increment for chars
        ATT = ATT + 2                   'increment for attributes
      NEXT NIBBLE

      DEF SEG = FONTSEG                 'point to the font
      NEXT BYTE                        'get another
     NEXT SCANLINE
     DEF SEG
END SUB

SUB FATFRAME (INSTRING$, FGR%, BGR%) STATIC
     'a fat frame routine

     CHAR = ASC(LEFT$(INSTRING$, 1))
     ATTR = BGR% * 2 ^ 4 + FGR%
     DEF SEG = SCREENSEG

     'top of box
     FOR OFFSET = 0 TO 159
                POKE OFFSET, CHAR
                OFFSET = OFFSET + 1
                POKE OFFSET, ATTR
     NEXT OFFSET

     'middle of box
     FOR LINES = 1 TO 23
                 OFFSET = LINES * 160
                 POKE OFFSET, CHAR
                 POKE OFFSET + 1, ATTR
                 POKE OFFSET + 158, CHAR
                 POKE OFFSET + 159, ATTR
     NEXT LINES

     'bottom of box
     OFFSET = 24 * 160
     WHILE NOT OFFSET = 4000
            POKE OFFSET, CHAR
            POKE OFFSET + 1, ATTR
            OFFSET = OFFSET + 2
     WEND

     DEF SEG
END SUB

SUB MIDPRINT (TXT$, RW%, CL%, FGC%, BGC%) STATIC
     LOCATE RW%, (CL% + 1) - (LEN(TXT$) / 2)
     COLOR FGC%, BGC%
     PRINT TXT$;
END SUB