==================================================

                    INDUCE.DOC

==================================================


                                 INDUCE


                  Copyright 1986 - MicroExpert Systems
                             Box 430 R.D. 2
                            Nassau, NY 12123


     INDUCE implements the ID3 algorithm for the generation of rules from a data   set as described in the article "Finding Knowledge in Data" in the November 1986 issue of BYTE.

    The program has been tested using Turbo Version 3.01A on an IBM PC. It has been run under both DOS 2.1 and Concurrent 4.1 . The source for this program is contained in two files, INDUCE.PAS and   INDUCE.INC. The program produces one overlay file INDUCE.000 .

     INDUCE produces a knowledge base which can be used with MicroExpert.   MicroExpert is an expert system shell written in Turbo Pascal for the IBM PC and Apple II. It is available for $49.95 and comes with complete source code. It can be order by writing to :

        McGraw-Hill Book Company
        P.O. Box 400
        Hightstown, NJ 08520

   Or calling 1-800-628-004 or in New York state 212/512-2999.

   We would be pleased to hear your comments, good or bad, or any applications   and modifications of the program. Contact us at the above address or on BIX. Our id is bbt and we may be contacted via BIXmail or by leaving comments in the MicroExpert conference.

-   Bill and Bev Thompson 


                                Operation

     To start the program simply switch to the directory containing INDUCE.COM and INDUCE.000 and at the DOS prompt type INDUCE and press the ENTER key. The screen will clear and the message

Example File (Press <ENTER> to quit.) : 

will appear. Type in the name of your example file and press the enter key. The file name should include the drive and path name if necessary. The default extension for example files is ".EX". The program will now read the example file. Error messages will be displayed on the screen. The program does not do very extensive error checking, so be sure to examine the example files and knowledge base to be sure that they make sense.

     Once the file has been read, the program will attempt to classify the example set. Each time an attempt is made to classify a partition of the example set, a "." is printed on the screen. The program is not particularly fast, so you will see the "."s crawl across the screen.

     You may see a "*" appear on the screen from time to time and then disappear. This indicates that garbage collection is in process. The program is attempting to reclaim memory which has been used, but is no longer accessible. 

     When the classification process has been completed, the message

Output the tree to what file (Press <ENTER> for screen) ?

will appear. You may save the tree to a file or press <ENTER> to print it on the screen. The format of the tree is described in the BYTE article. If the size of the tree is such that its width exceeds 80 columns, it may not print properly. After displaying the tree on the screen, a message telling you to press any key to continue will be displayed. To print the tree on the printer enter "lst:" as the file name.

Next, the program will display

Output the rules to what file (Press <ENTER> for screen) ?

Enter the name of the file which is to contain the rules. If this file is to be a MicroExpert knowledge base, be sure to include the extension ".KB" to the file name. The program will also write a series of prompts for the attributes.

     Finally the program will clear the screen and request a new example file. At this point you can enter a new example file or press <ENTER> to exit the program.

                              Example Files

     Example files are simply Ascii text files which are created with a text editor. The program ignores blank lines and comments in the files. Comments begin with "(*" and end with "*)". A comment may extend over several lines. The first line in the file which is not a comment or a blank line must contain the attribute names. The format of this line is

    class name,attribute1,attribute2,.....

The class name must come first, followed by the names of the attributes separated by commas. Leading and trailing blanks in attribute are not significant. Internal spaces are. Therefore, "dog and cat" is not the same as "dogandcat". The program is also case sensitive, so "Dog" is considered different from "dog". The program does not check for duplicate attributes, but of course, any knowledge base produced using duplicate attribute names is likely to be incorrect.

     Following the line containing the attribute names are one or more lines containing examples. Each example line contains a class value followed by a series of attribute values separated by commas. Each example must fit on one line. The general format is

    class value,value of attribute1,value of attribute2,.....

The attributes must be in the same order as they are listed in the first line, although there is no way for the program to check on this. As with attribute and class names, internal spaces are significant, leading and trailing spaces are not. "don't care" values are indicated by a "*".

     The following is the contents of the file for the example set in the BYTE article:


(* Example file for Byte Article   21-May-86 *)

(* Copyright [c] 1986    MicroExpert Systems
                         Box 430 RD 2
                         Nassau, NY 12123  *) 

             (* Attributes *)

profit	,age		,competition	,type

             (* Examples *)
down	,old		,no		,software
down	,midlife	,yes		,software
up	,midlife	,no		,hardware
down	,old		,no		,hardware
up	,new		,no		,hardware
up	,new		,no		,software
up	,midlife	,no		,software
up	,new		,yes		,software
down	,midlife	,yes		,hardware
down	,old		,yes		,software


                          Numerical Attributes

     Numerical attributes are handled in the name manner as symbolic (non-numerical) attributes, except that ":number" is appended to the attribute name. ":number" is removed from the attribute name before printing and will not appear in either the tree or the knowledge base. Values for numeric attributes must be with in the range +/- 1.0E+37 to +/- 1.0E-37. The numbers may be entered in integer, real or floating point format. The following example set demonstrates the use of numerical attributes. There is a "don't care" value in the second example.


(* Numerical Attribute Example file *)

(* Copyright [c] 1986    MicroExpert Systems
                         Box 430 RD 2
                         Nassau, NY 12123  *) 

             (* Attributes *)

profit	,age:number     ,competition	,type

             (* Examples *)
down	,5.0	        ,no		,software
down	,2.5        	,*		,software
up	,2.5       	,no		,hardware
down	,5		,no		,hardware
up	,1		,no		,hardware
up	,1		,no		,software
up	,2.5        	,no		,software
up	,1		,yes		,software
down	,2          	,yes		,hardware
down	,5		,yes		,software




==================================================

                    INDUCE.PAS

==================================================


{.IN+}
{.PW132}
(*$V-,R+,B- *)
PROGRAM induce ;

(* Copyright 1986 - MicroExpert Systems
                    Box 430 R.D. 2
                    Nassau, NY 12123       *)

(* Induce implements the ID3 algorithm for the generation of rules from a data
   set as described in the BYTE article "Finding Knowledge in Data".

   This program has been tested using Turbo ver 3.01A on an IBM PC. It has
   been run under both DOS 2.1 and Concurrent 4.1 .

   The source for this program is contained in two files, INDUCE.PAS and
   INDUCE.INC. The program produces one overlay file INDUCE.000 .

   INDUCE produces a knowledge base which can be used with MicroExpert.
   MicroExpert is an expert system shell written in Turbo Pascal for the
   IBM PC and Apple II. It is available for $49.95 and comes with complete
   source code. It can be order by writing to :
        McGraw-Hill Book Company
        P.O. Box 400
        Hightstown, NJ 08520

   Or calling 1-800-628-004 or in New York state 212/512-2999.

   We would be pleased to hear your comments, good or bad, or any applications
   and modifications of the program. Contact us at the above address or
   on BIX. Our id is bbt and we may be contacted via BIXmail or by leaving
   comments in the MicroExpert conference.

   Bill and Bev Thompson    *)


 CONST
  ln2 = 0.69314718 ;
  limit = 1.0E-20 ;
  debug = false ;
  back_space = ^H ;
  tab = ^I ;
  eof_mark = ^Z ;
  esc = #27 ;
  quote_char = #39 ;
  left_arrow = #75 ;
  end_key = #79 ;
  del_line = ^X ;
  return = ^M ;
  bell = ^G ;

 TYPE
  counter = 0 .. maxint ;
  string80 = string[80] ;
  string132 = string[132] ;
  string255 = string[255] ;
  text_file = text ;
  char_set = SET OF char ;
  node_type = (cons_node,symbol,number,free_node) ;
  node_ptr = ^node ;
  node = RECORD
          in_use : boolean ;
          CASE tag : node_type OF
           cons_node : (tail_ptr : node_ptr ;
                        head_ptr : node_ptr) ;
           symbol    : (string_data : string80) ;
           number    : (num_data : real) ;
           free_node : (next_free : node_ptr ;
                        block_cnt : counter) ;
          END ;

(* node is the basic allocation unit for lists. The fields are used as
   follows:

    in_use     - in_use = false tells the garbage collector that this node
                 is available for re-use.
    tag        - which kind of node this is.
    cons_node  - cons_nodes consist of two pointers. one to the head (first item)
                 the other to the rest of the list. They are the "glue" which
                 holds the list together. The list (A B C) would be stored as
                   -------         --------          --------
                   | .| . |----->  |  .| . |------> |  .| . |---> NIL
                   --|-----         --|------        --|-----
                     |                |                |
                     V                V                V
                     A                B                C

                 The boxes are the cons nodes, the first part of the box
                 holds the head pointer, then second contains the tail.
    symbol     - holds string values, we don't actually use the entire 80
                 characters in most cases.
    number     - contains a real number.
    free_node  - the garbage collector gathers all unused nodes and puts
                 them on a free list. It also compacts the free space into
                 contiguous blocks. next_free points to the next free block.
                 block_cnt contains a count of the number of contiguous 8 byte free
                 blocks which follow this one.    *)


 VAR
  example_file : text_file ;
  line : string255 ;
  c_list,examples,attrib_list,saved_list,initial_heap,free : node_ptr ;
  total_free : real ;
  no_of_cols : counter ;

(* The important globals are:
   example_file - text file containing the original example set. See the
                  documentation file for its format.
   line         - line buffer for reading in the text file
   c_list       - the classification tree
   examples     - the list of examples
   attrib_list  - list of attribute names and their values
   saved_list   - list of all items that absolutely must be saved if garbage
                  collection occurs. Usually has at least the examples and
                  attrib_list attcahed to it.
   initial_heap - the value of the heap pointer at the start of the program.
                  used by the garbage collector
   free         - the list of free nodes.
   total_free   - total number of free blocks on the free list.
   no_of_cols   - the total number of attributes + the class attribute in
                  the example set.    *)


