ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/AI_OCT86.ZIP/VTPROLOG.PAS

Pascal/Delphi Source File | 1986-07-14 | 10.6 KB | 338 lines

(*$V-,R+,B- *)
PROGRAM very_tiny_prolog ;

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

(* VTPROLOG implements the data base searching and pattern matching of
   PROLOG. It is described in "PROLOG from the Bottom Up" in issues
   1 and 2 of AI Expert.

   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 .

   We would be pleased to hear your comments, good or bad, or any applications
   and modifications of the program. Contact us at:

     AI Expert
     CL Publications Inc.
     650 Fifth St.
     Suite 311
     San Francisco, CA 94107

   or on the AI Expert BBS. Our id is BillandBev Thompson. You can also
   contact us on BIX, our id is bbt.

   Bill and Bev Thompson    *)

 CONST
  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,func,variable,constant,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) ;
           func,
           constant,
           variable  : (string_data : string80) ;
           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.
    constant   - holds string values, we don't actually use the entire 80
                 characters in most cases.
    variable   - also conatins a string value, these nodes will be treated as
                 PROLOG variables rather than constants.
    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
  line,saved_line : string132 ;
  token : string80 ;
  source_file : text_file ;
  error_flag,in_comment : boolean ;
  delim_set,text_chars : char_set ;
  data_base,initial_heap,free,saved_list : node_ptr ;
  total_free : real ;

(* The important globals are:
   source_file  - text file containing PROLOG statements.
   line         - line buffer for reading in the text file
   saved_list   - list of all items that absolutely must be saved if garbage
                  collection occurs. Usually has at least the data_base and
                  the currents query attached 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.
   data_base    - a pointer to the start of the data base. It points to a
                  node pointing to the first sentence in the data base. Nodes
                  pointing to sentences are linked together to form the data
                  base.
   delim_set    - set of characters which delimit tokens. *)


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

 PROCEDURE noise ;
  (* Make a noise on the terminal - used for warnings. *)
  BEGIN
   write(bell) ;
  END ; (* noise *)

 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 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 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 IN [constant,variable,func]
    THEN string_val := list^.string_data
   ELSE string_val := '' ;
  END ; (* string_val *)


 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 *)


 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
      constant,
      func,
      variable  : write(string_val(list),' ') ;
      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 :=