(*$V-,R+,B- *)

Program very_tiny_prolog ;
uses Crt; (* necessary for ClrEol *)


(* 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, HeapPtr : 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 ;

(* Johnicholas says: so ptr is some primitive that builds a (32-bit) pointer from a pair of (16-bit) ints?
      *  Maybe I just need to cast the FarPointer to the appropriate type? *)
  normalize := node_ptr(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 := normalize(node_ptr(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(typ : node_type ; 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 := typ   ;
  pt^.string_data := s ;
  alloc_str := pt ;
End ;
(* alloc_str *)


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


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

(* Johnicholas says: HeapPtr is something from the TP runtime - is there something analogous in the fpc runtime?
 *  Are we walking over all of memory, or just some specific region? *)
  While lower(p, HeapPtr) Do
    Begin
      p^.in_use := false ;
      Case p^.tag Of 
        cons_node : p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + node_allocation))) ;
        free_node : p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + (p^.block_cnt + 1) * 8))) ;
        func,
        constant,
        variable  : p := normalize(node_ptr(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(node_ptr(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(node_ptr(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(node_ptr(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(node_ptr(ptr(seg(p^),ofs(p^) + block_allocation))) ;
                  End ;
      func,
      constant,
      variable  :
                  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(node_ptr(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
     (* Johnicholas says: is memavail something in the legacy context? yes
      *  The fpc docs say: The MemAvail and MaxAvail functions are no longer available.
      *  On modern operating systems, the idea of "Available Free Memory" is not valid for an application.
      *  The reasons are:
      *  1. One processor cycle after an application asked the OS how much memory was free, another application
      *  may have allocated everything.
      *  2. It is not clear what "free memory" means [...snip...]
      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(Input,ch) ;
  write(return) ;

  ClrEol ;

End ;
(* wait *)



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

Procedure read_kbd(Var s : string80) ;
  (* Read a line from the keyboard *)
Begin
  write('-> ') ;
  readln(s) ;
End ;
(* read_kbd *)


Procedure read_from_file(Var f : text_file) ;

(* Read a line from file f and store it in the global variable line.
     It ignores blank lines and when the end of file is reached an
     eof_mark is returned. *)

Procedure read_a_line ;
Begin
    (*$I- *)
  readln(f,line) ;
    (*$I+ *)
  If ioresult <> 0
    Then line := eof_mark
  Else If eof(f)
         Then line := concat(line,eof_mark) ;
End ;
(* read_a_line *)

Begin
  line := '' ;
  If is_console(f)
    Then read_kbd(line)
  Else 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) ;
  saved_line := line ;
End ;
(* read_from_file *)


Procedure get_token(Var t_line : string132 ; Var token : string80) ;

(* Extract a token from t_line. Comments are ignored. A token is
     a string surrounded by delimiters or an end of line. Tokens may
     contain embedded spaces if they are surrounded by quote marks *)

Procedure get_word ;

Var 
  done : boolean ;
  cn : integer ;
  len : byte ;
Begin
  cn := 1 ;
  len := length(t_line) ;
  done := false ;
  While Not done Do
    If cn > len
      Then done := true
    Else If t_line[cn] In delim_set
           Then done := true
    Else cn := cn + 1 ;
  token := copy(t_line,1,cn-1) ;
  delete(t_line,1,cn-1) ;
End ;
(* get_word *)

Procedure comment ;
Begin
  If pos('*)',t_line) > 0
    Then
    Begin
      delete(t_line,1,pos('*)',t_line)+1) ;
      get_token(line,token) ;
    End
  Else
    Begin
      t_line := '' ;
      token := '' ;
      in_comment := true ;
    End ;
End ;
(* comment *)

Procedure get_quote ;
Begin
  delete(t_line,1,1) ;
  If pos(quote_char,t_line) > 0
    Then
    Begin
      token := concat(quote_char,copy(t_line,1,pos(quote_char,t_line) - 1)) ;
      delete(t_line,1,pos(quote_char,t_line)) ;
    End
  Else
    Begin
      token := t_line ;
      t_line := '' ;
    End ;
End ;
(* get_quote *)

Begin
  strip_leading_blanks(t_line) ;
  If length(t_line) > 0
    Then
    Begin
      If copy(t_line,1,2) = '(*'
        Then comment
      Else If (copy(t_line,1,2) = ':-') Or (copy(t_line,1,2) = '?-')
             Then
             Begin
               token := copy(t_line,1,2) ;
               delete(t_line,1,2) ;
             End
      Else If t_line[1] = quote_char
             Then get_quote
      Else If t_line[1] In delim_set
             Then
             Begin
               token := t_line[1] ;
               delete(t_line,1,1) ;
             End
      Else get_word ;
    End
  Else token := '' ;
End ;
(* get_token *)


Procedure scan(Var f : text_file ; Var token : string80) ;

(* Scan repeatedly calls get_token to retreive tokens. When the
     end of a line has been reached, read_from_file is called to
     get a new line. *)
Begin
  If length(line) > 0
    Then
    Begin
      get_token(line,token) ;
      If token = ''
        Then scan(f,token) ;
    End
  Else
    Begin
      read_from_file(f) ;
      scan(f,token) ;
    End ;
End ;
(* scan *)


Procedure compile(Var source : text_file) ;

(* The recursive descent compiler. It reads tokens until the token
     'EXIT' is found. If the token is '?-', a query is performed, a '@' token
     is the command to read a new file and source statements are read form that
     file, otherwise the token is assumed to be part of a sentence and the rest
     of the sentence is parsed. *)

Procedure error(error_msg : string80) ;

(* Signal an error. Prints saved_line to show where the error is located.
      saved_line contains the current line being parsed. it is required,
      because get_token chews up line as it reads tokens. *)

Procedure runout ;
Begin
  While (token <> '.') And (token <> eof_mark) Do
    scan(source,token) ;
End ;
(* runout *)

Begin
  error_flag := true ;
  writeln ;
  writeln(error_msg) ;
  writeln ;
  writeln(saved_line) ;
  writeln('' : length(saved_line) - length(line) - 1,'^') ; ;
  runout ;
  wait ;
End ;
(* error *)

Procedure goal(Var l_ptr : node_ptr) ;

(* Read a goal. The new goal is appended to l_ptr. Each goal is appended
      to l_ptr as a list. Thus, the sentence 'likes(john,X) :- likes(X,wine) .'
      becomes the list ( (likes john X) (likes X wine) ) *)

Var 
  goal_token : string80 ;

Procedure functor(Var f_ptr : node_ptr ; func_token : string80) ;

(* The current goal is a functor. This routine allocates a node
       to store the functor and then processes the components of the
       functor. On exit, f_ptr points to the list containing the functor
       and its components. func_token contains the functor name. *)

Var 
  c_ptr : node_ptr ;

Procedure components(Var cm_ptr : node_ptr) ;

(* Process the components of the functor. The components are terms
        seperated by commas. On exit, cm_ptr points to the list of
        components. *)

Procedure term(Var t_ptr : node_ptr) ;
      (* Process a single term. The new term is appended to t_ptr. *)

Var 
  t_token : string80 ;

Procedure quoted_str(Var q_ptr : node_ptr) ;
       (* Process a quote *)
Begin
  q_ptr := append_list(q_ptr,cons(alloc_str(constant,
           copy(token,2,length(token) - 1)),
           Nil)) ;
  scan(source,token) ;
End ;
(* quoted_str *)

Procedure varbl(Var v_ptr : node_ptr) ;
       (* The current token is a varaible, allocate a node and return
          a pointer to it. *)
Begin
  v_ptr := append_list(v_ptr,cons(alloc_str(variable,token),Nil)) ;
  scan(source,token) ;
End ;
(* varbl *)

Procedure number(Var n_ptr : node_ptr) ;

(* Numbers are treated as string constants. This isn't particularly
          efficent, but it is easy. *)
Begin
  n_ptr := append_list(n_ptr,cons(alloc_str(constant,token),Nil)) ;
  scan(source,token) ;
End ;
(* handle_number *)

Begin
  If token[1] In ['A' .. 'Z','_']
    Then varbl(t_ptr)
  Else If token[1] = quote_char
         Then quoted_str(t_ptr)
  Else If is_number(token)
         Then number(t_ptr)
  Else If token[1] In ['a' .. 'z']
         Then
         Begin
           t_token := token ;
           scan(source,token) ;
           If token = '('
             Then functor(t_ptr,t_token)
           Else t_ptr := append_list(t_ptr,
                         cons(alloc_str(constant,t_token),Nil)) ;
         End
  Else error('Illegal Symbol.') ;
End ;
(* term *)

Begin
  term(cm_ptr) ;
  If token = ','
    Then
    Begin
      scan(source,token) ;
      components(cm_ptr) ;
    End ;
End ;
(* components *)

Begin
  c_ptr := cons(alloc_str(func,func_token),Nil) ;
  scan(source,token) ;
  components(c_ptr) ;
  If token = ')'
    Then
    Begin
      f_ptr := append_list(f_ptr,cons(c_ptr,Nil)) ;
      scan(source,token) ;
    End
  Else error('Missing '')''.') ;
End ;
(* functor *)

Begin
  If token[1] In ['a' .. 'z',quote_char]
    Then
    Begin
      If token[1] = quote_char
        Then
        Begin
          l_ptr := append_list(l_ptr,
                   cons(cons(alloc_str(constant,
                   copy(token,2,length(token) - 1)),Nil),Nil)) ;
          scan(source,token) ;
        End
      Else
        Begin
          goal_token := token ;
          scan(source,token) ;
          If token = '('
            Then functor(l_ptr,goal_token)
          Else l_ptr := append_list(l_ptr,
                        cons(cons(alloc_str(constant,goal_token),
                        Nil),Nil)) ;
        End
    End
  Else error('A goal must begin with ''a .. z'' or be a quoted string.') ;
End ;
(* goal *)

Procedure tail_list(Var t_ptr : node_ptr) ;

(* Process the tail of a rule. Since the a query is syntactically identical
      to the tail of a rule, this routine is used to compile queries.
      On exit, t_ptr points to the list containing the tail. *)
Begin
  goal(t_ptr) ;
  If token = ','
    Then
    Begin
      scan(source,token) ;
      tail_list(t_ptr) ;
    End ;
End ;
(* tail *)

Procedure rule ;

(* Procees a rule, actually any sentence. If no error occurs the
      new sentence is appended to the data base. *)

Var 
  r_ptr : node_ptr ;

Procedure head_list(Var h_ptr : node_ptr) ;
Begin
  goal(h_ptr) ;
End ;
(* head *)

Begin
  saved_list := cons(data_base,Nil) ;
  test_memory ;
  r_ptr := Nil ;
  head_list(r_ptr) ;
  If token = ':-'
    Then
    Begin
      scan(source,token) ;
      tail_list(r_ptr) ;
    End ;
  If token <> '.'
    Then error('''.'' expected.') ;
  If Not error_flag
    Then data_base := append_list(data_base,cons(r_ptr,Nil)) ;
End ;
(* rule *)

Procedure query ;

(* Process a query. Compile the query, and then call solve to search the
      data base. q_ptr points to the compiled query and solved is a boolean
      indicating whether the query was successfully solved. *)

Var 
  q_ptr : node_ptr ;
  solved : boolean ;

Procedure solve(list,env : node_ptr ; level : counter) ;

(* This is where all the hard work is done. This routine follows the
       steps outlined in the article. list is the query to be soved, env is
       the current environment and level is the recursion level. level can
       only get to 32767, but you'll run out of stack space long before you
       get that far.
       solve saves list and env on the saved list so that they won't be
       destroyed by garbage collection. The data base is always on the
       saved list. At the end of solve, list and env are removed from
       saved_list. *)

Var 
  new_env,p : node_ptr ;

Function look_up(var_str : string80 ; environ : node_ptr) : node_ptr ;

(* Search the environment list pointed to by environ for the variable,
        var_str. If found return a pointer to var_str's binding, otherwise
        return NIL *)

Var 
  found : boolean ;
  p : node_ptr ;
Begin
  p := environ ;
  found := false ;
  While (p <> Nil) And (Not found) Do
    Begin
      If var_str = string_val(head(head(p)))
        Then
        Begin
          found := true ;
          look_up := tail(head(p)) ;
        End
      Else p := tail(p) ;
    End ;
  If Not found
    Then look_up := Nil ;
End ;
(* look_up *)

Procedure check_continue ;

(* Print the bindings and see if the user is satisfied. If nothing
        is printed from the environment, then print 'Yes' to indicate
        that the query was successfully satisfied. *)

Var 
  printed : boolean ;
  ch : char ;

Procedure print_bindings(list : node_ptr) ;

(* Print the bindings for level 0 variables only, intermediate variables
         aren't of interest. The routine recursivley searches for the
         end of the environments list and then prints the binding. This
         is so that variables bound first are printed first. *)

Procedure print_functor(l : node_ptr) ;
FORWARD ;

Procedure print_variable(var_str : string80) ;

(* The varaible in question was bound to another varaible, so look
          up that variable's binding and print it. If a match can't be found
          print '_' to tell the user that the variable is anonymous. *)

Var 
  var_ptr : node_ptr ;
Begin
  var_ptr := look_up(var_str,env) ;
  If var_ptr <> Nil
    Then
    Case tag_value(head(var_ptr)) Of 
      constant  : write(string_val(head(var_ptr)),' ') ;
      variable  : print_variable(string_val(head(var_ptr))) ;
      cons_node : print_functor(head(var_ptr)) ;
    End
  Else write('_ ') ;
End ;
(* print_variable *)

Procedure print_functor (l : node_ptr) ;
       (* The variable was bound to a functor. Print the functor and its
          components. *)

Procedure print_components(p : node_ptr) ;

(* Print the components of a functor. These may be variables or
           other functors, so call the approriate routines to print them. *)
Begin
  If p <> Nil
    Then
    Begin
      Case tag_value(head(p)) Of 
        constant  : write(string_val(head(p)),' ') ;
        variable  : print_variable(string_val(head(p))) ;
        cons_node : print_functor(head(p)) ;
      End ;
      If tail(p) <> Nil
        Then
        Begin
          write(',') ;
          print_components(tail(p)) ;
        End ;
    End ;
End ;
(* print_components *)

Begin
  If l <> Nil
    Then
    Begin
      write(string_val(head(l))) ;
      If tail(l) <> Nil
        Then
        Begin
          write('(') ;
          print_components(tail(l)) ;
          write(')') ;
        End ;
    End ;
End ;
(* print_functor *)

Begin
  If list <> Nil
    Then
    Begin
      print_bindings(tail(list)) ;
      If pos('#',string_val(head(head(list)))) = 0
        Then
        Begin
          printed := true ;
          writeln ;
          write(string_val(head(head(list))),' = ') ;
          Case tag_value(head(tail(head(list)))) Of 
            constant  : write(string_val(head(tail(head(list)))),' ') ;
            variable  : print_variable(string_val(head(tail(head(list))))) ;
            cons_node : print_functor(head(tail(head(list)))) ;
          End ;
        End ;
    End ;
End ;
(* print_bindings *)

Begin
  printed := false ;
  print_bindings(env) ;
  If Not printed
    Then
    Begin
      writeln ;
      write('Yes ') ;
    End ;
  Repeat
    read(Input,ch) ;
  Until ch In [return,';'] ;
  solved := (ch = return) ;
  writeln ;
End ;
(* check_continue *)

Function copy_list(list : node_ptr ; copy_level : counter) : node_ptr ;
     (* Copy a list and append the copy_level (recursion level) to all
        variables. *)

Var 
  temp_list,p : node_ptr ;
  level_str : string[6] ;

Procedure list_copy(from_list : node_ptr ; Var to_list : node_ptr) ;
Begin
  If from_list <> Nil
    Then
    Case from_list^.tag Of 
      variable : to_list := alloc_str(variable,
                            concat(from_list^.string_data,
                            level_str)) ;
      func,
      constant  : to_list := from_list ;
      cons_node :
                  Begin
                    list_copy(tail(from_list),to_list) ;
                    to_list := cons(copy_list(head(from_list),copy_level),
                               to_list) ;
                  End ;
    End ;
End ;
(* list_copy *)

Begin
  str(copy_level,level_str) ;
  level_str := concat('#',level_str) ;
  temp_list := Nil ;
  list_copy(list,temp_list) ;
  copy_list := temp_list ;
End ;
(* copy_list *)

Function unify(list1,list2,environ : node_ptr ; Var new_environ : node_ptr) :
                                                                              boolean ;

(* Unify two lists and return any new bindings at the front of the
        environment list. Returns true if the lists could be unified. This
        routine implements the unification table described in the article.
        Unification is straight forward, but the details of matching the
        lists get a little messy in this routine. There are better ways to
        do all of this, we just haven't gotten around to trying them. If
        you implement any other unification methods, we would be glad to
        hear about it.
        Unify checks to see if both lists are NIL, this is a successful
        unification. If one list is NIL, unification fails. Otherwise check
        what kind on node the head of list1 is and call the appropriate
        routine to perform the unification. Variables are unified by
        looking up the binding of the variable. If none is found, make
        a binding for the variable, otherwise try to unify the binding
        with list2. *)

Var 
  var_ptr : node_ptr ;

Procedure make_binding(l1,l2 : node_ptr) ;

(* Bind a variable to the environment. Anonymous variables are not bound.
         l1 points to the variable and l2 points to its binding. *)
Begin
  If copy(string_val(head(l1)),1,1) <> '_'
    Then new_environ := cons(cons(head(l1),l2),environ)
  Else new_environ := environ ;
  unify := true ;
End ;
(* make_binding *)

Procedure fail ;
      (* Unification failed. *)
Begin
  unify := false ;
  new_environ := environ ;
End ;
(* fail *)

Procedure unify_constant ;

(* List1 contains a constant. Try to unify it with list2. The 4 cases
         are:
          list2 contains
           constant - unify if constants match
           variable - look up binding, if no current binding bind the
                      constant to the variable, otherwise unify list1
                      with the binding.
           cons_node,
           func     - these can't be unified with a constant. A cons_node
                      indicates an expression. *)
Begin
  Case tag_value(head(list2)) Of 
    constant  : If string_val(head(list1)) = string_val(head(list2))
                  Then
                  Begin
                    unify := true ;
                    new_environ := environ ;
                  End
                Else fail ;
    variable  :
                Begin
                  var_ptr := look_up(string_val(head(list2)),environ) ;
                  If var_ptr = Nil
                    Then make_binding(list2,list1)
                  Else unify := unify(list1,var_ptr,environ,new_environ) ;
                End ;
    cons_node,
    func      : fail ;
  End ;
End ;
(* unify_constant *)

Procedure unify_func ;

(* List1 contains a functor. Try to unify it with list2. The 4 cases
         are:
          list2 contains
           constant  - can't be unified.
           variable  - look up binding, if no current binding bind the
                       functor to the variable, otherwise unify list1
                       with the binding.
           cons_node - fail
           func      - if the functors match, then true to unify the component
                       lists (tail of the list) term by term. *)

Procedure unify_tail ;
       (* This routine does the term by term unification of the component
          lists *)

Var 
  p,q : node_ptr ;
  unified : boolean ;
Begin
  p := tail(list1) ;
  q := tail(list2) ;
  unified := true ;
  new_environ := environ ;
  While (p <> Nil) And unified Do
    Begin
      unified := unified And unify(cons(head(p),Nil),cons(head(q),Nil),
                 new_environ,new_environ) ;
      p := tail(p) ;
      q := tail(q) ;
    End ;
  If Not unified
    Then fail ;
End ;
(* unify_tail *)

Begin
  Case tag_value(head(list2)) Of 
    constant  : fail ;
    variable  :
                Begin
                  var_ptr := look_up(string_val(head(list2)),environ) ;
                  If var_ptr = Nil
                    Then make_binding(list2,list1)
                  Else unify := unify(list1,var_ptr,environ,new_environ) ;
                End ;
    func      : If string_val(head(list1)) = string_val(head(list2))
                  Then
                  If list_length(tail(list1)) = list_length(tail(list2))
                    Then unify_tail
                Else fail
                Else fail ;
    cons_node : fail ;
  End ;
End ;
(* unify_func *)

Procedure unify_expr ;

(* List1 contains an expression. Try to unify it with list2. The 4 cases
         are:
          list2 contains
           constant  - can't be unified.
           variable  - look up binding, if no current binding bind the
                       functor to the variable, otherwise unify list1
                       with the binding.
           cons_node - If the heads can be unified, the unify the tails.
           func      - fail *)
Begin
  Case tag_value(head(list2)) Of 
    constant  : fail ;
    variable  :
                Begin
                  var_ptr := look_up(string_val(head(list2)),environ) ;
                  If var_ptr = Nil
                    Then make_binding(list2,list1)
                  Else unify := unify(list1,var_ptr,environ,new_environ) ;
                End ;
    func      : fail ;
    cons_node : If unify(head(list1),head(list2),environ,new_environ)
                  Then unify := unify(tail(list1),tail(list2),new_environ,
                                new_environ)
                Else fail ;
  End ;
End ;
(* unify_expr *)

Begin
  If (list1 = Nil) And (list2 = Nil)
    Then
    Begin
      unify := true ;
      new_environ := environ ;
    End
  Else If list1 = Nil
         Then fail
  Else If list2 = Nil
         Then fail
  Else
    Case tag_value(head(list1)) Of 
      constant  : unify_constant ;
      variable  :
                  Begin
                    var_ptr := look_up(string_val(head(list1)),environ) ;
                    If var_ptr = Nil
                      Then make_binding(list1,list2)
                    Else unify := unify(var_ptr,list2,environ,new_environ) ;
                  End ;
      func      : unify_func ;
      cons_node : unify_expr ;
    End ;
End ;
(* unify *)

Begin
  saved_list := cons(list,cons(env,saved_list)) ;
  If list = Nil
    Then check_continue
  Else
    Begin
      p := data_base ;
      While (p <> Nil) And (Not solved) Do
        Begin
          test_memory ;
          If unify(copy_list(head(head(p)),level),head(list),env,new_env)
            Then solve(append_list(copy_list(tail(head(p)),level),tail(list)),
            new_env,level + 1) ;
          p := tail(p) ;
        End ;
    End ;
  saved_list := tail(tail(saved_list)) ;
End ;
(* solve *)

Begin
  q_ptr := Nil ;
  tail_list(q_ptr) ;
  If token <> '.'
    Then error('''.'' expected.')
  Else If Not error_flag
         Then
         Begin
           solved := false ;
           saved_list := cons(data_base,Nil) ;
           solve(q_ptr,Nil,0) ;
           If Not solved
             Then writeln('No') ;
         End ;
End ;
(* query *)

Procedure read_new_file ;

(* Read source statements from a new file. When all done, close file
      and continue reading from the old file. Files may be nested, but you
      will run into trouble if you nest them deaper than 15 levels. This
      is Turbo's default for open files. *)

Var 
  new_file : text_file ;
  old_line,old_save : string132 ;
  f_name : string80 ;
Begin
  If token[1] = quote_char
    Then delete(token,1,1) ;
  If pos('.',token) = 0
    Then f_name := concat(token,'.PRO')
  Else f_name := token ;
  If open(new_file,f_name)
    Then
    Begin
      old_line := line ;
      old_save := saved_line ;
      line := '' ;
      compile(new_file) ;
      close(new_file) ;
      line := old_line ;
      saved_line := old_save ;
      scan(source,token) ;
      If token <> '.'
        Then error('''.'' expected.') ;
    End
  Else error(concat('Unable to open ',f_name)) ;
End ;
(* read_new_file *)

Procedure do_exit ;

(* Exit the program. This really should be a built-in function and handled
      in solve, but this does the trick. *)
Begin
  scan(source,token) ;
  If token <> '.'
    Then error('''.'' expected.')
  Else halt
End ;
(* do_exit *)

Begin
  scan(source,token) ;
  While token <> eof_mark Do
    Begin
      error_flag := false ;
      If token = '?-'
        Then
        Begin
          scan(source,token) ;
          query ;
        End
      Else If token = '@'
             Then
             Begin
               scan(source,token) ;
               read_new_file ;
             End
      Else If toupper(token) = 'EXIT'
             Then do_exit
      Else rule ;
      scan(source,token) ;
    End ;
End ;
(* compile *)


Procedure initialize ;
  (* Write a heading line and initialize the global variables *)
Begin
  clrscr ;
  writeln ;
  writeln('Very Tiny Prolog - Version 1.0     [c] 1986 MicroExpert Systems') ;
  writeln ;
  in_comment := false ;
  delim_set := [' ',')','(',',','[',']',eof_mark,tab,quote_char,':',
               '@','.','?'] ;
  text_chars := [' ' .. '~'] ;
  line := '' ;
  data_base := Nil ;
  free := Nil ;
  saved_list := Nil ;
  total_free := 0.0 ;
  initial_heap := HeapPtr ;
End ;
(* initialize *)


Begin
  initialize ;
  compile(Input) ;
End.