(*$I induce.inc *)


 PROCEDURE read_from_file(VAR f : text_file) ;
  (* Read a line form file f and store it in the global variable, line.
     It ignores blank lines and comments. When the end of file is reached
     eof_mark is returned.   *)
  CONST
   in_comment : boolean = false ; (* static *)

  PROCEDURE read_a_line ;
   BEGIN
    (*$I- *)
    readln(f,line) ;
    (*$I+ *)
    IF ioresult <> 0
     THEN line := eof_mark
    ELSE IF pos('(*',line) > 0
     THEN
      IF pos('*)',line) > 0
       THEN delete(line,pos('(*',line),pos('*)',line) - pos('(*',line) + 2)
       ELSE
        BEGIN
         in_comment := true ;
         line := '' ;
        END ;
   END ; (* read_a_line *)

  BEGIN
   line := '' ;
   IF eof(f)
    THEN line := eof_mark
    ELSE
     BEGIN
      read_a_line ;
      IF in_comment
       THEN
        IF pos('*)',line) > 0
         THEN
          BEGIN
           delete(line,1,pos('*)',line) + 1) ;
           in_comment := false ;
          END
         ELSE read_from_file(f) ;
     END ;
   strip_leading_blanks(line) ;
   strip_trailing_blanks(line) ;
   IF line = ''
    THEN read_from_file(f) ;
  END ; (* read_from_file *)


 OVERLAY PROCEDURE expand(example_list : node_ptr ;
                          VAR new_example_list : node_ptr) ;
  (* Expand "don't care" values into values from attrib_list.
     example_list     - unexpanded example set
     new_example_list - expanded set    *)

  PROCEDURE dup_and_copy(list : node_ptr) ;
   (* This routine creates a new version of the current row, pointed to by
      list. If it finds a regular attribute value, it just appends the value
      to the row it is constructing. If it finds a '*', indicating a
      "don't care" value, it call copy_to_new_list to expand the value and
      attach the new rows to new_example_list.
      Notice that we attach anything we don't want to be trashed by the
      garbage collector to the head of saved_list and remove it at the end
      of the routine. copy_to_new_list saves new_list because it calls
      dup_and_copy and that routine might initiate garbage collection.  *)
   VAR
    new_list,attr_ptr : node_ptr ;
    copied : boolean ;

   PROCEDURE copy_to_new_list ;
    (* This routine does the actual expansion. It attaches a value for the
       attribute, pointed to by p, to the row that has been constructed
       so far and attaches the rest of the list to the end of the row.
       It calls dup_and_copy to expand any more *'s in the row and finally
       attach the row to the new_example_list *)
    VAR
     p,new_row : node_ptr ;
    BEGIN
     saved_list := cons(new_list,saved_list) ;
     copied := true ;
     p := tail(head(attr_ptr)) ;
     WHILE p <> NIL DO
      BEGIN
       new_row := append_list(new_list,cons(head(p),tail(list))) ;
       dup_and_copy(new_row) ;
       p := tail(p) ;
      END ;
     saved_list := tail(saved_list) ;
    END ; (* copy_to_new_list *)

   BEGIN
    saved_list := cons(list,saved_list) ;
    test_memory ;
    new_list := NIL ;
    attr_ptr := attrib_list ;
    copied := false ;
    WHILE (list <> NIL) AND (NOT copied) DO
     IF string_val(head(list)) = '*'
      THEN copy_to_new_list
      ELSE
       BEGIN
        new_list := append_list(new_list,cons(head(list),NIL)) ;
        list := tail(list) ;
        attr_ptr := tail(attr_ptr) ;
       END ;
    IF NOT copied
     THEN new_example_list := append_list(new_example_list,cons(new_list,NIL)) ;
    saved_list := cons(new_example_list,tail(saved_list)) ;
   END ; (* dup_and_copy *)

  BEGIN
   new_example_list := NIL ;
   WHILE example_list <> NIL DO
    BEGIN
     dup_and_copy(head(example_list)) ;
     example_list := tail(example_list) ;
    END ;
  END ; (* expand *)


 OVERLAY FUNCTION conflicts(example_list : node_ptr) : boolean ;
  (* Search for conflicts by using match_list to compare each row against
     the rows which follow it in the example list. conflicts returns true
     if a match is found.  *)
  VAR
   p : node_ptr ;
   found_match : boolean ;

  PROCEDURE conflict_message ;
   BEGIN
    writeln ;
    writeln('A conflict exists between rows:') ;
    writeln ;
    print_list(head(example_list)) ;
    writeln ;
    print_list(head(p)) ;
    writeln ;
    writeln('Processing cannot continue.') ;
   END ; (* conflict_message *)

  BEGIN
   found_match := false ;
   WHILE (example_list <> NIL) AND (NOT found_match) DO
    BEGIN
     p := tail(example_list) ;
     WHILE (p <> NIL) AND (NOT found_match) DO
      IF match_lists(tail(head(example_list)),tail(head(p)))
       THEN found_match := true
       ELSE p := tail(p) ;
     IF NOT found_match
      THEN example_list := tail(example_list) ;
    END ;
   IF found_match
    THEN conflict_message ;
   conflicts := found_match ;
  END ; (* conflicts *)


 OVERLAY PROCEDURE build_table ;
  (* Read the example file and build the attrib_list and examples. The
     format of these two lists is described in the BYTE article mentioned
     at the beginning of the program. This routine doesn't do much error
     checking, so be careful with your example files.   *)
  VAR
   new_row : node_ptr ;
   token : string80 ;

  PROCEDURE scan ;
   (* Get a single token from the input line. This procedure strips leading
      and trailing blanks and tabs, but interior spaces are sigificant.
      A token is any string between the first non-space character and a
      comma or end of line. Case is significant in tokens, 'Cat' and 'cat'
      will be treated as different values by the program.    *)
   VAR
    comma_pos : byte ;
   BEGIN
    strip_leading_blanks(line) ;
    IF line = ''
     THEN token := ''
     ELSE
      BEGIN
       comma_pos := pos(',',line) ;
       IF comma_pos > 0
        THEN
         BEGIN
          token := copy(line,1,comma_pos - 1) ;
          delete(line,1,comma_pos) ;
         END
        ELSE
         BEGIN
          token := line ;
          line := '' ;
         END ;
       IF token = ''
        THEN token := '*' ;
       strip_trailing_blanks(token) ;
      END ;
   END ; (* scan *)

  PROCEDURE build_a_row ;
   (* Builds an example row. Symbolic and numerical attributes are handled
      differently. Input lines are read one token at a time and storage is
      allocated for the new token. The attrib_list is examined to see if
      the new value appears on the list of values for that attribute. If it
      does not, the value is added to the list. Symbolic values are added
      to the end of the list of values for the attribute, numerical values are
      stored in order. Once the new row is constructed it is appended
      to the example set.   *)
   VAR
    at_list,row_list,token_ptr : node_ptr ;

   PROCEDURE length_error ;
    (* Signal an error, probably a missing value. The row in question
       will not be included in the example set, but the attribute list
       may be damaged, so don't trust results after and error.   *)
    BEGIN
     writeln ;
     writeln('Missing attribute in row:') ;
     print_list(row_list) ;
     writeln ;
     writeln ;
     wait ;
    END ; (* length_error *)

   PROCEDURE add_value ;
    (* Add a new value to the attribue list. The variable attrib_list keeps
       track of the current column as the row is scanned. If token was
       found to already be on the attrib_list, head(attrib_list) is appended
       to at_list. If the token is a new value, it is added to the list at the
       head of attrib_list, and then head(attrib_list) is appended to at_list.
       After reading the entire row from the file, attrib_list is set to
       point to at_list. This way attrib_list is reconstructed for each
       row.    *)

    PROCEDURE insert_number ;
     (* Insert a number into the attribute list. The list of values
        for numerical attributes is maintained in order. This is done by
        comparing the value of the token against the other items on the
        list. As the comparison is done, the values are copied to new_list.
        When a value is found that is greater than the token value or the
        end of the list is reached, the token is appened to new_list and
        then the reaming values on the old list are appended to new_list.
        Finally new_list is appended to at_list. All of this appending
        produces lots of garbage.  *)
     VAR
      new_list,p : node_ptr ;
      r : real ;
      inserted : boolean ;

     PROCEDURE build_new_list ;
      (* This routine does the actual insetion described above. *)
      BEGIN
       WHILE (p <> NIL) AND (NOT inserted) DO
        BEGIN
         IF abs(r - num_val(head(p))) < limit
          THEN
           BEGIN
            inserted := true ;
            new_list := append_list(new_list,p) ;
           END
         ELSE IF r > num_val(head(p))
          THEN
           BEGIN
            new_list := append_list(new_list,cons(head(p),NIL)) ;
            p := tail(p) ;
           END
         ELSE
          BEGIN
           new_list := append_list(new_list,append_list(
                                            cons(token_ptr,NIL),p)) ;
           inserted := true ;
          END ;
        END ;
      END ; (* build_new_list *)

     BEGIN
      r := num_val(token_ptr) ;
      inserted := false ;
      new_list := cons(head(head(attrib_list)),NIL) ;
      p := tail(head(attrib_list)) ;
      build_new_list ;
      IF (p = NIL) AND (NOT inserted)
       THEN new_list := append_list(new_list,cons(token_ptr,NIL)) ;
      at_list := append_list(at_list,cons(new_list,NIL)) ;
     END ; (* insert_number *)

    BEGIN
     IF tag_value(token_ptr) = number
      THEN insert_number
      ELSE at_list := append_list(at_list,
                                  cons(append_list(head(attrib_list),
                                                   cons(token_ptr,NIL)),
                                        NIL)) ;
    END ; (* add_value *)

   BEGIN
    saved_list := cons(examples,attrib_list) ;
    test_memory ;
    at_list := NIL ;
    row_list := NIL ;
    scan ;
    WHILE token <> '' DO
     BEGIN
      IF pos(':NUMBER',toupper(string_val(head(head(attrib_list))))) > 0
       THEN token_ptr := alloc_num(toreal(token))
       ELSE token_ptr := alloc_str(token) ;
      IF (NOT on_list(token,head(attrib_list))) AND (token <> '*')
       THEN add_value
       ELSE at_list := append_list(at_list,cons(head(attrib_list),NIL)) ;
      row_list := append_list(row_list,cons(token_ptr,NIL)) ;
      attrib_list := tail(attrib_list) ;
      scan ;
     END ;
    attrib_list := at_list ;
    IF list_length(row_list) = no_of_cols
     THEN examples := append_list(examples,cons(row_list,NIL))
     ELSE length_error ;
   END ; (* build_a_row *)

  PROCEDURE build_attrib_list ;
   (* constructs the initial attrib_list from the first row in the file.
      Initially the attrib_list is simply a list of the attribute names,
      build_a_row adds the values to it. This routine also counts the
      number of columns (attributes) in the table.   *)
   BEGIN
    attrib_list := NIL ;
    no_of_cols := 0 ;
    scan ;
    WHILE token <> '' DO
     BEGIN
      attrib_list := append_list(attrib_list,cons(cons(alloc_str(token),NIL),
                                                  NIL)) ;
      no_of_cols := no_of_cols + 1 ;
      scan ;
     END ;
   END ; (* build_attrib_list *)

  BEGIN
   examples := NIL ;
   line := '' ;
   read_from_file(example_file) ;
   IF line <> eof_mark
    THEN build_attrib_list ;
   read_from_file(example_file) ;
   WHILE line <> eof_mark DO
    BEGIN
     build_a_row ;
     read_from_file(example_file) ;
    END ;
  END ; (* build_table *)

 OVERLAY FUNCTION classify_it : node_ptr ;
  (* is an overlay function which calls classify. We do it this way to avoid
     swapping due to recursion. *)

  FUNCTION classify(example_list,chosen_list : node_ptr) : node_ptr ;
   (* This is the main processing routine of the program. It is passed two
      lists, a list of rows, example_list and a list of attributes already
      chosen. The second list is simply for convenience. That way we don't
      have to calculate the entropy for attribute which can no longer
      contribute to splitting example_set. classify returns a pointer to the
      classification tree built from the example_set.
      If the example_list passed to it contains only a single class value,
      classify returns the class_name (attribute name of the first column) and
      the class value.
      Variables:
       split_elem    - the column (attribute number) to split on
       classify_list - a temporary list to hold the tree
       split_value   - for numerical attributes. It contains the value which
                       produces the best numerical split.
     classify prints a dot on the screen each time it is entered to show you
     that the program really hasn't died.     *)
   VAR
    split_elem : counter ;
    classify_list : node_ptr ;
    split_value : real ;

   PROCEDURE find_split(VAR split_elem : counter ; VAR min_split_value : real) ;
    (* finds the best attribute to split on. It returns the column number on
       which to split and for numerical attribute, the value which produces the
       best split. For each active attribute it constructs a class_list. the
       class_list has the following format:
       ( (attribute value #1 (class1 count) (class2 count) ....)
         (attribute value #2 (class1 count) (class2 count) ....) .....)
       The counts are the number of times each class appears in a row with
       a particular value of the attribute. This list is used to calculate
       the entropy of the attribute.  *)
    VAR
     i : counter ;
     attrib : node_ptr ;
     ent,min_entropy,split_value : real ;

    FUNCTION entropy(list : node_ptr ; cases : counter) : real ;
     (* list is a class list. cases is the number of examples under
        consideration. This routine calculates the entropy H(C|A) from the class
        list. *)
     VAR
      sum,sum1,sum2,r : real ;
      p : node_ptr ;

     FUNCTION log2(x : real) : real ;
      BEGIN
       IF abs(x) < limit
        THEN log2 := 0.0
        ELSE log2 := ln(x) / ln2 ;
      END ; (* log2 *)

     BEGIN
      sum := 0.0 ;
      WHILE list <> NIL DO
       BEGIN
        sum1 := 0.0 ;
        sum2 := 0.0 ;
        p := tail(head(list)) ;
        WHILE p <> NIL DO
         BEGIN
          r := num_val(head(tail(head(p)))) ;
          sum1 := sum1 + r * log2(r) ;
          sum2 := sum2 + r ;
          p := tail(p) ;
         END ;
        sum := sum + (sum2 * log2(sum2)) - sum1 ;
        list := tail(list) ;
       END ;
      entropy := sum / cases ;
     END ; (* entropy *)

    PROCEDURE numeric_entropy(elem_no : counter ;
                              VAR num_entropy,num_split_value : real) ;
     (* Find the best split for a numeric attribute. elem_no is the column we
        are working on. num_entropy is the best entropy for this attribute
        and num_split_value is the split which gives that value. In
        addition to the class list, this routine produces an ordered list
        of the values for this attribute, called num_list. This list is
        used in making the splits. Each split is half way between successive
        values on the num_list. The entropy is calculated for each split. *)
     VAR
      class_list,sp,num_list : node_ptr ;
      sp_val,num_ent : real ;
      total_cases : counter ;

     PROCEDURE make_num_list ;
      (* constructs num_list. This is essentially the same routine as
         insert_number in build_table *)
      VAR
       new_list,p,q : node_ptr ;
       r : real ;
       inserted : boolean ;

      PROCEDURE add_to_new_list ;
       BEGIN
        WHILE (p <> NIL) AND (NOT inserted) DO
         BEGIN
          IF abs(r - num_val(head(p))) < limit
           THEN
            BEGIN
             inserted := true ;
             new_list := append_list(new_list,p) ;
            END
          ELSE IF r > num_val(head(p))
           THEN
            BEGIN
             new_list := append_list(new_list,cons(head(p),NIL)) ;
             p := tail(p) ;
            END
          ELSE
           BEGIN
            new_list := append_list(new_list,append_list(
                                             cons(alloc_num(r),NIL),p)) ;
            inserted := true ;
           END ;
         END ;
       END ; (* add_to_new_list *)

      BEGIN
       test_memory ;
       num_list := NIL ;
       q := example_list ;
       WHILE q <> NIL DO
        BEGIN
         r := num_val(head(element(head(q),elem_no))) ;
         new_list := NIL ;
         p := num_list ;
         inserted := false ;
         add_to_new_list ;
         IF (p = NIL) AND (NOT inserted)
          THEN new_list := append_list(new_list,cons(alloc_num(r),NIL)) ;
         num_list := new_list ;
         q := tail(q) ;
        END ;
      END ; (* make_num_list *)

     PROCEDURE make_numeric_class_list(v : real) ;
      (* builds the class list. v is the value to split on. The class_list
         contains lists for two ranges < v and >= v. The list has the format:
         ( (< v  (class1 count) (class2 count) .....)
           (>= v (class1 count) (class2 count) .....))   *)
      VAR
       temp_list,p : node_ptr ;
       v_str : string80 ;
      BEGIN
       str(v,v_str) ;
       temp_list := NIL ;
       p := tail(head(attrib_list)) ;
       WHILE p <> NIL DO
        BEGIN
         temp_list := append_list(temp_list,cons(cons(head(p),
                                                 cons(alloc_num(0.0),NIL)),NIL)) ;
         p := tail(p) ;
        END ;
       class_list := cons(cons(alloc_str(concat('< ',v_str)),temp_list),
                          cons(cons(alloc_str(concat('>= ',v_str)),
                               copy_list(temp_list)),NIL)) ;
      END ; (* make_numeric_class_list *)

     PROCEDURE count_numeric_classes(v : real ; elem_no : counter) ;
      (* count the classes for each range. It reads the example list, extracts
         the value for the attribute, searches the class list and increments
         the appropriate class value in the list. v is the split value. *)
      VAR
       px,py : node_ptr ;

      PROCEDURE numeric_increment(list : node_ptr ; attr_v,atv : string80) ;
       (* search list (class_list) and compare attr_v to v, the split_value.
          atv is the class_value. Once we find the sub-list with the proper
          range we search its tail for atv to increment the class count.   *)

       PROCEDURE do_increment(v_list : node_ptr) ;
        VAR
         p,q : node_ptr ;
        BEGIN
         q := tail(v_list) ;
         WHILE q <> NIL DO
          IF string_val(head(head(q))) = atv
           THEN
            BEGIN
             p := head(tail(head(q))) ;
             IF tag_value(p) = number
              THEN p^.num_data := p^.num_data + 1.0 ;
             total_cases := total_cases + 1 ;
             q := NIL ;
            END
           ELSE q := tail(q) ;
        END ; (* do_increment *)

       BEGIN
        IF toreal(attr_v) < v
         THEN do_increment(head(list))
         ELSE do_increment(head(tail(list))) ;
       END ; (* numeric_increment *)

      BEGIN
       total_cases := 0 ;
       px := example_list ;
       WHILE px <> NIL DO
        BEGIN
         py := head(px) ;
         numeric_increment(class_list,string_val(head(element(py,elem_no))),
                  string_val(head(py))) ;
         px := tail(px) ;
        END ;
      END ; (* count_numeric_classes *)

     BEGIN
      num_entropy := 1.0E+37 ;
      make_num_list ;
      sp := tail(num_list) ;
      saved_list := cons(num_list,saved_list) ;
      WHILE sp <> NIL DO
       BEGIN
        test_memory ;
        sp_val := num_val(head(num_list))
                  + ((num_val(head(sp)) - num_val(head(num_list))) / 2.0) ;
        make_numeric_class_list(sp_val) ;
        count_numeric_classes(sp_val,elem_no) ;
        num_ent := entropy(class_list,total_cases) ;
        IF num_ent < num_entropy
         THEN
          BEGIN
           num_entropy := num_ent ;
           num_split_value := sp_val ;
          END ;
        num_list := sp ;
        sp := tail(sp) ;
       END ;
      saved_list := tail(saved_list) ;
     END ; (* numeric_entropy *)

    PROCEDURE symbol_entropy(val_list : node_ptr ; elem_no : counter ;
                             VAR sym_ent,sym_split_val : real) ;
     (* Find the entropy for a symbolic attribute. val_list is the list
        of possible values for this attribute from the attrib_list.
        elem_no is the column number, sym_ent is the entropy for this attribute.
        sym_split_value is always 0. This routine constructs a class list
        as described above and counts the classes for each value of the
        attribute as in the numeric case, only there is no range splitting.
        Symbolic attributes can result in mult-way partitions of the
        example_list, numerical attributes always produce binary splits.  *)
     VAR
      class_list : node_ptr ;
      total_cases : counter ;

     PROCEDURE make_class_list(a_list : node_ptr) ;
      (* builds the initial class list. See above comments for format. *)
      VAR
       temp_list,p : node_ptr ;
      BEGIN
       WHILE a_list <> NIL DO
        BEGIN
         temp_list := cons(head(a_list),NIL) ;
         p := tail(head(attrib_list)) ;
         WHILE p <> NIL DO
          BEGIN
          temp_list := append_list(temp_list,cons(cons(head(p),
                                                   cons(alloc_num(0.0),NIL)),NIL)) ;
           p := tail(p) ;
          END ;
         class_list := append_list(class_list,cons(temp_list,NIL)) ;
         a_list := tail(a_list) ;
        END ;
      END ; (* make_class_list *)

     PROCEDURE count_classes(elem_no : counter) ;
      (* traverses the example_list and counts class values. *)
      VAR
       px,py : node_ptr ;

      PROCEDURE increment(list : node_ptr ; attr,v : string80) ;
       (* search list (class_list) and compare attr to the head of each sub-list.
          v is the class_value. Once we find the sub-list with the proper
          range we search its tail for v to increment the class count.   *)
       VAR
        p,q : node_ptr ;
       BEGIN
        WHILE list <> NIL DO
         IF string_val(head(head(list))) = attr
          THEN
           BEGIN
            q := tail(head(list)) ;
            WHILE q <> NIL DO
             IF string_val(head(head(q))) = v
              THEN
               BEGIN
                p := head(tail(head(q))) ;
                IF tag_value(p) = number
                 THEN p^.num_data := p^.num_data + 1.0 ;
                total_cases := total_cases + 1 ;
                list := NIL ;
                q := NIL ;
               END
              ELSE q := tail(q) ;
           END
          ELSE list := tail(list) ;
        END ; (* increment *)

      BEGIN
       total_cases := 0 ;
       px := example_list ;
       WHILE px <> NIL DO
        BEGIN
         py := head(px) ;
         increment(class_list,string_val(head(element(py,elem_no))),
                  string_val(head(py))) ;
         px := tail(px) ;
        END ;
      END ; (* count_classes *)

     BEGIN
      class_list := NIL ;
      make_class_list(val_list) ;
      count_classes(elem_no) ;
      sym_ent := entropy(class_list,total_cases) ;
      sym_split_val := 0.0
     END ; (* symbol_entropy *)

    BEGIN
     min_entropy := 1.0E+37 ;
     FOR i := 2 TO no_of_cols DO
      BEGIN
       test_memory ;
       attrib := head(element(attrib_list,i)) ;
       IF NOT on_list(string_val(head(attrib)),chosen_list)
        THEN
         BEGIN
          IF pos(':NUMBER',toupper(string_val(head(attrib)))) > 0
           THEN numeric_entropy(i,ent,split_value)
           ELSE symbol_entropy(tail(attrib),i,ent,split_value) ;
          IF ent < min_entropy
           THEN
            BEGIN
             min_entropy := ent ;
             split_elem := i ;
             min_split_value := split_value ;
            END ;
         END ;
      END ;
    END ; (* find_split *)

   FUNCTION split(elem_no : counter ; split_val : real) : node_ptr ;
    (* This routine splits the example_list into sets which contain a single
       value of the split attribute. elem_no is the column on which to split.
       split_val is the split value for numerical attributes.
       split_item points to the attribute's entry in the attribute list.
       split_list is the tree which is returned by split. Its format is
       (attribute_name (value1 classify(partition with attribute = value1)
                       (value2 classify(partition with attribute = value2)
                       ....... )    *)
     VAR
     split_list,split_item,new_chosen : node_ptr ;

    PROCEDURE numeric_split ;
     (* Splitting on a numerical attribute splits the examples into
        two groups, those with values < split_value and those with
        values >= split_value. new_list1 and new_list2 are the example
        sets for the two categories. It returns a split_list as follows:
        (attribute_name ('< split_val'
                         classify(all examples with attribute value < split_val)
                        ('>= split_val'
                         classify(all examples with attribute value >= split_val))
        Notice all the lists placed on the saved_list. These are the items
        that we must retain should any of the calls to classify invoke garbage
        collection *)
     VAR
      new_list1,new_list2,q,valu : node_ptr ;
      split_str : string80 ;
     BEGIN
      str(split_val,split_str) ;
      valu := cons(alloc_str(concat('< ',split_str)),
                   cons(alloc_str(concat('>= ',split_str)),NIL)) ;
      q := example_list ;
      new_list1 := NIL ;
      new_list2 := NIL ;
      WHILE q <> NIL DO
       BEGIN
        IF num_val(head(element(head(q),elem_no))) < split_val
         THEN new_list1 := append_list(new_list1,cons(head(q),NIL))
         ELSE new_list2 := append_list(new_list2,cons(head(q),NIL)) ;
        q := tail(q) ;
       END ;
      saved_list := cons(split_list,cons(valu,cons(new_list2,saved_list))) ;
      split_list := append_list(split_list,
                              cons(cons(head(valu),
                              cons(classify(new_list1,chosen_list),NIL)),NIL)) ;
      saved_list := cons(split_list,tail(saved_list)) ;
      split_list := append_list(split_list,
                              cons(cons(head(tail(valu)),
                              cons(classify(new_list2,chosen_list),NIL)),NIL)) ;
      saved_list := tail(tail(tail(saved_list))) ;
     END ; (* numeric_split *)

    PROCEDURE symbol_split ;
     (* performs the split for symbolic attributes. For each value of the
        attribute, it searches the example list for matches and attaches
        examples with a match to new_example_list. If it finds any matches
        it appends the value and the result of classifying the new_example_list
        to split_list. This is a very inefficient way of doing this. It
        would be better to sort the example_list using column elem_no as
        a key.   *)
     VAR
      valu,q,new_example_list : node_ptr ;
     BEGIN
      valu := tail(split_item) ;
      WHILE valu <> NIL DO
       BEGIN
        q := example_list ;
        new_example_list := NIL ;
        WHILE q <> NIL DO
         BEGIN
          IF string_val(head(valu)) = string_val(head(element(head(q),elem_no)))
           THEN new_example_list := append_list(new_example_list,cons(head(q),NIL)) ;
          q := tail(q) ;
         END ;
        IF new_example_list <> NIL
         THEN
          BEGIN
           saved_list := cons(split_list,saved_list) ;
           split_list := append_list(split_list,
                                     cons(cons(head(valu),
                                     cons(classify(new_example_list,new_chosen),NIL)),
                                     NIL)) ;
           saved_list := tail(saved_list) ;
          END ;
        valu := tail(valu) ;
       END ;
     END ; (* symbol_split *)

    BEGIN
     split_item := head(element(attrib_list,elem_no)) ;
     new_chosen := cons(head(split_item),chosen_list) ;
     split_list := cons(head(split_item),NIL) ;
     IF pos(':NUMBER',toupper(string_val(head(split_item)))) > 0
      THEN numeric_split
      ELSE symbol_split ;
     split := split_list ;
    END ; (* split *)

   FUNCTION single_class : boolean ;
    (* returns true if the example_list contains only a single class value. *)
    VAR
     first_val : string80 ;
     p : node_ptr ;
     more_than_one : boolean ;
    BEGIN
     first_val := string_val(head(head(example_list))) ;
     more_than_one := false ;
     p := tail(example_list) ;
     WHILE (p <> NIL) AND (NOT more_than_one) DO
      IF string_val(head(head(p))) <> first_val
       THEN more_than_one := true
       ELSE p := tail(p) ;
     single_class := NOT more_than_one ;
    END ; (* single_class *)

   BEGIN
    write('.') ;
    split_elem := 0 ;
    saved_list := cons(chosen_list,cons(example_list,saved_list)) ;
    IF NOT single_class
     THEN find_split(split_elem,split_value) ;
    IF split_elem = 0
     THEN classify_list := cons(head(head(attrib_list)),
                                cons(cons(head(head(example_list)),NIL),NIL))
     ELSE classify_list := split(split_elem,split_value) ;
    saved_list := append_list(tail(tail(saved_list)),cons(classify_list,NIL)) ;
    classify := classify_list ;
   END ; (* classify *)

  BEGIN
   classify_it := classify(examples,NIL) ;
  END ; (* classify_it *)


 OVERLAY PROCEDURE print_rule_list(list : node_ptr) ;
  (* This routine transforms the tree into a set of IF/THEN statements and
     writes them to a file. It produces a knowledge base for MicroExpert [c],
     if you want to produces rules for another shell, this routine will
     have to be modified.  *)
  VAR
   rule_count : counter ;
   rule_file : text_file ;
   file_name : string80 ;
   used_attribs : node_ptr ;

  PROCEDURE print_rule(tree,rule_list : node_ptr) ;
   (* Do a depth first traversal of tree. On entry rule_list contains a
      list of attribute value pairs. When tree is finally NIL, i.e. a
      terminal node of the tree has been encountered, the rule_list is
      printed. If entered with a non-NIL tree, the routine creates a new
      attribute value pair, attaches it to rule_list and explores further
      down the tree. It also attaches the attribute names to used_attribs
      so that they can be used to generate prompts. *)
   VAR
    p : node_ptr ;

   PROCEDURE print_the_rule(list : node_ptr) ;
    (* Prints the rule_list, with rules formatted for MicroExpert. *)
    VAR
     s : string80 ;

    PROCEDURE write_compare ;
     VAR
      comp_str : string[2] ;

     FUNCTION quote(w : string80) : string80 ;
      BEGIN
       quote := '''' + w + '''' ;
      END ; (* quote *)

     BEGIN
      comp_str := '' ;
      WHILE s[1] <> ' ' DO
       BEGIN
        comp_str := comp_str + s[1] ;
        delete(s,1,1) ;
       END ;
      strip_leading_blanks(s) ;
      strip_trailing_blanks(s) ;
      writeln(rule_file,'function compare(',attrib_value(head(head(list))),
              ',',quote(comp_str),',',quote(s),')') ;
     END ; (* write_compare *)

    BEGIN
     writeln(rule_file,rule_count) ;
     rule_count := rule_count + 1 ;
     write(rule_file,'If   ') ;
     WHILE list <> NIL DO
      BEGIN
       s := string_val(head(tail(head(list)))) ;
       IF s[1] IN ['<','>']
        THEN write_compare
        ELSE writeln(rule_file,attrib_value(head(head(list))),' is ',s) ;
       list := tail(list) ;
       IF list <> NIL
        THEN
         IF tail(list) = NIL
          THEN write(rule_file,'then ')
          ELSE write(rule_file,'and  ') ;
      END ;
     writeln(rule_file,'.') ;
     writeln(rule_file) ;
    END ; (* print_the_rule *)

   BEGIN
    IF tree = NIL
     THEN print_the_rule(rule_list)
     ELSE
      BEGIN
       IF head(tree) <> head(head(attrib_list))
        THEN
         IF NOT on_list(string_val(head(tree)),used_attribs)
          THEN used_attribs := cons(head(tree),used_attribs) ;
       p := tail(tree) ;
       WHILE p <> NIL DO
        BEGIN
         print_rule(head(tail(head(p))),
                    append_list(rule_list,cons(cons(head(tree),
                                               cons(head(head(p)),NIL)),
                                               NIL))) ;
         p := tail(p) ;
        END ;
      END ;
   END ; (* print_rule *)

  PROCEDURE print_prompts ;
   (* This routine traverses the attribute list and writes a prompt for
      each attribute on the list. MicroExpert does not automatically
      generate prompts, so this is necessary. The format
      of the questions may seem dumb. For a working knowledge base, you
      will want to edit the prompts and add translations.  *)
    VAR
     q : node_ptr ;
   BEGIN
    q := used_attribs ;
    WHILE q <> NIL DO
     BEGIN
      writeln(rule_file) ;
      IF pos(':NUMBER',toupper(string_val(head(q)))) > 0
       THEN writeln(rule_file,'Numeric prompt ',attrib_value(head(q)))
       ELSE writeln(rule_file,'Prompt ',attrib_value(head(q))) ;
      writeln(rule_file,'What is the value of ',attrib_value(head(q)),' ?') ;
      writeln(rule_file,'.') ;
      q := tail(q) ;
     END ;
   END ; (* print_prompts *)

  BEGIN
   writeln ;
   write('Output the rules to what file (Press <ENTER> for screen.) ? ') ;
   readln(file_name) ;
   strip_leading_blanks(file_name) ;
   IF file_name = ''
    THEN file_name := 'con:' ;
   assign(rule_file,file_name) ;
   rewrite(rule_file) ;
   writeln(rule_file) ;
   rule_count := 1 ;
   used_attribs := NIL ;
   print_rule(list,NIL) ;
   print_prompts ;
   IF is_console(rule_file)
    THEN wait ;
   close(rule_file) ;
  END ; (* print_rule_list *)


 OVERLAY PROCEDURE print_tree(list : node_ptr) ;
  (* Print the tree. This is really just a pretty print routine, which
     indents each sub_list. *)
  VAR
   indent_level : counter ;
   tree_file : text_file ;
   file_name : string80 ;

  PROCEDURE print_the_tree(tree : node_ptr ; VAR indent : counter) ;
   VAR
    p : node_ptr ;
   BEGIN
    IF tree <> NIL
     THEN
      CASE tree^.tag OF
       number,
       symbol    : BEGIN
                    write(tree_file,attrib_value(tree),' ') ;
                    indent := indent + length(attrib_value(tree)) + 1 ;
                   END ;
       cons_node : BEGIN
                    write(tree_file,'(') ;
                    indent := indent + 1 ;
                    print_the_tree(head(tree),indent) ;
                    p := tail(tree) ;
                    WHILE p <> NIL DO
                     BEGIN
                      print_the_tree(head(p),indent) ;
                      IF list_length(p) > 1
                       THEN
                        BEGIN
                         writeln(tree_file) ;
                         write(tree_file,' ' : indent) ;
                        END ;
                      p := tail(p) ;
                     END ;
                    indent := indent - length(attrib_value(head(tree))) - 2 ;
                    write(tree_file,') ') ;
                   END ;
      END ;
   END ; (* print_the_tree *)

  BEGIN
   writeln ;
   write('Output the tree to what file (Press <ENTER> for screen.) ? ') ;
   readln(file_name) ;
   strip_leading_blanks(file_name) ;
   IF file_name = ''
    THEN file_name := 'con:' ;
   assign(tree_file,file_name) ;
   rewrite(tree_file) ;
   writeln(tree_file) ;
   indent_level := 0 ;
   print_the_tree(list,indent_level) ;
   writeln(tree_file) ;
   writeln(tree_file) ;
   IF is_console(tree_file)
    THEN wait ;
   close(tree_file) ;
  END ; (* print_tree *)


 OVERLAY FUNCTION got_file : boolean ;
  (* asks for an example file name and tries to open it. If it can't
     open the file, it complains and asks for a new file *)
  VAR
   example_name : string80 ;
  BEGIN
   writeln ;
   write('Example File (Press <ENTER> to quit.) : ') ;
   readln(example_name) ;
   IF example_name = ''
    THEN got_file := false
    ELSE
     BEGIN
      IF pos('.',example_name) = 0
       THEN example_name := concat(example_name,'.EX') ;
      IF open(example_file,example_name)
       THEN got_file := true
       ELSE
        BEGIN
         writeln ;
         writeln(toupper(example_name),' could not be found.') ;
         writeln ;
         got_file := got_file ;
        END ;
     END ;
  END ; (* got_file *)


 BEGIN
  free := NIL ;
  initial_heap := HeapPtr ;
  total_free := 0.0 ;
  clrscr ;
  WHILE got_file DO
   BEGIN
    build_table ;
    close(example_file) ;
    IF NOT conflicts(examples)
     THEN
      BEGIN
       saved_list := cons(attrib_list,examples) ;
       expand(examples,examples) ;
       writeln ;
       saved_list := cons(attrib_list,examples) ;
       c_list := classify_it ;
       saved_list := cons(c_list,attrib_list) ;
       writeln ;
       test_memory ;
       print_tree(c_list) ;
       writeln ;
       test_memory ;
       writeln ;
       print_rule_list(c_list) ;
       clrscr ;
      END ;
   END ;
 END.




==================================================

                    INDUCE.INC

==================================================



(* ----------------------------------------------------------------------
        Utility Routines
   ---------------------------------------------------------------------- *)

 FUNCTION open(VAR f : text_file ; f_name : string80) : boolean ;
  (* open a file - returns true if the file exists and was opened properly
     f      - file pointer
     f_name - external name of the file *)
  BEGIN
   assign(f,f_name) ;
   (*$I- *)
   reset(f) ;
   (*$I+ *)
   open := (ioresult = 0) ;
  END ; (* open *)


 FUNCTION is_console(VAR f : text_file) : boolean ;
  (* return true if f is open on the system console
     for details of fibs and fib_ptrs see the Turbo Pascal ver 3.0 reference
     manual chapter 20. This should work under CP/M-86 or 80, but we haven't
     tried it. *)
  TYPE
   fib = ARRAY [0 .. 75] OF byte ;
  VAR
   fib_ptr : ^fib ;
   dev_type : byte ;
  BEGIN
   fib_ptr := addr(f) ;
   dev_type := fib_ptr^[2] AND $07 ;
   is_console := (dev_type = 1) OR (dev_type = 2) ;
  END ; (* is_console *)


 PROCEDURE strip_leading_blanks(VAR s : string80) ;
  BEGIN
   IF length(s) > 0
    THEN
     IF (s[1] = ' ') OR (s[1] = tab)
      THEN
       BEGIN
        delete(s,1,1) ;
        strip_leading_blanks(s) ;
       END ;
  END ; (* strip_leading_blanks *)


 PROCEDURE strip_trailing_blanks(VAR s : string80) ;
  BEGIN
   IF length(s) > 0
    THEN
     IF (s[length(s)] = ' ') OR (s[length(s)] = tab)
      THEN
       BEGIN
        delete(s,length(s),1) ;
        strip_trailing_blanks(s) ;
       END ;
  END ; (* strip_trailing_blanks *)



 FUNCTION toupper(s : string80) : string80 ;
  (* returns s converted to upper case *)
  VAR
   i : byte ;
  BEGIN
   IF length(s) > 0
    THEN
     FOR i := 1 TO length(s) DO
      s[i] := upcase(s[i]) ;
   toupper := s ;
  END ; (* toupper *)


 FUNCTION toreal(s : string80) : real ;
  (* converts s to a real number
     This routine uses the Turbo intrinsic val to do the conversion.
     If s does not contain a legal representation of a number, it returns
     0.0  *)
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   val(s,num,code) ;
   IF code = 0
    THEN toreal := num
    ELSE toreal := 0 ;
  END ; (* toreal *)


 FUNCTION is_number(s : string80) : boolean ;
  (* checks to see if s contains a legitimate numerical string.
     It ignores leading and trailing blanks *)
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   IF s <> ''
    THEN val(s,num,code)
    ELSE code := -1 ;
   is_number := (code = 0) ;
  END ; (* is_number *)


 FUNCTION head(list : node_ptr) : node_ptr ;
  (* returns a pointer to the first item in the list.
     If the list is empty, it returns NIL.  *)
  BEGIN
   IF list = NIL
    THEN head := NIL
    ELSE head := list^.head_ptr ;
  END ; (* head *)


 FUNCTION tail(list : node_ptr) : node_ptr ;
  (* returns a pointer to a list starting at the second item in the list.
     Note - tail( (a b c) ) points to the list (b c), but
            tail( ((a b) c d) ) points to the list (c d) .  *)
  BEGIN
   IF list = NIL
    THEN tail := NIL
   ELSE
    CASE list^.tag OF
     cons_node : tail := list^.tail_ptr ;
     free_node : tail := list^.next_free ;
     ELSE        tail := NIL ;
    END ;
  END ; (* tail *)


 FUNCTION element(list : node_ptr ; elem_no : counter) : node_ptr ;
  (* returns a pointer to the element number elem_no in the list.
     element(list,1) points to list.
     element(list,2) is the same as tail(list).    *)
  VAR
   i : counter ;
  BEGIN
   FOR i := 1 TO elem_no - 1 DO
    list := tail(list) ;
   element := list ;
  END ; (* element *)


 FUNCTION allocation_size(x : counter) : counter ;
  (* Turbo 3.0 allocates memory in 8 byte blocks, this routine calculates the
     actual number of bytes returned for a request of x bytes.  *)
  BEGIN
   allocation_size := (((x - 1) DIV 8) + 1) * 8 ;
  END ; (* allocation_size *)


 FUNCTION node_size : counter ;
  (* calculates the base size of a node. Add the rest of the node to this
     to get the actual size of a node *)
  BEGIN
   node_size := 2 * sizeof(node_ptr) + sizeof(boolean) + sizeof(node_type) ;
  END ; (* node_size *)


 FUNCTION normalize(pt : node_ptr) : node_ptr ;
  (* returns a normalized pointer. Pointers are 32 bit addresses. The first
     16 bits contain the segment number and the second 16 bits contain the
     offset within the segment. Normalized pointers have offsets in the range
     $0 to $F (0 .. 15)    *)
  VAR
   pt_seg,pt_ofs : integer ;
  BEGIN
   pt_seg := seg(pt^) + (ofs(pt^) DIV 16) ;
   pt_ofs := ofs(pt^) MOD 16 ;
   normalize := ptr(pt_seg,pt_ofs) ;
  END ; (* normalize *)


 FUNCTION string_val(list : node_ptr) : string80 ;
  (* returns the string pointed to by list. If list points to a number
     node, it returns a string representing that number *)
  VAR
   s : string[15] ;
  BEGIN
   IF list = NIL
    THEN string_val := ''
   ELSE IF list^.tag = symbol
    THEN string_val := list^.string_data
   ELSE IF list^.tag = number
    THEN
     BEGIN
      str(list^.num_data : 14,s) ;
      string_val := s ;
     END
   ELSE string_val := '' ;
  END ; (* string_val *)


 FUNCTION num_val(list : node_ptr) : real ;
  (* returns the number pointed to by list. If list points to a string,
     it returns the numerical value of the string.   *)
  VAR
   s : string80 ;
   code : integer ;
   r : real ;
  BEGIN
   IF list = NIL
    THEN num_val := 0.0
   ELSE IF list^.tag = number
    THEN num_val := list^.num_data
   ELSE IF list^.tag = symbol
    THEN num_val := toreal(list^.string_data)
   ELSE num_val := 0.0 ;
  END ; (* num_val *)


 FUNCTION attrib_value(p : node_ptr) : string80 ;
  (* This routine is used by print_rule and print_tree to strip off
     ':number' from an attribute name.   *)
  BEGIN
   IF pos(':NUMBER',toupper(string_val(p))) > 0
    THEN attrib_value := copy(string_val(p),
                 1,pos(':NUMBER',toupper(string_val(p))) - 1)
    ELSE attrib_value := string_val(p) ;
  END ; (* attrib_value *)


 FUNCTION tag_value(list : node_ptr) : node_type ;
  (* returns the value of the tag for a node.     *)
  BEGIN
   IF list = NIL
    THEN tag_value := free_node
    ELSE tag_value := list^.tag ;
  END ; (* tag_value *)


 FUNCTION match_lists(list1,list2 : node_ptr) : boolean ;
  (* returns true if list1 and list2 are identical.
     Two lists are identical if they are both NIL or if their heads match
     and match_lists returns true for thier tails. *)
  BEGIN
   IF (list1 = NIL) AND (list2 = NIL)
    THEN match_lists := true
   ELSE IF (list1 = NIL) OR (list2 = NIL)
    THEN match_lists := false
   ELSE IF tag_value(head(list1)) <> tag_value(head(list2))
    THEN match_lists := false
   ELSE
    CASE tag_value(head(list1)) OF
     symbol    : IF string_val(head(list1)) = string_val(head(list2))
                  THEN match_lists := match_lists(tail(list1),tail(list2))
                  ELSE match_lists := false ;
     number    : IF num_val(head(list1)) = num_val(head(list2))
                  THEN match_lists := match_lists(tail(list1),tail(list2))
                  ELSE match_lists := false ;
     cons_node : IF match_lists(head(list1),head(list2))
                  THEN match_lists := match_lists(tail(list1),tail(list2))
                  ELSE match_lists := false ;
    END ;
  END ; (* match_lists *)


 FUNCTION on_list(s : string80 ; list : node_ptr) : boolean ;
  (* checks to see if s is on the list, list. s is on the list if it
     matches the head of the list or if on_list(tail(list)) returns true.  *)
  BEGIN
   IF list = NIL
    THEN on_list := false
   ELSE IF s = string_val(head(list))
    THEN on_list := true
   ELSE on_list := on_list(s,tail(list)) ;
  END ; (* on_list *)


 PROCEDURE print_list(list : node_ptr) ;
  (* recursively traverses the list and prints its elements. This is
     not a pretty printer, so the lists may look a bit messy.  *)
  VAR
   p : node_ptr ;
  BEGIN
   IF list <> NIL
    THEN
     CASE list^.tag OF
      symbol    : write(string_val(list),' ') ;
      number    : write(num_val(list) : 6,' ') ;
      cons_node : BEGIN
                   write('(') ;
                   p := list ;
                   WHILE p <> NIL DO
                    BEGIN
                     print_list(head(p)) ;
                     p := tail(p) ;
                    END ;
                   write(') ') ;
                  END ;
     END ;
  END ; (* print_list *)


 PROCEDURE get_memory(VAR p : node_ptr ; size : counter) ;
  (* On exit p contains a pointer to a block of allocation_size(size) bytes.
     If possible this routine tries to get memory from the free list before
     requesting it from the heap *)
  VAR
   blks : counter ;
   allocated : boolean ;

  PROCEDURE get_from_free(VAR list : node_ptr) ;
   (* Try and get need memory from the free list. This routine uses a
      first-fit algorithm to get the space. It takes the first free block it
      finds with enough storage. If the free block has more storage than was
      requested, the block is shrunk by the requested amount.  *)
   BEGIN
    IF list <> NIL
     THEN
      IF list^.block_cnt >= (blks - 1)
       THEN
        BEGIN
         p := normalize(ptr(seg(list^),ofs(list^) +
                                       (list^.block_cnt - blks + 1) * 8)) ;
         IF list^.block_cnt = blks - 1
          THEN list := list^.next_free
          ELSE list^.block_cnt := list^.block_cnt - blks ;
         allocated := true ;
         total_free := total_free - (blks * 8.0) ;
        END
       ELSE get_from_free(list^.next_free) ;
   END ; (* get_from_free *)

  BEGIN
   blks := ((size - 1) DIV 8) + 1 ;
   allocated := false ;
   get_from_free(free) ;
   IF NOT allocated
    THEN getmem(p,blks * 8) ;
  END ; (* get_memory *)


 FUNCTION alloc_str(s : string80) : node_ptr ;
  (* Allocate storage for a string and return a pointer to the new node.
     This routine only allocates enough storage for the actual number of
     characters in the string plus one for the length. Because of this,
     concatenating anything to the end of a string stored in a symbol node
     will lead to disaster. Copy the string to a new string do the
     concatenation and then allocate a new node.  *)
  VAR
   pt : node_ptr ;
  BEGIN
   get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
                                 length(s) + 1)) ;
   pt^.tag := symbol   ;
   pt^.string_data := s ;
   alloc_str := pt ;
  END ; (* alloc_str *)


 FUNCTION alloc_num(r : real) : node_ptr ;
  (* Allocate storage for a real number and return a pointer to the new node. *)
  VAR
   pt : node_ptr ;
  BEGIN
   get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
                                 sizeof(real))) ;
   pt^.tag := number ;
   pt^.num_data := r ;
   alloc_num := pt ;
  END ; (* alloc_num *)


 FUNCTION cons(new_node,list : node_ptr) : node_ptr ;
  (* Construct a list. This routine allocates storage for a new cons node.
     new_node points to the new head of the list. The tail pointer of the
     new node points to list. This routine adds the new cons node to the
     beginning of the list and returns a pointer to it. The list described
     in the comments at the beginning of the program could be constructed
     as cons(alloc_str('A'),cons(alloc_str('B'),cons(alloc_str('C'),NIL))). *)
  VAR
   p : node_ptr ;
  BEGIN
   get_memory(p,allocation_size(node_size)) ;
   p^.tag := cons_node ;
   p^.head_ptr := new_node ;
   p^.tail_ptr := list ;
   cons := p ;
  END ; (* cons *)


 FUNCTION append_list(list1,list2 : node_ptr) : node_ptr ;
  (* Append list2 to list1. This routine returns a pointer to the
     combined list. Appending is done by consing each item on the first
     list to the second list. This routine is one of the major sources of
     garbage so if garbage collection becomes a problem, you may want to
     rewrite it. *)
  BEGIN
   IF list1 = NIL
    THEN append_list := list2
    ELSE append_list := cons(head(list1),append_list(tail(list1),list2)) ;
  END ; (* append_list *)


 FUNCTION list_length(list : node_ptr) : counter ;
  (* returns the length of a list.
     Note - both (A B C) and ( (A B) C D) have length 3.   *)
  BEGIN
   IF list = NIL
    THEN list_length := 0
    ELSE list_length := 1 + list_length(list^.tail_ptr) ;
  END ; (* list_length *)


 FUNCTION copy_list(list : node_ptr) : node_ptr ;
  (* Returns a pointer to a copy of list. This routine allocates new nodes
     for each item in the original list *)
  BEGIN
   IF list = NIL
    THEN copy_list := NIL
    ELSE
     CASE tag_value(list) OF
      cons_node : copy_list := cons(copy_list(head(list)),copy_list(tail(list))) ;
      number    : copy_list := alloc_num(num_val(list)) ;
      symbol    : copy_list := alloc_str(string_val(list)) ;
     END ;
  END ; (* copy_list *)


 PROCEDURE collect_garbage ;
  (* This routine is specific to Turbo Pascal Ver 3.01
     It depends upon the fact that Turbo allocates memory in 8 byte blocks
     on the PC. If you recompile this program on another system be very
     careful with this routine.
     Garbage collection proceeds in three phases:
      unmark  - free all memory between the initial_heap^ and the current
                top of the heap.
      mark    - mark everything on the saved_list as being in ues.
      release - gather all unmarked blocks and put them on the free list.
     The collector displays a '*' on the screen to let you know it is
      operating.  *)

  FUNCTION lower(p1,p2 : node_ptr) : boolean ;
   (* returns true if p1 points to a lower memory address than p2 *)
   BEGIN
    p1 := normalize(p1) ;
    p2 := normalize(p2) ;
    lower := (seg(p1^) < seg(p2^)) OR
              ((seg(p1^) = seg(p2^)) AND (ofs(p1^) < ofs(p2^))) ;
   END ; (* lower *)

  PROCEDURE mark(list : node_ptr) ;
   (* Mark the blocks on list as being in use. Since a node may be on several
      lists at one time, if it is already marked we don't continue processing
      the tail of the list. *)
   BEGIN
    IF list <> NIL
     THEN
      BEGIN
       IF NOT list^.in_use
        THEN
         BEGIN
          list^.in_use := true ;
          IF list^.tag = cons_node
           THEN
            BEGIN
             mark(head(list)) ;
             mark(tail(list)) ;
            END ;
         END ;
      END ;
   END ; (* mark *)

  PROCEDURE unmark_mem ;
   (* Go through memory from initial_heap^ to HeapPtr^ and mark each node
      as not in use. The tricky part here is updating the pointer p to point
      to the next cell. *)
   VAR
    p : node_ptr ;
    string_base,node_allocation : counter ;
   BEGIN
    string_base := sizeof(node_type) + sizeof(boolean) ;
    p := normalize(initial_heap) ;
    node_allocation := allocation_size(node_size) ;
    WHILE lower(p,HeapPtr) DO
     BEGIN
      p^.in_use := false ;
      CASE p^.tag OF
       cons_node : p := normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ;
       free_node : p := normalize(ptr(seg(p^),ofs(p^) + (p^.block_cnt + 1) * 8)) ;
       number    : p := normalize(ptr(seg(p^),
                                  ofs(p^) +
                                  allocation_size(string_base + sizeof(real)))) ;
       symbol    : p := normalize(ptr(seg(p^),
                                  ofs(p^) +
                                  allocation_size(string_base +
                                                  length(p^.string_data) + 1))) ;
      END ;
     END ;
   END ; (* unmark_mem *)

  PROCEDURE release_mem ;
   (* This procedure does the actual collection and compaction of nodes.
      This is the slow phase of garbage collection because of all the pointer
      manipulation.  *)
   VAR
    heap_top : node_ptr ;
    string_base,node_allocation,string_allocation,block_allocation : counter ;

   PROCEDURE free_memory(pt : node_ptr ; size : counter) ;
    (* return size bytes pointed to by pt to the free list. If pt points to
       a block next to the head of the free list combine it with the top
       free node. total_free keeps track of the total number of free bytes. *)
    VAR
     blks : counter ;
    BEGIN
     blks := ((size - 1) DIV 8) + 1 ;
     pt^.tag := free_node ;
     IF normalize(ptr(seg(pt^),ofs(pt^) + 8 * blks)) = free
      THEN
       BEGIN
        pt^.next_free := free^.next_free ;
        pt^.block_cnt := free^.block_cnt + blks ;
        free := pt ;
       END
     ELSE IF normalize(ptr(seg(free^),ofs(free^) + 8 * (free^.block_cnt + 1))) =
             normalize(pt)
      THEN free^.block_cnt := free^.block_cnt + blks
     ELSE
      BEGIN
       pt^.next_free := free ;
       pt^.block_cnt := blks - 1 ;
       free := pt ;
      END ;
     total_free := total_free + (blks * 8.0) ;
    END ; (* free_memory *)

   PROCEDURE do_release ;
    (* This routine sweeps through memory and checks for nodes with
       in_use = false. *)
    VAR
     p : node_ptr ;
    BEGIN
     p := normalize(initial_heap) ;
     WHILE lower(p,heap_top) DO
      CASE p^.tag OF
       cons_node : BEGIN
                    IF NOT p^.in_use
                     THEN free_memory(p,node_size) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ;
                   END ;
       free_node : BEGIN
                    block_allocation := (p^.block_cnt + 1) * 8 ;
                    free_memory(p,block_allocation) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + block_allocation)) ;
                   END ;
       number    : BEGIN
                    block_allocation := allocation_size(string_base +
                                                        sizeof(real)) ;
                    IF NOT p^.in_use
                     THEN free_memory(p,block_allocation) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + block_allocation)) ;
                   END ;
       symbol    : BEGIN
                    string_allocation := allocation_size(string_base +
                                                length(p^.string_data) + 1) ;
                    IF NOT p^.in_use
                     THEN free_memory(p,string_base + length(p^.string_data)
                                      + 1) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + string_allocation)) ;
                   END ;
      END ;
    END ; (* do_release *)

   BEGIN
    free := NIL ;
    total_free := 0.0 ;
    heap_top := HeapPtr ;
    string_base := sizeof(node_type) + sizeof(boolean) ;
    node_allocation := allocation_size(node_size) ;
    do_release ;
   END ; (* release_mem *)

  BEGIN
   write('*') ;
   unmark_mem ;
   mark(saved_list) ;
   release_mem ;
   write(back_space) ;
   clreol ;
  END ; (* collect_garbage *)


 PROCEDURE test_memory ;
  (* This routine activates the garbage collector, if the the total available
     memory (free_list + heap) is less than a specified amount. Lowering the
     minimum causes garbage collection to be called less often, but if you
     make it too small you may not have enough room left for recursion or any
     temporary lists you need. Using 10000 is probably being overly
     cautious.   *)
  BEGIN
   IF (memavail * 16.0) + total_free < 10000
    THEN collect_garbage ;
  END ; (* test_memory *)


 PROCEDURE wait ;
  (* Just like it says. It waits for the user to press a key before
     continuing. *)
  VAR
   ch : char ;
  BEGIN
   writeln ;
   writeln ;
   write('Press any key to continue. ') ;
   read(kbd,ch) ;
   write(return) ;
   clreol ;
  END ; (* wait *)


