Category : Files from Magazines
Archive   : AIOCT86.ZIP
Filename : VTPROLOG.PAS
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 :=
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/