home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol069 / animals.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  39KB  |  1,088 lines
  1. PROGRAM animals;    {Requires Pascal/Z 3.3 or later, CP/M 2.2 or later}
  2.  
  3. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  4. {* This program is Copyright (C) 1981 by                             *}
  5. {*       Systems Engineering Associates                              *}
  6. {*       124 West Blithedale Avenue                                  *}
  7. {*       Mill Valley, California  94941                              *}
  8. {*       (415) 982-7468                                              *}
  9. {* This program may be copied and used by anyone wishing to do so,   *}
  10. {* provided that the following conditions are respected:             *}
  11. {*       (1) Neither this program, nor any portion or adaptation of  *}
  12. {*           may be sold without the specific written permission of  *}
  13. {*           Systems Engineering Associates.                         *}
  14. {*       (2) The full text of this Copyright Notice must be          *}
  15. {*           included in any presentation of the source program.     *}
  16. {*       (3) The program code that prints the acknowledgement of     *}
  17. {*           authorship must not be altered, disabled or bypassed.   *}
  18. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  19.  
  20. CONST
  21.     ack1     = 'This guessing and learning game program';
  22.     ack1a    = ' was written by, and is copyrighted by,';
  23.     ack2     = '    Roy P. Allen';
  24.     ack3     = '    Systems Engineering Associates';
  25.     ack4     = '    124 West Blithedale Avenue';
  26.     ack5     = '    Mill Valley, California  94941  USA';
  27.     ack6     = '    (415) 982-7468';
  28.  
  29.     filepfx  = 'BEASTS';
  30.     inviter  = 'Would you like to play the animal guessing game';
  31.     start1   = 'You think of an animal, and I''ll try to guess what it is.';
  32.     start2   = 'When you''re ready to begin, press the <RETURN> key.';
  33.     askagain = 'Would you like to play another round';
  34.     maxlen   = 240;
  35.     bufsize  = 256;
  36.     maxx     = 128;                     {No. entries per XFILE block  }
  37. {$L+}
  38. TYPE
  39.     questx   = 0..maxlen;               {Index to a question text     }
  40.     bufx     = 1..bufsize;              {Index to a QFILE buffer      }
  41.     dirx     = 1..maxx;                 {Index to an XFILE block      }
  42.     recty    = (quest,ctl);
  43.     qstring  = string maxlen;
  44.     question = RECORD;                  {QUESTION logical record      }
  45.         ident    : integer;             {Record number (1..MAXINT)    }
  46.         typcode  : recty;               {Record type                  }
  47.         CASE recty OF
  48.             quest: (nextyes : integer;  {Next Q if answer = yes       }
  49.                     nextno  : integer;  {Next Q if answer = no        }
  50.                     query   : qstring); {Current question             }
  51.             ctl  : (lastq   : integer;  {Last recno in QFILE          }
  52.                     lastqbl : integer;  {Last QFILE block used        }
  53.                     lastxbl : integer;  {Last XFILE block used        }
  54.                     beastct : integer)  {No. animals known            }
  55.         END; {question record}
  56.  
  57.     buffer   = packed array[bufx] of char;
  58.     qrec     = RECORD;
  59.         qentry   : buffer
  60.         END; {qrec record}
  61.     queryfile= file of qrec;
  62.  
  63.     xbuffr   = array[dirx] OF integer;
  64.     xrec     = RECORD;
  65.         xentry   : xbuffr
  66.         END; {xrec record}
  67.     directory= file of xrec;
  68.  
  69.     filestring = string 14;
  70.     $string0   = string 0;
  71.     $string255 = string 255;
  72.     charset    = set of char;
  73. {$L+}
  74. VAR
  75.     db       : text;        {Debugging output file                    }
  76.     dbugging : boolean;     {Is debugging active?                     }
  77.     moreokay : boolean;     {Indicator - keep playing?                }
  78.     runabort : boolean;     {Indicator - fatal error has occurred     }
  79.     zerochr  : char;        {One byte of binary zero                  }
  80.     vowels   : charset;     {Set of all vowels                        }
  81.     shiftup  : integer;     {Factor to shift from lower to upper case }
  82.     replytxt : qstring;     {Text of a console reply                  }
  83.     maxquery : integer;     {Maximum question number in file          }
  84.     highblok : integer;     {Relative block# of last QFILE block      }
  85.     highxblk : integer;     {Relative block# of last XFILE block      }
  86.     maxanimals : integer;   {No. animals file now knows               }
  87.     currblok   : integer;   {Relative block# - current QFILE block    }
  88.     currxblk   : integer;   {Relative block# - current XFILE block    }
  89.     qimage     : qrec;      {Current qfile block image                }
  90.     ximage     : xrec;      {Current xfile block image                }
  91.     currec     : question;  {Current question file record             }
  92.     i          : integer;
  93.  
  94.     qfile      : queryfile; {Questions file                           }
  95.     xfile      : directory; {Directory to Questions file              }
  96.  
  97.  
  98. FUNCTION  length    (x: $string255):    integer;    EXTERNAL;
  99. FUNCTION  index     (x, y: $string255): integer;    EXTERNAL;
  100. PROCEDURE setlength (VAR x: $string0;  y: integer); EXTERNAL;
  101. {$L+}
  102. FUNCTION cnvrt (VAR arr: buffer;  pnt: bufx): integer;            {$C-}
  103.  
  104. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  105. {* Given buffer ARR, with PNT pointing to the leftmost of a pair of  *}
  106. {* entries in ARR, return the integer value of the two-byte pair     *}
  107. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  108.  
  109. CONST
  110.     maxint = 32767;
  111.  
  112. VAR
  113.     i : integer;
  114.  
  115. BEGIN {cnvrt function}
  116.     IF ord(arr[pnt])>127
  117.         THEN BEGIN
  118.                 i := (256*(ord(arr[pnt]) mod 128)) + ord(arr[pnt+1]);
  119.                 cnvrt := i - maxint - 1
  120.             END
  121.         ELSE cnvrt := (256*ord(arr[pnt])) + ord(arr[pnt+1])
  122. END; {cnvrt function}
  123.  
  124. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  125.  
  126. PROCEDURE revert (VAR buff: buffer;  ptr: bufx;  x: integer);
  127. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  128. {* Given an integer X, store it as two bytes as location PTR in      *}
  129. {* buffer BUFF.  This procedure complements function CNVRT.          *}
  130. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  131.  
  132. BEGIN {revert}
  133.     buff[ptr]   := chr(x div 256);
  134.     buff[ptr+1] := chr(x mod 256)
  135. END; {revert procedure} {$L+}
  136. PROCEDURE error (errnumbr: integer);
  137.  
  138. CONST
  139.     set1 = 'I''ve just been told that error number ';
  140.     set2 = ' (whatever THAT means) has occurred.';
  141.     set3 = 'Ain''t that the pits?!!';
  142.     intro    = 'FATAL PROGRAM OR FILE ERROR.  DESCRIPTION:';
  143.     err1     = 'Invalid record number passed to GETRECORD procedure.';
  144.     err2     = 'Invalid block pointer found in .QQX file.';
  145.     err3     = 'Invalid block number passed to BLOKFETCH procedure.';
  146.     err4     = 'APPENDSEG1 procedure invoked for a too-full block.';
  147.     err5     = '.QQQ record not found where .QQX file says it should be.';
  148.     unknown  = '(Undefined error code)';
  149.  
  150. VAR
  151.     message  : string 75;
  152.  
  153. BEGIN {error procedure}
  154.     writeln;
  155.     writeln(set1, errnumbr:2, set2);
  156.     writeln(set3);
  157.     writeln;
  158.     writeln(intro);
  159.     IF errnumbr=1
  160.             THEN message := err1
  161.     ELSE IF errnumbr=2
  162.             THEN message := err2
  163.     ELSE IF errnumbr=3
  164.             THEN message := err3
  165.     ELSE IF errnumbr=4
  166.             THEN message := err4
  167.     ELSE IF errnumbr=5
  168.             THEN message := err5
  169.             ELSE message := unknown;
  170.     writeln('    ',message);
  171.     writeln;
  172.     runabort := true
  173. END; {error procedure} {$L+}
  174. FUNCTION getyes: boolean;
  175. {$Icopyseaf.inc }
  176.  
  177. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  178. {* Secure from the console a reply of yes (y) or no (n).         *}
  179. {* Return "true" if yes, "false" otherwise.                 *}
  180. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  181.  
  182. CONST
  183.     suffix = '? (Y/N)  ';
  184.     prompt = '     Please reply yes (Y) or no (N):  ';
  185.  
  186. VAR
  187.     reply : string 10;
  188.     ans      : char;
  189.     gotreply : boolean;
  190.  
  191. BEGIN {getyes function}
  192.     write(suffix);
  193.     gotreply := false;
  194.     while gotreply= false do
  195.     begin {while}
  196.         readln(reply);
  197.         gotreply := true;
  198.         ans := reply[1];
  199.         case ans of
  200.             'Y', 'y':    getyes := true;
  201.             'N', 'n':    getyes := false;
  202.             else:
  203.             begin {else}
  204.                 gotreply := false;
  205.                 write(prompt)
  206.             end   {else}
  207.         end {case}
  208.     end {while}
  209. END;  {getyes function} {$L+}
  210. PROCEDURE shiftxt (VAR arr: buffer;
  211.                        org: bufx;
  212.                        len: bufx;
  213.                    VAR trg: qstring); {$C-}
  214. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  215. {* Append a sequence of characters from ARR to TRG.  Transcription   *}
  216. {* is of LEN consecutive bytes, beginning with byte ORG of ARR.      *}
  217. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  218.  
  219. VAR
  220.     i, j : integer;
  221.  
  222. BEGIN {shiftxt procedure}
  223.     i := 1;
  224.     j := org;
  225.     WHILE i<=len DO
  226.         BEGIN {while}
  227.             append(trg,arr[j]);
  228.             i := i + 1;
  229.             j := j + 1
  230.         END {while}
  231. END; {shiftxt procedure} {$L+}
  232. FUNCTION dirfetch (recno: integer): dirx;
  233. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  234. {* Given RECNO (logical record number of a desired QFILE record),    *}
  235. {* return the XIMAGE.XENTRY entry number for that record.            *}
  236. {*                                                                   *}
  237. {* Side effects:                                                     *}
  238. {*      highxblk - may be incremented +1                             *}
  239. {*      currxblk - set to relative block# of current index block     *}
  240. {*      ximage   - will contain the current index block              *}
  241. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  242.  
  243. VAR
  244.     xblkno   : integer;
  245.     i        : dirx;
  246.  
  247. BEGIN {dirfetch function}
  248.     xblkno := (recno div maxx) + 1;
  249.     IF xblkno=(highxblk+1)
  250.         THEN BEGIN
  251.                 currxblk := highxblk + 1;
  252.                 FOR i := 1 TO maxx DO
  253.                     ximage.xentry[i] := 0;
  254.                 write(xfile:currxblk,ximage);
  255.                 highxblk := currxblk
  256.             END; {then}
  257.     IF xblkno>highxblk
  258.         THEN BEGIN
  259.                 error(2);
  260.                 xblkno := -1
  261.             END {then}
  262.         ELSE BEGIN
  263.                 IF xblkno<>currxblk
  264.                     THEN READ(xfile:xblkno,ximage);
  265.                 currxblk := xblkno
  266.             END; {else}
  267.     dirfetch := (recno mod maxx) + 1
  268. END; {dirfetch function} {$L+}
  269. PROCEDURE blokfetch (blokno: integer;
  270.                  VAR buff  : qrec);
  271. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  272. {* Fetch a specified relative QFILE block into a given buffer        *}
  273. {*                                                                   *}
  274. {* Side effects:                                                     *}
  275. {*      highblok - may be incremented +1                             *}
  276. {*      currblok - set to block# of current qfile block              *}
  277. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  278.  
  279. VAR
  280.     i : bufx;
  281.  
  282. BEGIN {blokfetch procedure}
  283.     IF blokno=(highblok+1)
  284.         THEN BEGIN
  285.                 currblok := blokno;
  286.                 FOR i := 1 TO bufsize DO
  287.                     buff.qentry[i] := zerochr;
  288.                 write(qfile:currblok,buff);
  289.                 highblok := currblok
  290.             END; {then}
  291.     IF (blokno<1) OR (blokno>highblok)
  292.         THEN error(3)
  293.         ELSE BEGIN
  294.                 IF blokno<>currblok
  295.                     THEN READ(qfile:blokno,buff);
  296.                 currblok := blokno
  297.             END {else}
  298. END; {blokfetch procedure} {$L+}
  299. FUNCTION findrec (recno: integer;  buff : buffer):  bufx;
  300.  
  301. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  302. {* Return a pointer to the starting byte of a requested record       *}
  303. {* number in a given buffer.                                         *}
  304. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  305.  
  306. VAR
  307.     i        : integer;
  308.     found    : boolean;
  309.  
  310. BEGIN {findrec function}
  311.     found := false;
  312.     i := 1;
  313.     WHILE ((i<(bufsize-3)) AND (buff[i]<>zerochr) AND (NOT found)) DO
  314.         BEGIN {while}
  315.             IF cnvrt(buff,i+2)=recno
  316.                 THEN found := true
  317.                 ELSE i := i + ord(buff[i])
  318.          END; {while}
  319.     IF NOT found
  320.         THEN error(5);
  321.     findrec := i
  322. END; {findrec function} {$L+}
  323. FUNCTION buildctl (VAR buff: qrec): question;
  324.  
  325. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  326. {* Given BUFF, with control record image, return the equivalent      *}
  327. {* control record.                                                   *}
  328. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  329.  
  330. VAR
  331.     equivalent : question;
  332.  
  333. BEGIN {buildctl function}
  334.     WITH buff, equivalent DO
  335.         BEGIN {with}
  336.             lastq   := cnvrt(qentry,6);
  337.             lastqbl := cnvrt(qentry,8);
  338.             lastxbl := cnvrt(qentry,10);
  339.             beastct := cnvrt(qentry,12)
  340.         END; {with}
  341.     buildctl := equivalent
  342. END; {buildctl function} {$L+}
  343. FUNCTION getrecord (recno  : integer): question;
  344.  
  345. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  346. {* Return from QFILE the RECNO record.                               *}
  347. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  348.  
  349. VAR
  350.     ptr      : bufx;
  351.     xptr     : dirx;
  352.     questn   : question;
  353. {$L+}
  354. FUNCTION buildquest (VAR buff: qrec;  pnt: bufx):  question;
  355.  
  356. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  357. {* Return the question-record that begins at position PNT of BUFF    *}
  358. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  359.  
  360. VAR
  361.     blokno     : integer;
  362.     equivalent : question;
  363.  
  364. BEGIN {buildquest function}
  365.     WITH equivalent, buff DO
  366.         BEGIN {with}
  367.             ident   := cnvrt(qentry,pnt+2);
  368.             typcode := quest;
  369.             nextyes := cnvrt(qentry,pnt+5);
  370.             nextno  := cnvrt(qentry,pnt+7);
  371.             setlength(query,0);
  372.             shiftxt(qentry,pnt+9,ord(qentry[pnt])-9,query);
  373.             IF ord(qentry[pnt+1])<>1
  374.                 THEN BEGIN
  375.                         blokno := currblok + 1;
  376.                         blokfetch(blokno,buff);
  377.                         IF NOT runabort
  378.                             THEN pnt := findrec(recno,qentry);
  379.                         IF NOT runabort
  380.                             THEN shiftxt(qentry,pnt+4,ord(qentry[pnt])-4,query)
  381.                     END {then}
  382.         END; {with}
  383.     buildquest := equivalent
  384. END; {buildquest function} {$L+}
  385. BEGIN {getrecord function}
  386.     IF ((recno<0) OR (recno>maxquery))
  387.         THEN BEGIN
  388.                 writeln('INVALID RECORD NUMBER ',recno:1);
  389.                 error(1)
  390.             END {then}
  391.         ELSE WITH qimage, questn DO
  392.                 BEGIN {with}
  393.                     xptr := dirfetch(recno);
  394.                     IF NOT runabort
  395.                        THEN blokfetch(ximage.xentry[xptr],qimage);
  396.                     IF NOT runabort
  397.                         THEN ptr := findrec(recno,qentry);
  398.                     IF NOT runabort
  399.                         THEN BEGIN
  400.                                 ident := recno;
  401.                                 IF qentry[ptr+4]=chr(ord(quest))
  402.                                     THEN typcode := quest
  403.                                     ELSE typcode := ctl;
  404.                                 CASE typcode OF
  405.                                     quest: questn := buildquest(qimage,ptr);
  406.                                     ctl  : questn := buildctl(qimage)
  407.                                 END {case}
  408.                             END {then}
  409.                 END; {with and else}
  410.     IF NOT runabort
  411.         THEN getrecord := questn
  412. END; {getrecord function} {$L+}
  413. PROCEDURE reshift (VAR buff    : buffer;
  414.                        tbyte   : bufx;
  415.                        source  : qstring;
  416.                        sbyte   : questx;
  417.                        len     : questx);
  418. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  419. {* Copy to BUFF, starting at TBYTE, LEN consecutive characters of    *}
  420. {* SOURCE, starting at byte SBYTE.                                   *}
  421. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  422.  
  423. VAR
  424.     sptr     : questx;
  425.     tptr     : integer;
  426.  
  427. BEGIN {reshift procedure}
  428.     tptr := tbyte;
  429.     FOR sptr := sbyte TO (sbyte+len-1) DO
  430.         BEGIN {for}
  431.             buff[tptr] := source[sptr];
  432.             tptr := tptr + 1
  433.         END {for}
  434. END; {reshift procedure} {$L+}
  435. PROCEDURE appendseg1 (txt      : qstring;
  436.                       nyes, nno: integer;
  437.                   VAR buff     : qrec;
  438.                       ptr      : bufx);
  439. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  440. {* In BUFF at point PTR, build segment 1 of the logical record       *}
  441. {* expressed by TXT, NYES, NNO.                                      *}
  442. {*                                                                   *}
  443. {* Side effects:                                                     *}
  444. {*      maxquery - becomes the new record's record-ID.               *}
  445. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  446.  
  447. LABEL 1;
  448.  
  449. TYPE
  450.     switcher = 0..1;
  451.  
  452. VAR
  453.     avl      : bufx;
  454.     need     : integer;
  455.     shiftlen : integer;
  456.     seglength: integer;
  457.     lastind  : switcher;
  458.  
  459. BEGIN {appendseg1 procedure}
  460.     need := length(txt) + 9;
  461.     avl  := bufsize - ptr + 1;
  462.     IF avl<9
  463.         THEN BEGIN
  464.                 error(4);
  465.                 GOTO 1
  466.             END;
  467.     WITH buff DO
  468.         BEGIN {with}
  469.             IF avl<need
  470.                 THEN seglength := avl
  471.                 ELSE seglength := need;
  472.             IF seglength=need
  473.                 THEN lastind := 1
  474.                 ELSE lastind := 0;
  475.             qentry[ptr]   := chr(seglength);
  476.             qentry[ptr+1] := chr(lastind);
  477.             revert(qentry,ptr+2,maxquery+1);
  478.             qentry[ptr+4] := chr(ord(quest));
  479.             revert(qentry,ptr+5,nyes);
  480.             revert(qentry,ptr+7,nno);
  481.             IF avl<need
  482.                 THEN shiftlen := length(txt) - (need-avl)
  483.                 ELSE shiftlen := length(txt);
  484.             reshift(qentry,ptr+9,txt,1,shiftlen)
  485.         END; {with}
  486. 1:
  487. END; {appendseg1 procedure} {$L+}
  488. PROCEDURE addrecord (txt : qstring;
  489.                      nyes, nno: integer);
  490. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  491. {* Given the three data elements of a question record, append that   *}
  492. {* record to the question file.                                      *}
  493. {*                                                                   *}
  494. {* Side effects (updated as required):                               *}
  495. {*      xfile                                                        *}
  496. {*      highblok, highxblk, maxquery, maxanimals                     *}
  497. {*      qfile file control record                                    *}
  498. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  499.  
  500. LABEL 1;
  501.  
  502. VAR
  503.     newaddr  : integer;
  504.     xptr     : dirx;
  505. {$L+}
  506. FUNCTION appendrec (txt  : qstring;
  507.                      nyes, nno: integer): integer;
  508. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  509. {* Given the three data elements of a question record, append the    *}
  510. {* record to QFILE, assigning it record number MAXQUERY+1.  Return   *}
  511. {* block address.                                                    *}
  512. {*                                                                   *}
  513. {* Side effects:                                                     *}
  514. {*      maxquery - used but not changed.                             *}
  515. {*      highblok - may be incremented +1.                            *}
  516. {*      currblok - equal to new highblok.                            *}
  517. {*      qimage   - contains image of new highblok.                   *}
  518. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  519.  
  520. LABEL 1;
  521.  
  522. VAR
  523.     objblok  : integer;
  524.     i        : bufx;
  525.     available: integer;
  526.     required : bufx;
  527. {$L+}
  528. BEGIN {appendrec function}
  529.     WITH qimage DO
  530.         BEGIN {with}
  531.             required := length(txt) + 9;
  532.             available:= 0;
  533.             objblok  := highblok - 1;
  534.             WHILE available<9 DO
  535.                 BEGIN {while}
  536.                     objblok   := objblok + 1;
  537.                     blokfetch(objblok,qimage);
  538.                     IF runabort
  539.                         THEN GOTO 1;
  540.                     i := 1;
  541.                     WHILE ((i<bufsize) AND (qentry[i]<>zerochr)) DO
  542.                         i := i + ord(qentry[i]);
  543.                     available := bufsize - i + 1
  544.                 END; {while}
  545.             appendseg1(txt,nyes,nno,qimage,i);
  546.             IF runabort
  547.                 THEN GOTO 1;
  548.             appendrec := objblok;
  549.             write(qfile:objblok,qimage);
  550.             IF qentry[i+1]<>chr(1)
  551.                 THEN BEGIN
  552.                         objblok := objblok + 1;
  553.                         blokfetch(objblok,qimage);
  554.                         IF runabort
  555.                             THEN GOTO 1;
  556.                         qentry[1] := chr(required-available+4);
  557.                         qentry[2] := chr(1);
  558.                         revert(qentry,3,maxquery+1);
  559.                         reshift(qentry,5,txt,available-8,required-available);
  560.                         write(qfile:objblok,qimage)
  561.                     END; {then}
  562. 1:      END {with}
  563. END; {appendrec function} {$L+}
  564. BEGIN {addrecord procedure}
  565.     newaddr := appendrec(txt,nyes,nno);
  566.     IF runabort
  567.         THEN GOTO 1;
  568.     xptr := dirfetch(maxquery+1);
  569.     ximage.xentry[xptr] := newaddr;
  570.     write(xfile:highxblk,ximage);
  571.  
  572.     IF ((nyes=0) AND (nno=0))
  573.         THEN maxanimals := maxanimals + 1;
  574.     maxquery := maxquery + 1;
  575.     blokfetch(1,qimage);
  576.     IF runabort
  577.         THEN GOTO 1;
  578.     revert(qimage.qentry, 6,maxquery);
  579.     revert(qimage.qentry, 8,highblok);
  580.     revert(qimage.qentry,10,highxblk);
  581.     revert(qimage.qentry,12,maxanimals);
  582.     write(qfile:1,qimage);
  583. 1:
  584. END; {addrecord procedure} {$L+}
  585. PROCEDURE initializefiles;
  586.  
  587. VAR
  588.     qfilename : string 15;
  589.     xfilename : string 15;
  590. {$L+}
  591. PROCEDURE newfile;
  592.  
  593. CONST
  594.     firstquestion = 'Does it live in the water';
  595.     yesguess      = 'octopus';
  596.     noguess       = 'moose';
  597.  
  598. VAR
  599.     i        : dirx;
  600.     newq     : queryfile;
  601.     newx     : directory;
  602.  
  603. BEGIN {newfile procedure}
  604.     rewrite(qfilename,newq);
  605.     rewrite(xfilename,newx);
  606.     FOR i := 1 TO 4 DO
  607.         ximage.xentry[i] := 1;          {First 4 records to block 1   }
  608.     FOR i := 5 TO maxx DO
  609.         ximage.xentry[i] := 0;
  610.     write(newx,ximage);
  611.  
  612.     WITH qimage DO
  613.         BEGIN {with}
  614.             FOR i := 1 TO bufsize DO
  615.                 qentry[i] := zerochr;
  616.             qentry[1]  := chr(13);      {Control record length is 13  }
  617.             qentry[2]  := chr(1);       {This is last & only segment  }
  618.             qentry[5]  := chr(ord(ctl));    {Identify as control rec  }
  619.             qentry[7]  := chr(3);       {Highest question# is 3       }
  620.             qentry[9]  := chr(1);       {Last question block used is 1}
  621.             qentry[11] := chr(1);       {Last index block used is 1   }
  622.             qentry[13] := chr(2);       {File contains 2 animals      }
  623.         END; {with}
  624.     i := 14;
  625.     maxquery := 0;
  626.     appendseg1(firstquestion,2,3,qimage,i);
  627.     i := i + 9 + length(firstquestion);
  628.     maxquery := 1;
  629.     appendseg1(yesguess,0,0,qimage,i);
  630.     i := i + 9 + length(yesguess);
  631.     maxquery := 2;
  632.     appendseg1(noguess,0,0,qimage,i);
  633.     write(newq,qimage)
  634. END; {newfile procedure} {$L+}
  635. FUNCTION testexist:  boolean;
  636. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  637. {* Test for existence of disk files QFILENAME and XFILENAME.         *}
  638. {* Return FALSE if either one is missing, TRUE if both there.        *}
  639. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  640.  
  641. VAR
  642.     testxfile : directory;
  643.     testqfile : queryfile;
  644.     missing   : boolean;
  645.  
  646. BEGIN {testexist function}
  647.     reset(qfilename,testqfile);
  648.     reset(xfilename,testxfile);
  649.     missing := (eof(testqfile) OR eof(testxfile));
  650.     testexist := NOT missing
  651. END; {testexist function} {$L+}
  652. BEGIN {initializefiles procedure}
  653.     qfilename := filepfx;
  654.     append(qfilename,'.QQQ ');
  655.     xfilename := filepfx;
  656.     append(xfilename,'.QQX ');
  657.     IF NOT testexist
  658.         THEN newfile;
  659.  
  660.     reset(qfilename,qfile);
  661.     reset(xfilename,xfile);
  662.     currblok   := -1;
  663.     currxblk   := -1;
  664.     highblok   :=  1;
  665.     highxblk   :=  1;
  666.     maxquery   :=  3;
  667.     maxanimals :=  2;
  668.  
  669.     read(xfile:1,ximage);
  670.     currxblk := 1;
  671.     read(qfile:1,qimage);
  672.     currblok := 1;
  673.     currec   := buildctl(qimage);
  674.     maxquery   := currec.lastq;
  675.     highblok   := currec.lastqbl;
  676.     highxblk   := currec.lastxbl;
  677.     maxanimals := currec.beastct
  678. END; {initializefiles procedure} {$L+}
  679. PROCEDURE guessing;
  680.  
  681. LABEL 1;
  682.  
  683. CONST
  684.     bell      = 7;           {ordinal of ASCII code for terminal bell }
  685.     boast     = 'How about that - - - I WON!';
  686.     delay     = 8000;
  687.  
  688. VAR
  689.     guesstime : boolean;
  690.     success   : boolean;
  691.     nextquest : integer;
  692.     prevquest : integer;
  693.     querytxt  : string maxlen+1;
  694.     holdguess : qstring;
  695.     i         : integer;
  696. {$L+}
  697. FUNCTION voweler (noun: qstring):  qstring;
  698.  
  699. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  700. {* Given a noun, return a string with the correct choice of "a" or   *}
  701. {* "an" preceding the noun.                                          *}
  702. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  703.  
  704. VAR
  705.     holder : qstring;
  706.  
  707. BEGIN {voweler function}
  708.     IF noun[1] IN vowels
  709.         THEN holder := ' an '
  710.         ELSE holder := ' a ';
  711.     append(holder,noun);
  712.     voweler := holder
  713. END; {voweler function}
  714.  
  715. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  716.  
  717. PROCEDURE lowerize (VAR txt: qstring);
  718.  
  719. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  720. {* In a given string, change all upper-case letters to lower-case,   *}
  721. {* unless it looks like the mix is intended.                         *}
  722. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  723.  
  724. VAR
  725.     i      : integer;
  726.     letter : char;
  727.     sloppy : boolean;
  728.  
  729. BEGIN {lowerize procedure}
  730.     sloppy := true;
  731.     FOR i := 1 TO 4 DO
  732.         IF i<=length(txt)
  733.             THEN IF txt[i] in ['a'..'z']
  734.                     THEN sloppy := false;
  735.     IF sloppy
  736.         THEN FOR i := 1 TO length(txt) DO
  737.                 BEGIN {for}
  738.                     letter := txt[i];
  739.                     IF ((letter>='A') AND (letter<='Z'))
  740.                         THEN txt[i] := chr(ord(letter)-shiftup)
  741.                 END {for}
  742. END; {lowerize procedure} {$L+}
  743. PROCEDURE askabout (qtext: qstring);
  744.  
  745. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  746. {* Publish a given question.                                         *}
  747. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  748.  
  749. CONST
  750.     maxline  = 69;
  751.  
  752. VAR
  753.     i, j     : questx;
  754.     holder   : qstring;
  755.  
  756. BEGIN {askabout procedure}
  757.     IF length(qtext)<=maxline
  758.         THEN write(qtext)
  759.         ELSE BEGIN
  760.                 i := maxline;
  761.                 WHILE (i>(maxline-20)) AND (qtext[i]<>' ') DO
  762.                     i := i - 1;
  763.                 IF i>(maxline-20)
  764.                     THEN BEGIN
  765.                             setlength(holder,i-1);
  766.                             FOR j := 1 to (i-1) DO
  767.                                 holder[j] := qtext[j];
  768.                             writeln(holder);
  769.                             holder := '    ';
  770.                             FOR j := (i+1) TO length(qtext) DO
  771.                                 append(holder,qtext[j]);
  772.                             write(holder)
  773.                         END {else}
  774.                     ELSE write(qtext)
  775.             END {else}
  776. END; {askabout procedure} {$L+}
  777. PROCEDURE learning (oldguess  : qstring;
  778.                     prevquest : integer);
  779. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  780. {* Given an old (wrong) guess (in the form "a fish" or "an egret",   *}
  781. {* and the record number of the question that led to that guess,     *}
  782. {* secure from the player the correct answer, and a yes-or-no        *}
  783. {* question that would have led to it.  Insert the new question and  *}
  784. {* and animal into the question file linkage.                        *}
  785. {*                                                                   *}
  786. {* Side effects:                                                     *}
  787. {*      maxanimals - updated                                         *}
  788. {*      I/O variables as required (see subordinate procedures)       *}
  789. {*      currec (used to build new record & view old guess)           *}
  790. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  791.  
  792. CONST
  793.     humbler  = 'Oh!  I didn''t know about';
  794.     request1 = 'I''d like to learn more about animals.';
  795.     request2 = 'What''s a yes-or-no question to discriminate between';
  796.     clarify1 = 'Which answer to that question would mean';
  797.     clarify2 = ' - yes or no';
  798.     thanks   = 'Thank you!  Now I know ';
  799.  
  800. VAR
  801.     holdright  : qstring;
  802.     rightbeast : qstring;
  803.     newbeast   : boolean;
  804.     newquery   : qstring;
  805.     qhold      : qstring;
  806.  
  807.  
  808.  
  809.  
  810. PROCEDURE depunctuate (VAR dtext: qstring);
  811.  
  812. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  813. {* Trim off any terminating punctuation marks.                       *}
  814. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  815.  
  816. CONST
  817.     endset   = '.!?';
  818.  
  819. BEGIN {depunctuate procedure}
  820.     WHILE index(endset,dtext[length(dtext)])<>0 DO
  821.         setlength(dtext,length(dtext)-1)
  822. END; {depunctuate procedure} {$L+}
  823. FUNCTION getbeast: qstring;
  824.  
  825. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  826. {* Return the name of the animal the player had in mind.             *}
  827. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  828.  
  829. CONST
  830.     puzzled  = 'Really?  What sort of animal is it, then?';
  831.  
  832. VAR
  833.     altered  : boolean;
  834.     oldlen   : questx;
  835.     holder   : qstring;
  836.  
  837. {$L+}
  838. PROCEDURE markout (VAR btext: qstring;  word: qstring);
  839.  
  840. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  841. {* Given a BTEXT, find any instances of WORD appearing as distinct   *}
  842. {* words.  If there are any, eliminate from BTEXT all characters to  *}
  843. {* and including WORD.                                               *}
  844. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  845.  
  846. CONST
  847.     blank1 = ' ';
  848.  
  849. VAR
  850.     i, j     : questx;
  851.     offset   : questx;
  852.     padword  : qstring;
  853.     padlen   : questx;
  854.  
  855. BEGIN {markout procedure}
  856.     padword := word;
  857.     append(padword,blank1);
  858.     padlen  := length(padword);
  859.     WHILE index(btext,padword)=1 DO
  860.         BEGIN {while}
  861.             setlength(btext,length(btext)-padlen);
  862.             FOR i := 1 TO length(btext) DO
  863.                 btext[i] := btext[i+padlen];
  864.             WHILE btext[1]=blank1 DO
  865.                 BEGIN {while}
  866.                     setlength(btext,length(btext)-1);
  867.                     FOR i := 1 TO length(btext) DO
  868.                         btext[i] := btext[i+1]
  869.                 END {while}
  870.         END; {while}
  871.     padword := blank1;
  872.     append(padword,word);
  873.     append(padword,blank1);
  874.     padlen := length(padword);
  875.    j := index(btext,padword);
  876.     WHILE j<>0 DO
  877.         BEGIN {while}
  878.             offset := j + padlen - 1;
  879.             setlength(btext,length(btext)-offset);
  880.             FOR i := 1 TO length(btext) DO
  881.                  btext[i] := btext[offset+i];
  882.             WHILE btext[1]=blank1 DO
  883.                 BEGIN {while}
  884.                     setlength(btext,length(btext)-1);
  885.                     FOR i := 1 TO length(btext) DO
  886.                         btext[i] := btext[i+1]
  887.                 END; {while}
  888.             j := index(btext,padword)
  889.         END {while}
  890. END; {markout procedure} {$L+}
  891. BEGIN {getbeast function}
  892.     writeln(puzzled);
  893.     readln(holder);
  894.     depunctuate(holder);
  895.     lowerize(holder);
  896.     oldlen := length(holder);
  897.     altered := (holder[1]='A');
  898.     IF altered
  899.         THEN holder[1] := 'a';
  900.     markout(holder,'a');
  901.     markout(holder,'an');
  902.     IF (altered AND (oldlen=length(holder)))
  903.         THEN holder[1] := 'A';
  904.     getbeast := holder
  905. END; {getbeast function} {$L+}
  906. PROCEDURE insertquestion (qstn : qstring;
  907.                           ind  : boolean;
  908.                           ytxt : qstring;
  909.                           rec  : question;
  910.                           prev : integer);
  911. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  912. {* Insert a new question and guess into the question file, with      *}
  913. {* all required linkages.  QUESTN is the new question, YTXT is the   *}
  914. {* name of the new animal to be guessed.  If IND is true, then YTST  *}
  915. {* is the guess for a YES answer, and the animal in REC for NO;      *}
  916. {* otherwise, it's the other way around.  PREV is the question#      *}
  917. {* that led to this question;  the new question is to be substituted *}
  918. {* for REC in that question.                                         *}
  919. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  920.  
  921. LABEL 1;
  922.  
  923. VAR
  924.     newqstnum : integer;
  925.     newansnum : integer;
  926.     oldansnum : integer;
  927.     newyes    : integer;
  928.     newno     : integer;
  929. {$L+}
  930. PROCEDURE amendrec (recno, nyes, nno: integer);
  931.  
  932. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  933. {* For a given question record, update the NEXTYES and NEXTNO ptrs.  *}
  934. {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
  935.  
  936. LABEL 1;
  937.  
  938. VAR
  939.     blokno   : integer;
  940.     xptr     : dirx;
  941.     ptr      : bufx;
  942.  
  943. BEGIN {amendrec procedure}
  944.     xptr := dirfetch(recno);
  945.     IF runabort
  946.         THEN GOTO 1;
  947.     blokno := ximage.xentry[xptr];
  948.     blokfetch(blokno,qimage);
  949.     IF runabort
  950.         THEN GOTO 1;
  951.     ptr := findrec(recno,qimage.qentry);
  952.     IF runabort
  953.         THEN GOTO 1;
  954.     revert(qimage.qentry,ptr+5,nyes);
  955.     revert(qimage.qentry,ptr+7,nno);
  956.     write(qfile:blokno,qimage);
  957. 1:
  958. END; {amendrec procedure} {$L+}
  959. BEGIN {insertquestion procedure}
  960.     newqstnum := maxquery + 1;
  961.     newansnum := maxquery + 2;
  962.     oldansnum := rec.ident;
  963.     IF ind
  964.         THEN BEGIN
  965.                 newyes := newansnum;
  966.                 newno  := oldansnum
  967.             END {then}
  968.         ELSE BEGIN
  969.                 newyes := oldansnum;
  970.                 newno  := newansnum
  971.             END; {else}
  972.     addrecord(qstn,newyes,newno);
  973.     IF runabort
  974.         THEN GOTO 1;
  975.     addrecord(ytxt,0,0);
  976.     IF runabort
  977.         THEN GOTO 1;
  978.     rec := getrecord(prev);
  979.     IF runabort
  980.         THEN GOTO 1;
  981.     IF rec.nextyes=oldansnum
  982.         THEN rec.nextyes := newqstnum
  983.         ELSE rec.nextno  := newqstnum;
  984.     amendrec(prev,rec.nextyes,rec.nextno);
  985. 1:
  986. END; {insertquestion procedure} {$L+}
  987. BEGIN {learning procedure}
  988.     rightbeast := getbeast;
  989.     holdright  := voweler(rightbeast);
  990.     writeln(humbler,holdright,'.');
  991.     writeln(request1);
  992.     qhold := request2;
  993.     append(qhold,holdright);
  994.     append(qhold,' and');
  995.     append(qhold,oldguess);
  996.     append(qhold,'?');
  997.     askabout(qhold);
  998.     writeln;
  999.     readln(newquery);
  1000.     depunctuate(newquery);
  1001.     lowerize(newquery);
  1002.     IF ((newquery[1]>='a') AND (newquery[1]<='z'))
  1003.         THEN newquery[1] := chr(ord(newquery[1])+shiftup);
  1004.     qhold := clarify1;
  1005.     append(qhold,holdright);
  1006.     append(qhold,clarify2);
  1007.     askabout(qhold);
  1008.     IF getyes
  1009.         THEN newbeast := true
  1010.         ELSE newbeast := false;
  1011.     insertquestion(newquery,newbeast,rightbeast,currec,prevquest);
  1012.     IF NOT runabort
  1013.         THEN writeln(thanks,maxanimals:1,' animals.')
  1014. END; {learning procedure} {$L+}
  1015. BEGIN {guessing procedure} {$C+}
  1016.     guesstime := false;
  1017.     nextquest := 1;
  1018.     WITH currec DO
  1019.         BEGIN {with}
  1020.             WHILE NOT guesstime DO
  1021.                 BEGIN {while}
  1022.                     currec := getrecord(nextquest);
  1023.                     IF runabort
  1024.                         THEN GOTO 1;
  1025.                     guesstime := (nextyes=0) AND (nextno=0);
  1026.                     IF NOT guesstime
  1027.                         THEN BEGIN
  1028.                                 prevquest := ident;
  1029.                                 askabout(query);
  1030.                                 IF getyes
  1031.                                     THEN nextquest := nextyes
  1032.                                     ELSE nextquest := nextno
  1033.                             END {then}
  1034.                 END; {while}
  1035.             querytxt  := 'Is it';
  1036.             holdguess := voweler(query);
  1037.             append(querytxt,holdguess);
  1038.             askabout(querytxt);
  1039.             IF getyes
  1040.                 THEN BEGIN
  1041.                         writeln;
  1042.                         writeln(chr(bell),boast);
  1043.                         FOR i := 1 TO delay DO;
  1044.                     END {then}
  1045.                 ELSE learning(holdguess,prevquest)
  1046.         END; {with}
  1047. 1:
  1048. END; {guessing procedure} {$L+}
  1049. BEGIN {mainline procedure of program}
  1050.     runabort := false;
  1051.     zerochr  := chr(0);
  1052.     vowels   := ['A','E','I','O','U','a','e','i','o','u'];
  1053.     shiftup  := ord('A') - ord('a');
  1054.     FOR i := 1 TO 14 DO
  1055.         writeln;
  1056.     writeln(ack1,ack1a);
  1057.     writeln;
  1058.     writeln(ack2);
  1059.     writeln(ack3);
  1060.     writeln(ack4);
  1061.     writeln(ack5);
  1062.     writeln(ack6);
  1063.     writeln;
  1064.     writeln;
  1065. {   rewrite('LST: ',db);  }
  1066. {   dbugging := false;    }
  1067.     initializefiles;
  1068.     write(inviter);
  1069.     moreokay := getyes;
  1070.     WHILE moreokay DO
  1071.         BEGIN {while}
  1072.             writeln(start1);
  1073.             writeln(start2);
  1074.             readln(replytxt);
  1075.             guessing;
  1076.             IF runabort
  1077.                 THEN moreokay := false
  1078.                 ELSE BEGIN
  1079.                         writeln;
  1080.                         write(askagain);
  1081.                         moreokay := getyes
  1082.                     END {else}
  1083.         END; {while}
  1084.     IF runabort
  1085.         THEN writeln('TERMINATING DUE TO PROGRAM OR FILE ERROR')
  1086.         ELSE writeln('Okay!  Goodbye!')
  1087. END. {Animals program}
  1088.