(* ------------------------------------------------------------------------
        End of utility routines
   ------------------------------------------------------------------------ *)



==================================================

                    CONFER.TXT

==================================================


@trans broad and flat @
the shape of the leaves is /not/ broad and flat
@
@prompt broad and flat @
Is the shape of the leaves broad and flat ?
@
@trans class @
the botanical class the tree belongs to 
@
@trans leaf shape @
the leaf shape
@
@prompt leaf shape @
Is the leaf shape needlelike or scalelike ?
@ 
@trans family @
the botanical family the tree belongs to
@
@trans even pattern @
the needles do /not/ line up along two sides of the branch
@
@prompt even pattern @
Do the needles grow in two lines along the sides of the branch ?
@
@trans silvery line @
there is /not/ a silvery line underneath the needles
@
@prompt silvery line @
Is there a silvery line underneath the needles ?
@
@trans decurrent @
the stem of the needle does /not/ grow down along the twig
@
@prompt decurrent @
Do the stems of the needles grow down along the twig ?
@
@trans spray shape @
the shape of the leaf spray 
@
@prompt spray shape @
Is the shape of the leaf spray round or flat ?
@
@trans random needles @
there are /not/ a few needles scattered along the branch
@
@prompt random needles @
Are there at least a few needles scattered along the branch ?             
@
@trans bundle @
the needles are /not/ grouped together in bundles of 2 to 5
@
@prompt bundle @
Are the needles grouped together in bundles of 2 to 5 ?
@
@trans needle scar @
the scar left when a needle is removed
@
@prompt needle scar @
Pull a needle off the twig. Is the scar it makes raised or depressed ?
@
@trans cross section @
the cross section of the needle 
@
@prompt cross section @
Pull off a needle.  Is its cross section flat, triangular or 4-sided ?
@
@trans genus @
the botanical genus of the tree
@
1
If broad and flat is yes
then class is angiosperm .
2
If broad and flat is no
then class is gymnosperm .
3
If class is gymnosperm 
and leaf shape is scalelike
then family is cypress .
4
If class is gymnosperm 
and leaf shape is needlelike
and even pattern is no
then family is pine .
5
If class is gymnosperm
and leaf shape is needlelike
and even pattern is yes
and silvery line is yes
then family is pine .
6
If family is cypress  
and spray shape is round    
and random needles is yes
then genus is juniper .
7
If class is gymnosperm
and leaf shape is needlelike
and even pattern is yes
and silvery line is no
and decurrent is no
then family is bald cypress
and genus is bald cypress .
8
If class is gymnosperm 
and leaf shape is needlelike
and even pattern is yes
and silvery line is no
and decurrent is yes
then family is yew
and genus is yew .
 
