PROGRAM animals;    {Requires Pascal/Z 3.3 or later, CP/M 2.2 or later}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* This program is Copyright (C) 1981 by                             *}
{*       Systems Engineering Associates                              *}
{*       124 West Blithedale Avenue                                  *}
{*       Mill Valley, California  94941                              *}
{*       (415) 982-7468                                              *}
{* This program may be copied and used by anyone wishing to do so,   *}
{* provided that the following conditions are respected:             *}
{*       (1) Neither this program, nor any portion or adaptation of  *}
{*           may be sold without the specific written permission of  *}
{*           Systems Engineering Associates.                         *}
{*       (2) The full text of this Copyright Notice must be          *}
{*           included in any presentation of the source program.     *}
{*       (3) The program code that prints the acknowledgement of     *}
{*           authorship must not be altered, disabled or bypassed.   *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    ack1     = 'This guessing and learning game program';
    ack1a    = ' was written by, and is copyrighted by,';
    ack2     = '    Roy P. Allen';
    ack3     = '    Systems Engineering Associates';
    ack4     = '    124 West Blithedale Avenue';
    ack5     = '    Mill Valley, California  94941  USA';
    ack6     = '    (415) 982-7468';

    filepfx  = 'BEASTS';
    inviter  = 'Would you like to play the animal guessing game';
    start1   = 'You think of an animal, and I''ll try to guess what it is.';
    start2   = 'When you''re ready to begin, press the <RETURN> key.';
    askagain = 'Would you like to play another round';
    maxlen   = 240;
    bufsize  = 256;
    maxx     = 128;                     {No. entries per XFILE block  }
{$L+}
TYPE
    questx   = 0..maxlen;               {Index to a question text     }
    bufx     = 1..bufsize;              {Index to a QFILE buffer      }
    dirx     = 1..maxx;                 {Index to an XFILE block      }
    recty    = (quest,ctl);
    qstring  = string maxlen;
    question = RECORD;                  {QUESTION logical record      }
        ident    : integer;             {Record number (1..MAXINT)    }
        typcode  : recty;               {Record type                  }
        CASE recty OF
            quest: (nextyes : integer;  {Next Q if answer = yes       }
                    nextno  : integer;  {Next Q if answer = no        }
                    query   : qstring); {Current question             }
            ctl  : (lastq   : integer;  {Last recno in QFILE          }
                    lastqbl : integer;  {Last QFILE block used        }
                    lastxbl : integer;  {Last XFILE block used        }
                    beastct : integer)  {No. animals known            }
        END; {question record}

    buffer   = packed array[bufx] of char;
    qrec     = RECORD;
        qentry   : buffer
        END; {qrec record}
    queryfile= file of qrec;

    xbuffr   = array[dirx] OF integer;
    xrec     = RECORD;
        xentry   : xbuffr
        END; {xrec record}
    directory= file of xrec;

    filestring = string 14;
    $string0   = string 0;
    $string255 = string 255;
    charset    = set of char;
{$L+}
VAR
    db       : text;        {Debugging output file                    }
    dbugging : boolean;     {Is debugging active?                     }
    moreokay : boolean;     {Indicator - keep playing?                }
    runabort : boolean;     {Indicator - fatal error has occurred     }
    zerochr  : char;        {One byte of binary zero                  }
    vowels   : charset;     {Set of all vowels                        }
    shiftup  : integer;     {Factor to shift from lower to upper case }
    replytxt : qstring;     {Text of a console reply                  }
    maxquery : integer;     {Maximum question number in file          }
    highblok : integer;     {Relative block# of last QFILE block      }
    highxblk : integer;     {Relative block# of last XFILE block      }
    maxanimals : integer;   {No. animals file now knows               }
    currblok   : integer;   {Relative block# - current QFILE block    }
    currxblk   : integer;   {Relative block# - current XFILE block    }
    qimage     : qrec;      {Current qfile block image                }
    ximage     : xrec;      {Current xfile block image                }
    currec     : question;  {Current question file record             }
    i          : integer;

    qfile      : queryfile; {Questions file                           }
    xfile      : directory; {Directory to Questions file              }


FUNCTION  length    (x: $string255):    integer;    EXTERNAL;
FUNCTION  index     (x, y: $string255): integer;    EXTERNAL;
PROCEDURE setlength (VAR x: $string0;  y: integer); EXTERNAL;
{$L+}
FUNCTION cnvrt (VAR arr: buffer;  pnt: bufx): integer;            {$C-}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given buffer ARR, with PNT pointing to the leftmost of a pair of  *}
{* entries in ARR, return the integer value of the two-byte pair     *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    maxint = 32767;

VAR
    i : integer;

BEGIN {cnvrt function}
    IF ord(arr[pnt])>127
        THEN BEGIN
                i := (256*(ord(arr[pnt]) mod 128)) + ord(arr[pnt+1]);
                cnvrt := i - maxint - 1
            END
        ELSE cnvrt := (256*ord(arr[pnt])) + ord(arr[pnt+1])
END; {cnvrt function}

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

PROCEDURE revert (VAR buff: buffer;  ptr: bufx;  x: integer);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given an integer X, store it as two bytes as location PTR in      *}
{* buffer BUFF.  This procedure complements function CNVRT.          *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

BEGIN {revert}
    buff[ptr]   := chr(x div 256);
    buff[ptr+1] := chr(x mod 256)
END; {revert procedure} {$L+}
PROCEDURE error (errnumbr: integer);

CONST
    set1 = 'I''ve just been told that error number ';
    set2 = ' (whatever THAT means) has occurred.';
    set3 = 'Ain''t that the pits?!!';
    intro    = 'FATAL PROGRAM OR FILE ERROR.  DESCRIPTION:';
    err1     = 'Invalid record number passed to GETRECORD procedure.';
    err2     = 'Invalid block pointer found in .QQX file.';
    err3     = 'Invalid block number passed to BLOKFETCH procedure.';
    err4     = 'APPENDSEG1 procedure invoked for a too-full block.';
    err5     = '.QQQ record not found where .QQX file says it should be.';
    unknown  = '(Undefined error code)';

VAR
    message  : string 75;

BEGIN {error procedure}
    writeln;
    writeln(set1, errnumbr:2, set2);
    writeln(set3);
    writeln;
    writeln(intro);
    IF errnumbr=1
            THEN message := err1
    ELSE IF errnumbr=2
            THEN message := err2
    ELSE IF errnumbr=3
            THEN message := err3
    ELSE IF errnumbr=4
            THEN message := err4
    ELSE IF errnumbr=5
            THEN message := err5
            ELSE message := unknown;
    writeln('    ',message);
    writeln;
    runabort := true
END; {error procedure} {$L+}
FUNCTION getyes: boolean;
{$Icopyseaf.inc }

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Secure from the console a reply of yes (y) or no (n).	     *}
{* Return "true" if yes, "false" otherwise.			     *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    suffix = '? (Y/N)  ';
    prompt = '     Please reply yes (Y) or no (N):  ';

VAR
    reply : string 10;
    ans	  : char;
    gotreply : boolean;

BEGIN {getyes function}
    write(suffix);
    gotreply := false;
    while gotreply= false do
	begin {while}
	    readln(reply);
	    gotreply := true;
	    ans := reply[1];
	    case ans of
		    'Y', 'y':	getyes := true;
		    'N', 'n':	getyes := false;
		    else:
			begin {else}
			    gotreply := false;
			    write(prompt)
			end   {else}
		end {case}
	end {while}
END;  {getyes function} {$L+}
PROCEDURE shiftxt (VAR arr: buffer;
                       org: bufx;
                       len: bufx;
                   VAR trg: qstring); {$C-}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Append a sequence of characters from ARR to TRG.  Transcription   *}
{* is of LEN consecutive bytes, beginning with byte ORG of ARR.      *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    i, j : integer;

BEGIN {shiftxt procedure}
    i := 1;
    j := org;
    WHILE i<=len DO
        BEGIN {while}
            append(trg,arr[j]);
            i := i + 1;
            j := j + 1
        END {while}
END; {shiftxt procedure} {$L+}
FUNCTION dirfetch (recno: integer): dirx;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given RECNO (logical record number of a desired QFILE record),    *}
{* return the XIMAGE.XENTRY entry number for that record.            *}
{*                                                                   *}
{* Side effects:                                                     *}
{*      highxblk - may be incremented +1                             *}
{*      currxblk - set to relative block# of current index block     *}
{*      ximage   - will contain the current index block              *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    xblkno   : integer;
    i        : dirx;

BEGIN {dirfetch function}
    xblkno := (recno div maxx) + 1;
    IF xblkno=(highxblk+1)
        THEN BEGIN
                currxblk := highxblk + 1;
                FOR i := 1 TO maxx DO
                    ximage.xentry[i] := 0;
                write(xfile:currxblk,ximage);
                highxblk := currxblk
            END; {then}
    IF xblkno>highxblk
        THEN BEGIN
                error(2);
                xblkno := -1
            END {then}
        ELSE BEGIN
                IF xblkno<>currxblk
                    THEN READ(xfile:xblkno,ximage);
                currxblk := xblkno
            END; {else}
    dirfetch := (recno mod maxx) + 1
END; {dirfetch function} {$L+}
PROCEDURE blokfetch (blokno: integer;
                 VAR buff  : qrec);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Fetch a specified relative QFILE block into a given buffer        *}
{*                                                                   *}
{* Side effects:                                                     *}
{*      highblok - may be incremented +1                             *}
{*      currblok - set to block# of current qfile block              *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    i : bufx;

BEGIN {blokfetch procedure}
    IF blokno=(highblok+1)
        THEN BEGIN
                currblok := blokno;
                FOR i := 1 TO bufsize DO
                    buff.qentry[i] := zerochr;
                write(qfile:currblok,buff);
                highblok := currblok
            END; {then}
    IF (blokno<1) OR (blokno>highblok)
        THEN error(3)
        ELSE BEGIN
                IF blokno<>currblok
                    THEN READ(qfile:blokno,buff);
                currblok := blokno
            END {else}
END; {blokfetch procedure} {$L+}
FUNCTION findrec (recno: integer;  buff : buffer):  bufx;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Return a pointer to the starting byte of a requested record       *}
{* number in a given buffer.                                         *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    i        : integer;
    found    : boolean;

BEGIN {findrec function}
    found := false;
    i := 1;
    WHILE ((i<(bufsize-3)) AND (buff[i]<>zerochr) AND (NOT found)) DO
        BEGIN {while}
            IF cnvrt(buff,i+2)=recno
                THEN found := true
                ELSE i := i + ord(buff[i])
         END; {while}
    IF NOT found
        THEN error(5);
    findrec := i
END; {findrec function} {$L+}
FUNCTION buildctl (VAR buff: qrec): question;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given BUFF, with control record image, return the equivalent      *}
{* control record.                                                   *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    equivalent : question;

BEGIN {buildctl function}
    WITH buff, equivalent DO
        BEGIN {with}
            lastq   := cnvrt(qentry,6);
            lastqbl := cnvrt(qentry,8);
            lastxbl := cnvrt(qentry,10);
            beastct := cnvrt(qentry,12)
        END; {with}
    buildctl := equivalent
END; {buildctl function} {$L+}
FUNCTION getrecord (recno  : integer): question;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Return from QFILE the RECNO record.                               *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    ptr      : bufx;
    xptr     : dirx;
    questn   : question;
{$L+}
FUNCTION buildquest (VAR buff: qrec;  pnt: bufx):  question;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Return the question-record that begins at position PNT of BUFF    *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    blokno     : integer;
    equivalent : question;

BEGIN {buildquest function}
    WITH equivalent, buff DO
        BEGIN {with}
            ident   := cnvrt(qentry,pnt+2);
            typcode := quest;
            nextyes := cnvrt(qentry,pnt+5);
            nextno  := cnvrt(qentry,pnt+7);
            setlength(query,0);
            shiftxt(qentry,pnt+9,ord(qentry[pnt])-9,query);
            IF ord(qentry[pnt+1])<>1
                THEN BEGIN
                        blokno := currblok + 1;
                        blokfetch(blokno,buff);
                        IF NOT runabort
                            THEN pnt := findrec(recno,qentry);
                        IF NOT runabort
                            THEN shiftxt(qentry,pnt+4,ord(qentry[pnt])-4,query)
                    END {then}
        END; {with}
    buildquest := equivalent
END; {buildquest function} {$L+}
BEGIN {getrecord function}
    IF ((recno<0) OR (recno>maxquery))
        THEN BEGIN
                writeln('INVALID RECORD NUMBER ',recno:1);
                error(1)
            END {then}
        ELSE WITH qimage, questn DO
                BEGIN {with}
                    xptr := dirfetch(recno);
                    IF NOT runabort
                       THEN blokfetch(ximage.xentry[xptr],qimage);
                    IF NOT runabort
                        THEN ptr := findrec(recno,qentry);
                    IF NOT runabort
                        THEN BEGIN
                                ident := recno;
                                IF qentry[ptr+4]=chr(ord(quest))
                                    THEN typcode := quest
                                    ELSE typcode := ctl;
                                CASE typcode OF
                                    quest: questn := buildquest(qimage,ptr);
                                    ctl  : questn := buildctl(qimage)
                                END {case}
                            END {then}
                END; {with and else}
    IF NOT runabort
        THEN getrecord := questn
END; {getrecord function} {$L+}
PROCEDURE reshift (VAR buff    : buffer;
                       tbyte   : bufx;
                       source  : qstring;
                       sbyte   : questx;
                       len     : questx);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Copy to BUFF, starting at TBYTE, LEN consecutive characters of    *}
{* SOURCE, starting at byte SBYTE.                                   *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    sptr     : questx;
    tptr     : integer;

BEGIN {reshift procedure}
    tptr := tbyte;
    FOR sptr := sbyte TO (sbyte+len-1) DO
        BEGIN {for}
            buff[tptr] := source[sptr];
            tptr := tptr + 1
        END {for}
END; {reshift procedure} {$L+}
PROCEDURE appendseg1 (txt      : qstring;
                      nyes, nno: integer;
                  VAR buff     : qrec;
                      ptr      : bufx);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* In BUFF at point PTR, build segment 1 of the logical record       *}
{* expressed by TXT, NYES, NNO.                                      *}
{*                                                                   *}
{* Side effects:                                                     *}
{*      maxquery - becomes the new record's record-ID.               *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

LABEL 1;

TYPE
    switcher = 0..1;

VAR
    avl      : bufx;
    need     : integer;
    shiftlen : integer;
    seglength: integer;
    lastind  : switcher;

BEGIN {appendseg1 procedure}
    need := length(txt) + 9;
    avl  := bufsize - ptr + 1;
    IF avl<9
        THEN BEGIN
                error(4);
                GOTO 1
            END;
    WITH buff DO
        BEGIN {with}
            IF avl<need
                THEN seglength := avl
                ELSE seglength := need;
            IF seglength=need
                THEN lastind := 1
                ELSE lastind := 0;
            qentry[ptr]   := chr(seglength);
            qentry[ptr+1] := chr(lastind);
            revert(qentry,ptr+2,maxquery+1);
            qentry[ptr+4] := chr(ord(quest));
            revert(qentry,ptr+5,nyes);
            revert(qentry,ptr+7,nno);
            IF avl<need
                THEN shiftlen := length(txt) - (need-avl)
                ELSE shiftlen := length(txt);
            reshift(qentry,ptr+9,txt,1,shiftlen)
        END; {with}
1:
END; {appendseg1 procedure} {$L+}
PROCEDURE addrecord (txt : qstring;
                     nyes, nno: integer);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given the three data elements of a question record, append that   *}
{* record to the question file.                                      *}
{*                                                                   *}
{* Side effects (updated as required):                               *}
{*      xfile                                                        *}
{*      highblok, highxblk, maxquery, maxanimals                     *}
{*      qfile file control record                                    *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

LABEL 1;

VAR
    newaddr  : integer;
    xptr     : dirx;
{$L+}
FUNCTION appendrec (txt  : qstring;
                     nyes, nno: integer): integer;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given the three data elements of a question record, append the    *}
{* record to QFILE, assigning it record number MAXQUERY+1.  Return   *}
{* block address.                                                    *}
{*                                                                   *}
{* Side effects:                                                     *}
{*      maxquery - used but not changed.                             *}
{*      highblok - may be incremented +1.                            *}
{*      currblok - equal to new highblok.                            *}
{*      qimage   - contains image of new highblok.                   *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

LABEL 1;

VAR
    objblok  : integer;
    i        : bufx;
    available: integer;
    required : bufx;
{$L+}
BEGIN {appendrec function}
    WITH qimage DO
        BEGIN {with}
            required := length(txt) + 9;
            available:= 0;
            objblok  := highblok - 1;
            WHILE available<9 DO
                BEGIN {while}
                    objblok   := objblok + 1;
                    blokfetch(objblok,qimage);
                    IF runabort
                        THEN GOTO 1;
                    i := 1;
                    WHILE ((i<bufsize) AND (qentry[i]<>zerochr)) DO
                        i := i + ord(qentry[i]);
                    available := bufsize - i + 1
                END; {while}
            appendseg1(txt,nyes,nno,qimage,i);
            IF runabort
                THEN GOTO 1;
            appendrec := objblok;
            write(qfile:objblok,qimage);
            IF qentry[i+1]<>chr(1)
                THEN BEGIN
                        objblok := objblok + 1;
                        blokfetch(objblok,qimage);
                        IF runabort
                            THEN GOTO 1;
                        qentry[1] := chr(required-available+4);
                        qentry[2] := chr(1);
                        revert(qentry,3,maxquery+1);
                        reshift(qentry,5,txt,available-8,required-available);
                        write(qfile:objblok,qimage)
                    END; {then}
1:      END {with}
END; {appendrec function} {$L+}
BEGIN {addrecord procedure}
    newaddr := appendrec(txt,nyes,nno);
    IF runabort
        THEN GOTO 1;
    xptr := dirfetch(maxquery+1);
    ximage.xentry[xptr] := newaddr;
    write(xfile:highxblk,ximage);

    IF ((nyes=0) AND (nno=0))
        THEN maxanimals := maxanimals + 1;
    maxquery := maxquery + 1;
    blokfetch(1,qimage);
    IF runabort
        THEN GOTO 1;
    revert(qimage.qentry, 6,maxquery);
    revert(qimage.qentry, 8,highblok);
    revert(qimage.qentry,10,highxblk);
    revert(qimage.qentry,12,maxanimals);
    write(qfile:1,qimage);
1:
END; {addrecord procedure} {$L+}
PROCEDURE initializefiles;

VAR
    qfilename : string 15;
    xfilename : string 15;
{$L+}
PROCEDURE newfile;

CONST
    firstquestion = 'Does it live in the water';
    yesguess      = 'octopus';
    noguess       = 'moose';

VAR
    i        : dirx;
    newq     : queryfile;
    newx     : directory;

BEGIN {newfile procedure}
    rewrite(qfilename,newq);
    rewrite(xfilename,newx);
    FOR i := 1 TO 4 DO
        ximage.xentry[i] := 1;          {First 4 records to block 1   }
    FOR i := 5 TO maxx DO
        ximage.xentry[i] := 0;
    write(newx,ximage);

    WITH qimage DO
        BEGIN {with}
            FOR i := 1 TO bufsize DO
                qentry[i] := zerochr;
            qentry[1]  := chr(13);      {Control record length is 13  }
            qentry[2]  := chr(1);       {This is last & only segment  }
            qentry[5]  := chr(ord(ctl));    {Identify as control rec  }
            qentry[7]  := chr(3);       {Highest question# is 3       }
            qentry[9]  := chr(1);       {Last question block used is 1}
            qentry[11] := chr(1);       {Last index block used is 1   }
            qentry[13] := chr(2);       {File contains 2 animals      }
        END; {with}
    i := 14;
    maxquery := 0;
    appendseg1(firstquestion,2,3,qimage,i);
    i := i + 9 + length(firstquestion);
    maxquery := 1;
    appendseg1(yesguess,0,0,qimage,i);
    i := i + 9 + length(yesguess);
    maxquery := 2;
    appendseg1(noguess,0,0,qimage,i);
    write(newq,qimage)
END; {newfile procedure} {$L+}
FUNCTION testexist:  boolean;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Test for existence of disk files QFILENAME and XFILENAME.         *}
{* Return FALSE if either one is missing, TRUE if both there.        *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    testxfile : directory;
    testqfile : queryfile;
    missing   : boolean;

BEGIN {testexist function}
    reset(qfilename,testqfile);
    reset(xfilename,testxfile);
    missing := (eof(testqfile) OR eof(testxfile));
    testexist := NOT missing
END; {testexist function} {$L+}
BEGIN {initializefiles procedure}
    qfilename := filepfx;
    append(qfilename,'.QQQ ');
    xfilename := filepfx;
    append(xfilename,'.QQX ');
    IF NOT testexist
        THEN newfile;

    reset(qfilename,qfile);
    reset(xfilename,xfile);
    currblok   := -1;
    currxblk   := -1;
    highblok   :=  1;
    highxblk   :=  1;
    maxquery   :=  3;
    maxanimals :=  2;

    read(xfile:1,ximage);
    currxblk := 1;
    read(qfile:1,qimage);
    currblok := 1;
    currec   := buildctl(qimage);
    maxquery   := currec.lastq;
    highblok   := currec.lastqbl;
    highxblk   := currec.lastxbl;
    maxanimals := currec.beastct
END; {initializefiles procedure} {$L+}
PROCEDURE guessing;

LABEL 1;

CONST
    bell      = 7;           {ordinal of ASCII code for terminal bell }
    boast     = 'How about that - - - I WON!';
    delay     = 8000;

VAR
    guesstime : boolean;
    success   : boolean;
    nextquest : integer;
    prevquest : integer;
    querytxt  : string maxlen+1;
    holdguess : qstring;
    i         : integer;
{$L+}
FUNCTION voweler (noun: qstring):  qstring;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given a noun, return a string with the correct choice of "a" or   *}
{* "an" preceding the noun.                                          *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    holder : qstring;

BEGIN {voweler function}
    IF noun[1] IN vowels
        THEN holder := ' an '
        ELSE holder := ' a ';
    append(holder,noun);
    voweler := holder
END; {voweler function}

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

PROCEDURE lowerize (VAR txt: qstring);

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* In a given string, change all upper-case letters to lower-case,   *}
{* unless it looks like the mix is intended.                         *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    i      : integer;
    letter : char;
    sloppy : boolean;

BEGIN {lowerize procedure}
    sloppy := true;
    FOR i := 1 TO 4 DO
        IF i<=length(txt)
            THEN IF txt[i] in ['a'..'z']
                    THEN sloppy := false;
    IF sloppy
        THEN FOR i := 1 TO length(txt) DO
                BEGIN {for}
                    letter := txt[i];
                    IF ((letter>='A') AND (letter<='Z'))
                        THEN txt[i] := chr(ord(letter)-shiftup)
                END {for}
END; {lowerize procedure} {$L+}
PROCEDURE askabout (qtext: qstring);

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Publish a given question.                                         *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    maxline  = 69;

VAR
    i, j     : questx;
    holder   : qstring;

BEGIN {askabout procedure}
    IF length(qtext)<=maxline
        THEN write(qtext)
        ELSE BEGIN
                i := maxline;
                WHILE (i>(maxline-20)) AND (qtext[i]<>' ') DO
                    i := i - 1;
                IF i>(maxline-20)
                    THEN BEGIN
                            setlength(holder,i-1);
                            FOR j := 1 to (i-1) DO
                                holder[j] := qtext[j];
                            writeln(holder);
                            holder := '    ';
                            FOR j := (i+1) TO length(qtext) DO
                                append(holder,qtext[j]);
                            write(holder)
                        END {else}
                    ELSE write(qtext)
            END {else}
END; {askabout procedure} {$L+}
PROCEDURE learning (oldguess  : qstring;
                    prevquest : integer);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given an old (wrong) guess (in the form "a fish" or "an egret",   *}
{* and the record number of the question that led to that guess,     *}
{* secure from the player the correct answer, and a yes-or-no        *}
{* question that would have led to it.  Insert the new question and  *}
{* and animal into the question file linkage.                        *}
{*                                                                   *}
{* Side effects:                                                     *}
{*      maxanimals - updated                                         *}
{*      I/O variables as required (see subordinate procedures)       *}
{*      currec (used to build new record & view old guess)           *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    humbler  = 'Oh!  I didn''t know about';
    request1 = 'I''d like to learn more about animals.';
    request2 = 'What''s a yes-or-no question to discriminate between';
    clarify1 = 'Which answer to that question would mean';
    clarify2 = ' - yes or no';
    thanks   = 'Thank you!  Now I know ';

VAR
    holdright  : qstring;
    rightbeast : qstring;
    newbeast   : boolean;
    newquery   : qstring;
    qhold      : qstring;




PROCEDURE depunctuate (VAR dtext: qstring);

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Trim off any terminating punctuation marks.                       *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    endset   = '.!?';

BEGIN {depunctuate procedure}
    WHILE index(endset,dtext[length(dtext)])<>0 DO
        setlength(dtext,length(dtext)-1)
END; {depunctuate procedure} {$L+}
FUNCTION getbeast: qstring;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Return the name of the animal the player had in mind.             *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    puzzled  = 'Really?  What sort of animal is it, then?';

VAR
    altered  : boolean;
    oldlen   : questx;
    holder   : qstring;

{$L+}
PROCEDURE markout (VAR btext: qstring;  word: qstring);

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Given a BTEXT, find any instances of WORD appearing as distinct   *}
{* words.  If there are any, eliminate from BTEXT all characters to  *}
{* and including WORD.                                               *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    blank1 = ' ';

VAR
    i, j     : questx;
    offset   : questx;
    padword  : qstring;
    padlen   : questx;

BEGIN {markout procedure}
    padword := word;
    append(padword,blank1);
    padlen  := length(padword);
    WHILE index(btext,padword)=1 DO
        BEGIN {while}
            setlength(btext,length(btext)-padlen);
            FOR i := 1 TO length(btext) DO
                btext[i] := btext[i+padlen];
            WHILE btext[1]=blank1 DO
                BEGIN {while}
                    setlength(btext,length(btext)-1);
                    FOR i := 1 TO length(btext) DO
                        btext[i] := btext[i+1]
                END {while}
        END; {while}
    padword := blank1;
    append(padword,word);
    append(padword,blank1);
    padlen := length(padword);
   j := index(btext,padword);
    WHILE j<>0 DO
        BEGIN {while}
            offset := j + padlen - 1;
            setlength(btext,length(btext)-offset);
            FOR i := 1 TO length(btext) DO
                 btext[i] := btext[offset+i];
            WHILE btext[1]=blank1 DO
                BEGIN {while}
                    setlength(btext,length(btext)-1);
                    FOR i := 1 TO length(btext) DO
                        btext[i] := btext[i+1]
                END; {while}
            j := index(btext,padword)
        END {while}
END; {markout procedure} {$L+}
BEGIN {getbeast function}
    writeln(puzzled);
    readln(holder);
    depunctuate(holder);
    lowerize(holder);
    oldlen := length(holder);
    altered := (holder[1]='A');
    IF altered
        THEN holder[1] := 'a';
    markout(holder,'a');
    markout(holder,'an');
    IF (altered AND (oldlen=length(holder)))
        THEN holder[1] := 'A';
    getbeast := holder
END; {getbeast function} {$L+}
PROCEDURE insertquestion (qstn : qstring;
                          ind  : boolean;
                          ytxt : qstring;
                          rec  : question;
                          prev : integer);
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* Insert a new question and guess into the question file, with      *}
{* all required linkages.  QUESTN is the new question, YTXT is the   *}
{* name of the new animal to be guessed.  If IND is true, then YTST  *}
{* is the guess for a YES answer, and the animal in REC for NO;      *}
{* otherwise, it's the other way around.  PREV is the question#      *}
{* that led to this question;  the new question is to be substituted *}
{* for REC in that question.                                         *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

LABEL 1;

VAR
    newqstnum : integer;
    newansnum : integer;
    oldansnum : integer;
    newyes    : integer;
    newno     : integer;
{$L+}
PROCEDURE amendrec (recno, nyes, nno: integer);

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* For a given question record, update the NEXTYES and NEXTNO ptrs.  *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

LABEL 1;

VAR
    blokno   : integer;
    xptr     : dirx;
    ptr      : bufx;

BEGIN {amendrec procedure}
    xptr := dirfetch(recno);
    IF runabort
        THEN GOTO 1;
    blokno := ximage.xentry[xptr];
    blokfetch(blokno,qimage);
    IF runabort
        THEN GOTO 1;
    ptr := findrec(recno,qimage.qentry);
    IF runabort
        THEN GOTO 1;
    revert(qimage.qentry,ptr+5,nyes);
    revert(qimage.qentry,ptr+7,nno);
    write(qfile:blokno,qimage);
1:
END; {amendrec procedure} {$L+}
BEGIN {insertquestion procedure}
    newqstnum := maxquery + 1;
    newansnum := maxquery + 2;
    oldansnum := rec.ident;
    IF ind
        THEN BEGIN
                newyes := newansnum;
                newno  := oldansnum
            END {then}
        ELSE BEGIN
                newyes := oldansnum;
                newno  := newansnum
            END; {else}
    addrecord(qstn,newyes,newno);
    IF runabort
        THEN GOTO 1;
    addrecord(ytxt,0,0);
    IF runabort
        THEN GOTO 1;
    rec := getrecord(prev);
    IF runabort
        THEN GOTO 1;
    IF rec.nextyes=oldansnum
        THEN rec.nextyes := newqstnum
        ELSE rec.nextno  := newqstnum;
    amendrec(prev,rec.nextyes,rec.nextno);
1:
END; {insertquestion procedure} {$L+}
BEGIN {learning procedure}
    rightbeast := getbeast;
    holdright  := voweler(rightbeast);
    writeln(humbler,holdright,'.');
    writeln(request1);
    qhold := request2;
    append(qhold,holdright);
    append(qhold,' and');
    append(qhold,oldguess);
    append(qhold,'?');
    askabout(qhold);
    writeln;
    readln(newquery);
    depunctuate(newquery);
    lowerize(newquery);
    IF ((newquery[1]>='a') AND (newquery[1]<='z'))
        THEN newquery[1] := chr(ord(newquery[1])+shiftup);
    qhold := clarify1;
    append(qhold,holdright);
    append(qhold,clarify2);
    askabout(qhold);
    IF getyes
        THEN newbeast := true
        ELSE newbeast := false;
    insertquestion(newquery,newbeast,rightbeast,currec,prevquest);
    IF NOT runabort
        THEN writeln(thanks,maxanimals:1,' animals.')
END; {learning procedure} {$L+}
BEGIN {guessing procedure} {$C+}
    guesstime := false;
    nextquest := 1;
    WITH currec DO
        BEGIN {with}
            WHILE NOT guesstime DO
                BEGIN {while}
                    currec := getrecord(nextquest);
                    IF runabort
                        THEN GOTO 1;
                    guesstime := (nextyes=0) AND (nextno=0);
                    IF NOT guesstime
                        THEN BEGIN
                                prevquest := ident;
                                askabout(query);
                                IF getyes
                                    THEN nextquest := nextyes
                                    ELSE nextquest := nextno
                            END {then}
                END; {while}
            querytxt  := 'Is it';
            holdguess := voweler(query);
            append(querytxt,holdguess);
            askabout(querytxt);
            IF getyes
                THEN BEGIN
                        writeln;
                        writeln(chr(bell),boast);
                        FOR i := 1 TO delay DO;
                    END {then}
                ELSE learning(holdguess,prevquest)
        END; {with}
1:
END; {guessing procedure} {$L+}
BEGIN {mainline procedure of program}
    runabort := false;
    zerochr  := chr(0);
    vowels   := ['A','E','I','O','U','a','e','i','o','u'];
    shiftup  := ord('A') - ord('a');
    FOR i := 1 TO 14 DO
        writeln;
    writeln(ack1,ack1a);
    writeln;
    writeln(ack2);
    writeln(ack3);
    writeln(ack4);
    writeln(ack5);
    writeln(ack6);
    writeln;
    writeln;
{   rewrite('LST: ',db);  }
{   dbugging := false;    }
    initializefiles;
    write(inviter);
    moreokay := getyes;
    WHILE moreokay DO
        BEGIN {while}
            writeln(start1);
            writeln(start2);
            readln(replytxt);
            guessing;
            IF runabort
                THEN moreokay := false
                ELSE BEGIN
                        writeln;
                        write(askagain);
                        moreokay := getyes
                    END {else}
        END; {while}
    IF runabort
        THEN writeln('TERMINATING DUE TO PROGRAM OR FILE ERROR')
        ELSE writeln('Okay!  Goodbye!')
END. {Animals program}