Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!rutgers!ames!ucbcad!ucbvax!decvax!decwrl!sun!imagen!turner
From: turner@imagen.UUCP (D'arc Angel)
Newsgroups: comp.ai
Subject: AI Expert Magazine source code posting for April (Part 01/05)
Message-ID: <1001@imagen.UUCP>
Date: Tue, 17-Mar-87 19:57:09 EST
Article-I.D.: imagen.1001
Posted: Tue Mar 17 19:57:09 1987
Date-Received: Thu, 19-Mar-87 04:39:23 EST
Organization: The Houses of the Holy
Lines: 607
Keywords: source


#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
#	ada.apr
#	aiapp.apr
#	contnt.apr
#	expert.apr
#	files.apr
#	vtlisp.doc
#	vtlisp.uue
# This archive created: Tue Mar 17 16:45:13 1987
# By:	D'arc Angel (The Houses of the Holy)
export PATH; PATH=/bin:/usr/bin:$PATH
echo shar: "extracting 'ada.apr'" '(3282 characters)'
if test -f 'ada.apr'
then
	echo shar: "will not over-write existing file 'ada.apr'"
else
cat << \SHAR_EOF > 'ada.apr'


"AI & Ada"
April 1987 AI EXPERT magazine


Listing 1

type predicate;-- will be for rule, fact, or goal.
type predicptr is access predicate;
type predicate is
	record
		item: symptr;--point to list which is predicate
		next: predicptr;--for next symbol in predicate
-- no value or confidence -this will be in binding for an instantiation
	end record;

type binding;
type bindptr is access binding;
type binding is
	record
		name: symptr;--variable name bound
		depth: integer;-- name+depth=standardized variable
		context: integer;-- depth of binding
		father:integer;
		mother: integer;-- rules that gave birth to binding
		ident: integer;-- depth bound to, if variable
		text: predicptr;-- text+ident=variable/fact bound to,
		next: bindptr;-- use chained (bucketed) hash
-- first token, link to linked list of tokens
	end record;


Listing 2

function unify( uin:predicptr; duin:integer;
		 vin:predicptr; dvin:integer;
		 context,father,mother: integer) return BOOLEAN is
u,v,valu:predicptr;
du,dv,dvalue: integer;
begin
u:=uin;
v:=vin;
du:=duin;
dv:=dvin;
--CAVEAT: binding is currently treated as ADT insofar as 
-- verify, unify, concerned.
-- depending on binding implementation 
-- may prefer global vs. local bindings, etc.  This may in turn
-- cause us to prefer slightly different versions of unify 
-- for hash, use Nakamura method but with occurs check.
--CAVEAT: MY UNIFY ASSUMES RULE ENTRIES ATOMS OR VARIABLES, NOT 
-- LISTS
@New_Line;Put(" entered unify");
<<doit>>
@New_Line;Put("doit u,v=");Printpred(u,du);Printpred(v,dv);
-- first if for end of the predicates encountered-
if u=NULL and v=NULL then return TRUE;
elsif u=NULL or v=NULL then return FALSE;--one but not both null;
end if;
--neither u nor v NULL 
if is_var(u) then
@Put(" u variable");Put(du);
	if not isbound(u,du) then --u is unbound-bind it to v
@Put(" u unbound");Put(du);
		if NOoccurs(u,du,v,dv) then
			value(v,dv,valu,dvalue);
			install(u.item,du,context,father,mother
			,dvalue,valu);
			return TRUE;
		--only works for binding var. to either var. or atom
		-- more general binding possible with minor extension
			-- don't return-check remainder of predicates
		else--occurs check
			return FALSE;
		end if;--occurs check-bind u to v
	else-- u bound- is it ok?
		value(u,du,valu,dvalue);
		u:=valu;
		du:=dvalue;
		goto doit;
	end if;-- if not bound u
 
elsif is_var(v) then -- v variable, u is not
@Put(" v is variable, u wasnt");Put(dv);
	<<dov>> if not isbound (v,dv) then--bind it to u
		if NOoccurs(v,dv,u,du) then
			install(v.item,dv,context,father,mother,du,u);
			return TRUE;
		else 
			return FALSE;
		end if;-- occurs check bind v to u
	else -- v bound as well as u
		value(v,dv,valu,dvalue);
		v:=valu;
		dv:=dvalue;
		--goto dov;Janus had pblms going to correct place-
		-- else <<dov>> if  is var confused it.
		if is_var(v) then goto dov; end if; 
	end if;-- if not bound
-- neither u, v variables- must be lists or atoms
elsif u.next=NULL and then v.next=NULL then--both atoms
	if u.item /= v.item then--check first tokens(symptr must equal)
		return FALSE;
	else
		return TRUE;
	end if;
end if;
-- neither variables nor atoms-lists
if unify(car(u),du,car(v),dv,context,father,mother) then
	u:=u.next;
	v:=v.next;
	goto doit;
else
	return FALSE;	
end if;
end unify;
SHAR_EOF
if test 3282 -ne "`wc -c < 'ada.apr'`"
then
	echo shar: "error transmitting 'ada.apr'" '(should have been 3282 characters)'
fi
fi
echo shar: "extracting 'aiapp.apr'" '(43847 characters)'
if test -f 'aiapp.apr'
then
	echo shar: "will not over-write existing file 'aiapp.apr'"
else
cat << \SHAR_EOF > 'aiapp.apr'

"AI Apprentice"
April 1987 AI EXPERT magazine
(Listings to VTLISP)


VTLISP.PAS
----------

{.PW132}
{.IN+}
{.HE VTLISP.PAS                                          Page #}
{$V-,R+ }
PROGRAM very_tiny_LISP ;

(* Copyright (c) 1987 - Knowledge Garden Inc.
                        473A Malden Bridge Rd.
                        RD #2
                        Nassau, NY 12123       *)


(* VT-LISP is a simple functional variation of LISP as described in the
   April and May 1987 issues of AI Expert

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

   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.
     500 Howard St.
     San Francisco, CA 94105

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

   Bill and Bev Thompson    *)

 CONST
  back_space = ^H ;
  tab = ^I ;
  eof_mark = ^Z ;
  quote_char = #39 ;
  left_arrow = #75 ;
  return = ^M ;
  bell = ^G ;

 TYPE
  counter = 0 .. maxint ;
222244444  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) ;
  s_expr = ^node ;
  node = RECORD
          in_use : boolean ;
          CASE tag : node_type OF
           cons_node : (car_ptr : s_expr ;
                        cdr_ptr : s_expr) ;
           symbol    : (string_data : string80) ;
           number    : (num_data : real) ;
           free_node : (next_free : s_expr ;
                        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 car pointer, then second contains the cdr pointer.
    symbol     - holds string values, we don't actually use the entire 80
                 characters in most cases.
    number     - used for storage of numbers. All numbers are implemented as
                 reals. This is inefficient, but relatively easy in Turbo
                 Pascal.
    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.


    Note: we allocate a new node for each atom, instead of a pointer to an
          existing string in the heap. This slows down comparisons,
          because you have to compare strings instead of pointers, but
          speeds up allocation. We've tried it both ways and there seems
          to be no effect on small programs, but if you decide to
          expand this program you should take a long hard look at all
          of the allocation routines and improve them. *)


 VAR
  total_free : real ;
  result,fn,free,initial_heap,saved_list,pending : s_expr ;
  token : string80 ;
  line,saved_line : string255 ;
  delim_set : char_set ;
  paren_level : counter ;

(* Variables - These are the important global variables:
     total_free -  a count of the total amount of free mameory on the
                   free list.
     result      - the S-expression returned by eval.
     fn          - S-expression read by get_expression.
     free        - a linked list of free nodes. Memory is allocated from
                   from here if possible before getting memory from
                   the heap. This list is built by the garbage collector.
     inital_heap - a pointer to the bottom of the heap
     saved_list  - a list of all nodes which must absolutely not be
                   reclaimed by the garbage collector.
     pending     - a utility S-expression used by LETREC
     token       - the returned by get_token. This really shouldn't
                   be a global. It's just sloppy programming.
     line        - the input buffer for S-expressions
     delim_set   - set of token delimeters
     paren_level - the count of unmatched parentheses, used while reading
                   S-expressions *)



(* ----------------------------------------------------------------------
        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 : string255) : real ;
  (* Converts "s" to a real - ignores non-numeric characters. *)
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   IF s = ''
    THEN code := -1
   ELSE IF length(s) = 1
    THEN
     IF s[1] IN ['0' .. '9']
      THEN val(s,num,code)
      ELSE code := -1
   ELSE val(s,num,code) ;
   IF code = 0
    THEN toreal := num
    ELSE toreal := 0 ;
  END ; (* toreal *)


 FUNCTION tointeger(s : string80) : integer ;
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   val(s,num,code) ;
   IF code = 0
    THEN
     IF (num < -32768.0) OR (num > 32767.0)
      THEN tointeger := 0
      ELSE tointeger := trunc(num)
    ELSE tointeger := 0 ;
  END ; (* tointeger *)


 FUNCTION is_number(s : string255) : boolean ;
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   IF s = ''
    THEN code := -1
   ELSE IF length(s) = 1
    THEN
     IF S[1] IN ['0' ..'9']
      THEN code := 0
      ELSE code := -1
   ELSE val(s,num,code) ;
   is_number := (code = 0) ;
  END ; (* is_number *)


 FUNCTION cardinal(i : integer) : real ;
  VAR
   r : real ;
  BEGIN
   r := i ;
   IF r < 0
    THEN r := r + 65536.0 ;
   cardinal := r ;
  END ; (* cardinal *)


 FUNCTION tag_value(list : s_expr) : 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 car(list : s_expr) : s_expr ;
  (* returns a pointer to the first item in the list.
     If the list is empty, it returns NIL.  *)
  BEGIN
   IF list = NIL
    THEN car := NIL
   ELSE IF tag_value(list) = cons_node
    THEN car := list^.car_ptr
   ELSE car := NIL ;
  END ; (* car *)


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


 FUNCTION atom(p : s_expr) : boolean ;
  (* Return true if p is a symbolic or numeric atom, otherwise
     it returns false *)
  BEGIN
   IF p = NIL
    THEN atom := false
   ELSE IF tag_value(p) IN [number,symbol]
    THEN atom := true
   ELSE atom := false ;
  END ; (* atom *)


 FUNCTION allocation_size(x : integer) : integer ;
  (* 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) SHR 3) + 1) SHL 3 ;
  END ; (* allocation_size *)


 FUNCTION node_size : counter ;
  (* calculates the size of a cons node. *)
  BEGIN
   node_size := 2 * sizeof(s_expr) + sizeof(boolean) + sizeof(node_type) ;
  END ; (* node_size *)


 FUNCTION normalize(pt : s_expr) : s_expr ;
  (* 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 : s_expr) : string80 ;
  (* returns the string pointed to by list. If list points to a number
     node, it returns a string representing that number *)
  TYPE
   real_rec = RECORD
               CASE boolean OF
                true  : (p1 : real) ;
                false : (p2 : ARRAY [0 ..5] OF byte) ;
               END ;
  VAR
   s : string80 ;
   p : real_rec ;

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

  BEGIN
   IF list = NIL
    THEN string_val := ''
   ELSE IF list^.tag = symbol
    THEN string_val := list^.string_data
   ELSE IF list^.tag = number
    THEN
     WITH list^ DO
      BEGIN
       p.p1 := abs(frac(num_data)) ;
       IF p.p2[0] = 0
        THEN str(num_data : 20 : 0,s)
       ELSE IF p.p2[0] < 112
        THEN str(num_data,s)
       ELSE
        BEGIN
         str(num_data : 20 : 10,s) ;
         strip_trailing_zeros(s) ;
        END ;
       strip_leading_blanks(s) ;
       string_val := s ;
      END
   ELSE string_val := '' ;
  END ; (* string_val *)


 FUNCTION num_val(list : s_expr) : real ;
  (* returns the number pointed to by list. If list points to a string,
     it returns the numerical value of the string.   *)
  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 *)



 PROCEDURE get_memory(VAR p : s_expr ; 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 : s_expr) ;
   (* 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 ;
-- 
---------------
C'est la vie, C'est la guerre, C'est la pomme de terre
Mail:	Imagen Corp. 2650 San Tomas Expressway Santa Clara, CA 95052-8101 
UUCP:	...{decvax,ucbvax}!decwrl!imagen!turner      AT&T: (408) 986-9400