9
If family is cypress
and spray shape is round
and random needles is no
then genus is white cedar .
10
If family is cypress
and spray shape is flat
then genus is arbor vitae (thuja) .
11
If family is pine
and bundle is yes
then genus is pine .
12
If family is pine
and bundle is no
and silvery line is yes
and needle scar is depressed
then genus is fir .
13
If family is pine
and bundle is no
and silvery line is yes
and needle scar is raised
then genus is hemlock .
14
If family is pine
and bundle is no
and silvery line is no
and cross section is triangular
then genus is larch .
15
If family is pine
and bundle is no
and silvery line is no
and cross section is four sided
then genus is spruce .
16
If family is pine 
and bundle is no
and silvery line is no
and cross section is flat 
then genus is douglas fir .
 







==================================================

                    CONIFERS.TXT

==================================================



@trans broad and flat @
the shape of the leaves is /not/ broad and flat
@

@prompt broad and flat @
Is the shape of the leaves broad and flat ?
@

@trans class @
the botanical class the tree belongs to 
@

@trans leaf shape @
the leaf shape
@

@prompt leaf shape @
Is the leaf shape needlelike or scalelike ?
@ 

@trans family @
the botanical family the tree belongs to
@

@trans even pattern @
the needles do /not/ line up along two sides of the branch
@

@prompt even pattern @
Do the needles grow in two lines along the sides of the branch ?
@

@trans silvery line @
there is /not/ a silvery line underneath the needles
@

@prompt silvery line @
Is there a silvery line underneath the needles ?
@

@trans decurrent @
the stem of the needle does /not/ grow down along the twig
@

@prompt decurrent @
Do the stems of the needles grow down along the twig ?
@

@trans spray shape @
the shape of the leaf spray 
@

@prompt spray shape @
Is the shape of the leaf spray round or flat ?
@

@trans random needles @
there are /not/ a few needles scattered along the branch
@

@prompt random needles @
Arå there at least a few needles scattered along the branch ?             
@

@trans bundle @
the needles are /not/ grouped together in bundles of 2 to 5
@

@prompt bundle @
Are the needles grouped together in bundles of 2 to 5 ?
@

@trans needle scar @
the scar left when a needle is removed
@

@prompt needle scar @
Pull off a needle.  Is the scar that is left raised or depressed ?
@

@trans cross section @
the cross section of the needle 
@

@prompt cross section @
Pull off a needle.  Is its cross section flat, triangular or 4-sided ?
@

@trans genus @
the botanical genus of the tree
@

1
If broad and flat is yes
then class is angiosperm .

2
If broad and flat is no
then class is gymnosperm .

3
If class is gymnosperm 
and leaf shape is scalelike
then family is cypress .

4
If class is gymnosperm 
and leaf shape is needlelike
and even pattern is no
then family is pine .

5
If class is gymnosperm
and leaf shape is needlelike
and even pattern is yes
and silvery line is yes
then family is pine .

6
If family is cypress  
and spray shape is round    
and random needles is yes
then genus is juniper .

7
If class is gymnosperm
and leaf shape is needlelike
and even pattern is yes
and silvery line is no
and decurrent is no
then family is bald cypress
and genus is bald cypress .

8
If class is gymnosperm 
and leaf shape is needlelike
and even pattern is yes
and silvery line is no
and decurrent is yes
then family is yew
and genus is yew .


9
If family is cypress
and spray shape is round
and random needles is no
then genus is white cedar .

10
If family is cypress
and spray shape is flat
then genus is arbor vitae (thuja) .

11
If family is pine
and bundle is yes
then genus is pine .

12
If family is pine
and bundle is no
and silvery line is yes
and needle scar is depressed
then genus is fir .

13
If family is pine
and bundle is no
and silvery line is yes
and needle scar is raised
then genus is hemlock .

14
If family is pine
and bundle is no
and silvery line is no
and cross section is triangular
then genus is larch .

15
If family is pine
and bundle is no
and silvery line is no
and cross section is four sided
then genus is spruce .

16
If family is pine 
and bundle is no
and silvery line is no
and cross section is flat 
then genus is douglas fir .






==================================================

                    RULEXREF.PAS

==================================================


(* Copyright 1984 MicroExpert Systems *)
(*$V- *)
PROGRAM rule_xref ;

 CONST
  word_size = 30 ;
  goal_size = 38 ;
  max_rule = 100 ;


 TYPE
  string80 = string[80] ;
  word = string[word_size] ;
  string1 = string[1] ;
  byte = 0 .. 255 ;
  counter = 0 .. maxint ;
  item_type = (cond,concld) ;
  item_ptr = ^item ;
  string_ptr = ^string_rec ;
  string_rec = RECORD
                info : string80 ;
                next_line : string_ptr ;
               END ;
  item = RECORD
          next : item_ptr ;
          attr : word ;
          CASE boolean OF
           TRUE : ( val : word ;
                    kind : item_type ;
                    rule_no : counter ) ;
           FALSE : ( prompt_ptr : string_ptr ;
                     trans_ptr : string_ptr ;
                     val_ptr : item_ptr) ;
         END ;


 VAR
  line : string80 ;
  rule_file : text ;
  token : word ;
  etx : string1 ;
  free,attr_list : item_ptr ;
  biggest_rule : counter ;


 PROCEDURE toupper(VAR s : string80) ;
  VAR
   i : byte ;
  BEGIN
   IF length(s) > 0
    THEN
     FOR i := 1 TO length(s) DO
      IF s[i] IN ['a' .. 'z']
       THEN s[i] := chr(ord(s[i]) - 32) ;
  END ; (* toupper *)


 PROCEDURE makestr(VAR s : string80 ; len : byte) ;
  VAR
   old_length : byte ;
  BEGIN
   old_length := length(s) ;
   (*$R- *)
   s[0] := chr(len) ;
   (*$R+ *)
   IF old_length < len
    THEN fillchar(s[old_length+1],len - old_length,' ') ;
  END ; (* makestr *)


 FUNCTION tointeger(s : word) : integer ;
  BEGIN
   IF length(s) = 0
    THEN tointeger := 0
   ELSE IF s[1] = '-'
    THEN
     BEGIN
      delete(s,1,1) ;
      tointeger := - tointeger(s) ;
     END
   ELSE IF NOT (s[1] IN ['0' .. '9'])
    THEN
     BEGIN
      delete(s,1,1) ;
      tointeger := tointeger(s) ;
     END
   ELSE IF length(s) = 1
    THEN tointeger := ord(s[1]) - ord('0')
   ELSE tointeger := tointeger(copy(s,length(s),1))
                     + 10 * tointeger(copy(s,1,length(s)-1)) ;
  END ; (* tointeger *)


 PROCEDURE strip_leading_blanks(VAR s : string80) ;
  BEGIN
   IF length(s) > 0
    THEN
     IF s[1] = ' '
      THEN
       BEGIN
        delete(s,1,1) ;
        strip_leading_blanks(s) ;
       END ;
  END ; (* strip_leading_blanks *)


 PROCEDURE strip_trailing_blanks(VAR s : string80) ;
  BEGIN
   IF length(s) > 0
    THEN
     IF s[length(s)] = ' '
      THEN
       BEGIN
        delete(s,length(s),1) ;
        strip_trailing_blanks(s) ;
       END ;
  END ; (* strip_leading_blanks *)


 FUNCTION on_list(s : word ; list : item_ptr ; VAR at : item_ptr) : boolean ;

  FUNCTION find_it(list : item_ptr) : boolean ;
   BEGIN
    IF list = NIL
     THEN find_it := FALSE
    ELSE IF s = list^.attr
     THEN
      BEGIN
       at := list ;
       find_it := TRUE ;
      END
    ELSE find_it := find_it(list^.next) ;
   END ; (* on_list *)

  BEGIN
   at := NIL ;
   toupper(s) ;
   makestr(s,word_size) ;
   on_list := find_it(list) ;
  END ; (* on_list *)


 FUNCTION alloc : item_ptr ;
  VAR
   p : item_ptr ;
  BEGIN
   IF free = NIL
    THEN new(p)
    ELSE
     BEGIN
      p := free ;
      free := free^.next ;
     END ;
   alloc := p ;
  END ; (* alloc *)


 PROCEDURE dispose_item(p : item_ptr) ;
  BEGIN
   p^.next := free ;
   free := p ;
  END ; (* dispose_item *)


 PROCEDURE remove_item(VAR list : item_ptr) ;
  VAR
   p : item_ptr ;
  BEGIN
   IF list <> NIL
    THEN
     BEGIN
      p := list ;
      list := list^.next ;
      dispose_item(p) ;
     END ;
  END ; (* remove_item *)


 PROCEDURE remove_list(VAR list : item_ptr) ;
  BEGIN
   IF list <> NIL
    THEN
     BEGIN
      remove_item(list) ;
      remove_list(list) ;
     END ;
  END ; (* remove_list *)


 PROCEDURE new_item(s1,s2 : string80 ; typ : item_type ;
                    rule_num : counter ; VAR list : item_ptr) ;
  VAR
   p : item_ptr ;
  BEGIN
   makestr(s1,word_size) ;
   toupper(s1) ;
   makestr(s2,word_size) ;
   toupper(s2) ;
   p := alloc ;
   WITH p^ DO
    BEGIN
     attr := s1 ;
     val := s2 ;
     kind := typ ;
     rule_no := rule_num ;
    END ;
   p^.next := list ;
   list := p ;
  END ; (* new_item *)


 PROCEDURE put_on_end(s1,s2 : string80 ; typ : item_type ; rule_no : counter ;
                      VAR list : item_ptr) ;
  BEGIN
   IF list = NIL
    THEN new_item(s1,s2,typ,rule_no,list)
   ELSE put_on_end(s1,s2,typ,rule_no,list^.next) ;
  END ; (* put_on_end *)


 PROCEDURE read_the_file ;
  VAR
   error : boolean ;

  PROCEDURE scanf ;

   PROCEDURE get_line ;
    BEGIN
     readln(rule_file,line) ;
     IF eof(rule_file)
      THEN line := etx ;
    END ; (* get_line *)

   PROCEDURE get_token ;
    VAR
     i : -1 .. 255 ;
    BEGIN
     strip_leading_blanks(line) ;
     IF length(line) > 0
      THEN
       BEGIN
        i := pos(' ',line) - 1 ;
        IF i <= 0
         THEN i := length(line) ;
        token := copy(line,1,i) ;
        toupper(token) ;
        delete(line,1,i) ;
       END
      ELSE
       BEGIN
        get_line ;
        get_token ;
       END ;
    END ; (* get_token *)

   BEGIN
    IF eof(rule_file)
     THEN token := etx
     ELSE get_token ;
   END ; (* scanf *)

  PROCEDURE at_line ;
   TYPE
    info_type = (prmpt,trns,nl) ;
   VAR
    typ : info_type ;
    attr_word : string80 ;

   PROCEDURE read_a_line ;
    BEGIN
     readln(rule_file,line) ;
     write('.') ;
    END ; (* read_a_line *)

   PROCEDURE insert_attr(s : word ; typ : info_type ; line : string80 ;
                         VAR list : item_ptr) ;

    PROCEDURE put_in_list(VAR p : item_ptr) ;

     PROCEDURE new_attr_item ;
      VAR
       s_ptr : string_ptr ;
       ptr : item_ptr ;
      BEGIN
       ptr := alloc ;
       ptr^.attr := s ;
       new(s_ptr) ;
       s_ptr^.info  := line ;
       s_ptr^.next_line := NIL ;
       CASE typ OF
        prmpt : BEGIN
                 ptr^.prompt_ptr := s_ptr ;
                 ptr^.trans_ptr := NIL ;
                END ;
        trns  : BEGIN
                 ptr^.prompt_ptr := NIL ;
                 ptr^.trans_ptr := s_ptr ;
                END ;
       END ;
       ptr^.val_ptr := NIL ;
       ptr^.next := p ;
       p := ptr ;
      END ; (* new_attr_item *)

     PROCEDURE old_attr_item ;
      VAR
       s_ptr : string_ptr ;

      PROCEDURE end_insert(VAR p_list : string_ptr) ;
       BEGIN
        IF p_list = NIL
         THEN p_list := s_ptr
         ELSE end_insert(p_list^.next_line) ;
       END ; (* end_insert *)

      BEGIN
       new(s_ptr) ;
       s_ptr^.info := line ;
       s_ptr^.next_line := NIL ;
       CASE typ OF
        prmpt : end_insert(p^.prompt_ptr) ;
        trns  : end_insert(p^.trans_ptr) ;
       END ;
      END ; (* old_attr_item *)

     BEGIN
      IF p = NIL
       THEN new_attr_item
      ELSE IF s < p^.attr
       THEN new_attr_item
      ELSE IF s = p^.attr
       THEN old_attr_item
      ELSE put_in_list(p^.next) ;
     END ; (* put_in_list *)

    BEGIN
     makestr(s,word_size) ;
     put_in_list(list) ;
    END ; (* insert_attr *)

   BEGIN
    attr_word := '' ;
    IF token = '@PROMPT'
     THEN typ := prmpt
     ELSE typ := trns ;
    scanf ;
    WHILE token <> '@' DO
     BEGIN
      attr_word := concat(attr_word,token,' ') ;
      scanf ;
     END ;
    read_a_line ;
    WHILE (NOT eof(rule_file)) AND (pos('@',line) = 0) DO
     BEGIN
      insert_attr(attr_word,typ,line,attr_list) ;
      read_a_line ;
     END ;
    scanf ;
   END ; (* at_line *)

  PROCEDURE rule ;
   VAR
    attr,pred,val : string80 ;
    rule_no : counter ;
    kind : item_type ;
    num : string[4] ;
    at : item_ptr ;

   PROCEDURE runout ;
    BEGIN
     WHILE (token <> '.') AND (pos('@',token) <> 0) AND (token <> etx) DO
      scanf ;
    END ; (* runout *)

   PROCEDURE error_rtn(err_num : byte) ;
    BEGIN
     writeln ;
     write('***** error - rule : ',rule_no : 3,' ***** ') ;
     CASE err_num OF
      1 : writeln('Couldn''t find rule number.') ;
      2 : writeln('Missing ''IF''.') ;
      3 : writeln('Missing ''THEN''.') ;
      4 : writeln('Couldn''t find an attribute.') ;
      5 : writeln('Couldn''t find a value.') ;
     END ;
     runout ;
     error := TRUE ;
    END ; (* error_rtn *)

   FUNCTION legal_pred(w : word) : boolean ;
    BEGIN
     legal_pred := (w = 'IS') ;
    END ; (* legal_pred *)

   PROCEDURE attribute ;
    BEGIN
     IF NOT legal_pred(token)
      THEN
       BEGIN
        attr := concat(attr,token,' ') ;
        scanf ;
        attribute ;
       END ;
    END ; (* attribute *)

   PROCEDURE predicate ;
    BEGIN
     IF attr = ''
      THEN error_rtn(4)
     ELSE IF legal_pred(token)
      THEN
       BEGIN
        pred := token ;
        scanf ;
       END ;
    END ; (* predicate *)

   PROCEDURE value ;
    BEGIN
     IF pred = ''
      THEN error_rtn(5)
     ELSE IF (token <> '.') AND (token <> etx)
             AND (token <> 'AND') AND (token <> 'THEN')
      THEN
       BEGIN
        val := concat(val,token,' ') ;
        scanf ;
        value ;
       END ;
    END ; (* value *)

   PROCEDURE clause ;

    PROCEDURE put_in_val_list(s1,s2 : string80 ; kind : item_type ;
                              rule_no : counter) ;
     VAR
      at : item_ptr ;
     
     PROCEDURE put_in_list(VAR list : item_ptr) ;
      BEGIN
       IF list = NIL
        THEN new_item(s1,s2,kind,rule_no,list)
       ELSE IF list^.val > s2
        THEN new_item(s1,s2,kind,rule_no,list)
       ELSE put_in_list(list^.next) ;
      END ; (* put_in_list *)

     PROCEDURE make_new_attr_item ;
      VAR
       ptr : item_ptr ;

      PROCEDURE put_in_attr_list(VAR list :item_ptr) ;
       BEGIN
        IF list = NIL
         THEN list := ptr
        ELSE IF ptr^.attr < list^.attr
         THEN
          BEGIN
           ptr^.next := list ;
           list := ptr ;
          END
        ELSE put_in_attr_list(list^.next) ;
       END ; (* put_in_attr_list *)
       
      BEGIN
       ptr := alloc ;
       makestr(s1,word_size) ;
       toupper(s1) ;
       WITH ptr^ DO
        BEGIN
         attr := s1 ;
         next := NIL ;
         prompt_ptr := NIL ;
         trans_ptr := NIL ;
         val_ptr := NIL ;
        END ;
       put_in_attr_list(attr_list) ;
       makestr(s2,word_size) ;
       toupper(s2) ;
       put_in_list(ptr^.val_ptr) ;
      END ; (* make_new_attr_item*)

     BEGIN
      IF on_list(s1,attr_list,at)
       THEN
        BEGIN
         makestr(s2,word_size) ;
         toupper(s2) ;
         put_in_list(at^.val_ptr) ;
        END
       ELSE make_new_attr_item ;
     END ; (* put_in_val_list *)

    BEGIN
     attr := '' ;
     pred := '' ;
     val := '' ;
     attribute ;
     predicate ;
     IF NOT error
      THEN value ;
     IF NOT error
      THEN put_in_val_list(attr,val,kind,rule_no) ;
    END ; (* clause *)

   PROCEDURE condition ;
    BEGIN
     IF NOT error
      THEN
       BEGIN
        kind := cond ;
        clause ;
        IF token = 'AND'
         THEN
          BEGIN
           scanf ;
           condition ;
          END ;
       END ;
    END ; (* condition *)

   PROCEDURE conclusion ;
    BEGIN
     IF NOT error
      THEN
       BEGIN
        kind := concld ;
        clause ;
        IF token = 'AND'
         THEN
          BEGIN
           scanf ;
           conclusion ;
          END ;
       END ;
    END ; (* conclusion *)

   BEGIN
    rule_no := tointeger(token) ;
    IF rule_no > 0
     THEN
      BEGIN
       scanf ;
       IF token = 'IF'
        THEN
         BEGIN
          scanf ;
          condition ;
          IF (token = 'THEN') AND (NOT error)
           THEN
            BEGIN
             scanf ;
             conclusion ;
             IF (rule_no > biggest_rule) AND (NOT error)
              THEN biggest_rule := rule_no ;
            END
           ELSE error_rtn(3)
         END	ELSE error_rtn(2) ;
      END
     ELSE error_rtn(1) ;
   END ; (* rule *)

  BEGIN
   error := FALSE ;
   scanf ;
   IF token <> etx
    THEN
     BEGIN
      IF (token = '@PROMPT') OR (token ='@TRANS')
       THEN at_line
       ELSE rule ;
      write('.') ;
      read_the_file ;
     END ;
  END ; (* read_the_file *)

  
 FUNCTION got_rule_files : boolean ;
  VAR
   ch : char ;
   rule_name : string80 ;
   
  FUNCTION file_ok : boolean ;
   
   FUNCTION open(VAR file_id : text ; file_name : string80) : boolean ;
    BEGIN
     (*$I- *)
     (* For Apple Pascal
     reset(file_id,file_name) ;
     *)
     assign(file_id,file_name) ;
     reset(file_id) ;
     open := (ioresult = 0) ;
     (*$I+ *)
    END ; (* open *)

   BEGIN
    write('File name : ') ;
    readln(rule_name) ;
    toupper(rule_name) ;
    IF pos('.TXT',rule_name) = 0
     THEN rule_name := concat(rule_name,'.TXT') ;
    file_ok := open(rule_file,rule_name) ;
   END ; (* file_ok *)

  BEGIN
   IF NOT file_ok
    THEN
     BEGIN
      writeln ;
      writeln('An error has occurred while opening the files.') ;
      writeln ;
      write('Press <ESC> to quit, any other key to continue.') ;
      read(trm,ch) ;
      writeln ;
      IF ch <> chr(27)
       THEN got_rule_files := got_rule_files
       ELSE got_rule_files := FALSE ;
     END
    ELSE got_rule_files := TRUE ;
  END ; (* got_rule_files *)


 PROCEDURE initialize ;
  BEGIN
   etx := ' ' ;
   etx[1] := chr(3) ;
   line := '' ;
   biggest_rule := 0 ;
   free := NIL ;
   attr_list := NIL ;
  END ; (* initialize *)


 PROCEDURE xref ;
  VAR
   out_name : string80 ;
   ch : char ;
   out_file : text ;
 
  PROCEDURE print_xref(list : item_ptr) ;
       
   PROCEDURE print_str(msg : word ; ptr : string_ptr) ;
    
    PROCEDURE print_s_list(p : string_ptr) ;
     BEGIN
      IF p <> NIL
       THEN
        BEGIN
         writeln(out_file,p^.info) ;
         print_s_list(p^.next_line) ;
        END ;
     END ; (* print_s_list *)

    BEGIN
     IF ptr <> NIL
      THEN
       BEGIN
        writeln(out_file,msg) ;
        print_s_list(ptr) ;
        writeln(out_file) ;
       END ;
    END ; (* print_str *)

   PROCEDURE print_v_list ;
    VAR
     last_val : word ;

    PROCEDURE print_v(ptr : item_ptr) ;
     BEGIN
      IF ptr <> NIL
       THEN
        BEGIN
         IF ptr^.val <> last_val
          THEN
           BEGIN
            writeln(out_file) ;
            write(out_file,ptr^.val) ;
            last_val := ptr^.val ;
           END ;
         write(out_file,ptr^.rule_no : 4) ;
         print_v(ptr^.next) ;
        END ;
     END ; (* print_v *)

    BEGIN
     IF list^.val_ptr <> NIL
      THEN
       BEGIN
        writeln(out_file,'Value',' ' : word_size - 5,'Rule(s)') ;
        last_val := '' ;
        print_v(list^.val_ptr) ;
        writeln(out_file) ;
       END ;
    END ; (* print_v_list *)

   BEGIN
    IF list <> NIL
     THEN
      BEGIN
       writeln(out_file) ;
       writeln(out_file,'Attribute : ',list^.attr) ;
       writeln(out_file) ;
       print_str('Prompt : ',list^.prompt_ptr) ;
       print_str('Translation : ',list^.trans_ptr) ;
       print_v_list ;
       IF out_name = 'CON:'
        THEN
         BEGIN
          writeln ;
          write('Press any key to continue. ') ;
          read(trm,ch) ;
          writeln ;
         END ;
       print_xref(list^.next) ;
      END ;
   END ; (* print_xref *)

  BEGIN
   writeln ;
   write('Output File (<RETURN> for con:) ') ;
   readln(out_name) ;
   toupper(out_name) ;
   IF out_name = ''
    THEN out_name := 'CON:' ;
   assign(out_file,out_name) ;
   rewrite(out_file) ;
   (* For Apple Pascal
   rewrite(out_file,out_name) ;
   *)
   print_xref(attr_list) ;
   close(out_file) ;
   (* For Apple Pascal
   close(out_file,lock) ;
   *)
  END ; (* xref *)


 BEGIN
  initialize ;
  IF got_rule_files
   THEN
    BEGIN
     read_the_file ;
     close(rule_file) ;
     xref ;
    END ;
 END.







==================================================

                    SAMPLE.TXT

==================================================



@trans stem @
The stem of the plant
@

@prompt stem @
Is the stem of the plant woody or green ?
@

@trans position @
The position of the plant
@

@prompt position @
Is the position of the plant upright or creeping ?
@

@trans one main trunk @
There is /not/ one main trunk
@

@prompt one main trunk @
Does the plant have one main trunk ?
@

@trans type of plant @
the type of the plant
@

@trans broad and flat @
The shape of the leaves is /not/ broad and flat
@

@prompt broad and flat @
Is the shape of the leaves broad and flat ?
@

@trans class @
The class of the tree
@

@trans leaf shape @
The leaf shape
@

@prompt leaf shape @
Is the leaf shape needlelike or scalelike ?
@

@trans needle pattern @
The pattern the needles form along the branch
@

@prompt needle pattern @
Is the pattern that the needles form along the branch
a random one or are the needles is 2 even lines ?
@

@trans silver bands @
There is /not/ a silver band under each needle
@

@prompt silver bands @
Is there a silver band under each needle ?
@

@trans family @
The family of the plant
@

1
If class is gymnosperm
and leaf shape is scalelike
then family is cypress .

2
If class is gymnosperm
and leaf shape is needlelike
and needle pattern is random
then family is pine .

3
If class is gymnosperm
and leaf shape is needlelike
and needle pattern is 2 even lines
and silver bands is yes
then family is pine .

4
If class is gymnosperm
and leaf shape is needlelike
and needle pattern is 2 even lines
and silver bands is no
then family is pine .

5
If type of plant is tree
and broad and flat is yes 
then class is angiosperm .

6
If type of plant is tree
and broad and flat is no
then class is gymnosperm .

7
If stem is green
then type of plant is herb .

8
If stem is woody 
and position is creeping
then type of plant is vine .

9
If stem is woody 
and position is upright
and one main trunk is yes 
then type of plant is tree .

10
If stem is woody 
and position is upright
and one main trunk is no
then type of plant is shrub .