Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/17/84; site cwruecmp.UUCP
Path: utzoo!watmath!clyde!burl!ulysses!ucbvax!decvax!cwruecmp!bammi
From: bammi@cwruecmp.UUCP (Jwahar R. Bammi)
Newsgroups: net.micro.atari
Subject: xlisp (PART 1 of 6)
Message-ID: <1379@cwruecmp.UUCP>
Date: Sat, 18-Jan-86 14:57:24 EST
Article-I.D.: cwruecmp.1379
Posted: Sat Jan 18 14:57:24 1986
Date-Received: Mon, 20-Jan-86 06:15:21 EST
Organization: CWRU Dept. Computer Eng., Cleveland, OH
Lines: 1178


	Xlisp source Part 1 of 6 shar format.
Read the file read.me after unpacking all the files.
				
		Enjoy!

#!/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 the files:
#	art.lsp
#	example.lsp
#	fact.lsp
#	fib.lsp
#	hanoi.lsp
#	hdwr.lsp
#	ifthen.lsp
#	init.lsp
#	prolog.lsp
#	queens.lsp
#	queens2.lsp
# This archive created: Sat Jan 18 14:32:15 1986
# By:	Jwahar R. Bammi ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'art.lsp'" '(2341 characters)'
if test -f 'art.lsp'
then
	echo shar: over-writing existing file "'art.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'art.lsp'
X; This is an example using the object-oriented programming support in
X; XLISP.  The example involves defining a class of objects representing
X; dictionaries.  Each instance of this class will be a dictionary in
X; which names and values can be stored.  There will also be a facility
X; for finding the values associated with names after they have been
X; stored.
X
X; Create the 'Dictionary' class and establish its instance variable list.
X; The variable 'entries' will point to an association list representing the
X; entries in the dictionary instance.
X
X(setq Dictionary (Class :new '(entries)))
X
X; Setup the method for the ':isnew' initialization message.
X; This message will be send whenever a new instance of the 'Dictionary'
X; class is created.  Its purpose is to allow the new instance to be
X; initialized before any other messages are sent to it.  It sets the value
X; of 'entries' to nil to indicate that the dictionary is empty.
X
X(Dictionary :answer :isnew '()
X	    '((setq entries nil)
X	      self))
X
X; Define the message ':add' to make a new entry in the dictionary.  This
X; message takes two arguments.  The argument 'name' specifies the name
X; of the new entry; the argument 'value' specifies the value to be
X; associated with that name.
X
X(Dictionary :answer :add '(name value)
X	    '((setq entries
X	            (cons (cons name value) entries))
X	      value))
X
X; Create an instance of the 'Dictionary' class.  This instance is an empty
X; dictionary to which words may be added.
X
X(setq d (Dictionary :new))
X
X; Add some entries to the new dictionary.
X
X(d :add 'mozart 'composer)
X(d :add 'winston 'computer-scientist)
X
X; Define a message to find entries in a dictionary.  This message takes
X; one argument 'name' which specifies the name of the entry for which to
X; search.  It returns the value associated with the entry if one is
X; present in the dictionary.  Otherwise, it returns nil.
X
X(Dictionary :answer :find '(name &aux entry)
X	    '((cond ((setq entry (assoc name entries))
X	      (cdr entry))
X	     (t
X	      nil))))
X
X; Try to find some entries in the dictionary we created.
X
X(d :find 'mozart)
X(d :find 'winston)
X(d :find 'bozo)
X
X; The names 'mozart' and 'winston' are found in the dictionary so their
X; values 'composer' and 'computer-scientist' are returned.  The name 'bozo'
X; is not found so nil is returned in this case.
SHAR_EOF
if test 2341 -ne "`wc -c 'art.lsp'`"
then
	echo shar: error transmitting "'art.lsp'" '(should have been 2341 characters)'
fi
echo shar: extracting "'example.lsp'" '(2464 characters)'
if test -f 'example.lsp'
then
	echo shar: over-writing existing file "'example.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'example.lsp'
X; Make the class ship and its instance variables be known
X
X(setq ship (Class :new '(x y xv yv m name captain registry)))
X
X
X(ship :answer :getx		'() '( x ))	; just evaluate x
X(ship :answer :getxv		'() '( xv ))	; note that the method is a
X(ship :answer :gety		'() '( y ))	; list of forms, the value
X(ship :answer :getyv		'() '( yv ))	; of the last one being the
X(ship :answer :getm		'() '( m ))	; value of the method
X(ship :answer :getname		'() '( name ))
X(ship :answer :getcaptain	'() '( captain ))
X(ship :answer :getregistry	'() '( registry ))
X
X;			   formal
X;			   param
X;			   of
X;			   method
X(ship :answer :setx  	   '(to) '( (setq x to) ) )
X(ship :answer :setxv 	   '(to) '( (setq xv to) ) )
X(ship :answer :sety  	   '(to) '( (setq y to) ) )
X(ship :answer :setyv	   '(to) '( (setq yv to) ) )
X(ship :answer :setm	   '(to) '( (setq m to) ) )
X(ship :answer :setname     '(to) '( (setq name to) ) )
X(ship :answer :setcaptain  '(to) '( (setq captain to) ) )
X(ship :answer :setregistry '(to) '( (setq registry to) ) )
X
X(ship :answer :sail '(time) 
X	; the METHOD for sailing
X	'( (princ (list "sailing for " time " hours\n"))
X	   ; note that this form is expressed in terms of objects:  "self"
X	   ; is bound to the object being talked to during the execution
X	   ; of its message.  It can ask itself to do things.
X	   (self :setx (+  (self :getx)
X			   (* (self :getxv) time)))
X	   ; This form performs a parallel action to the above, but more
X	   ; efficiently, and in this instance, more clearly
X	   (setq y (+ y (* yv time)))
X	   ; Cute message for return value.  Tee Hee.
X	   "Sailing, sailing, over the bountiful chow mein..."))
X
X; <OBJECT: #12345667> is not terribly instructive.  How about a more
X; informative print routine?
X
X(ship :answer :print '() '((princ (list
X				"SHIP NAME: " (self :getname) "\n"
X				"REGISTRY: " (self :getregistry) "\n"
X				"CAPTAIN IS: " (self :getcaptain) "\n"
X				"MASS IS: " (self :getm) " TONNES\n"
X				"CURRENT POSITION IS: " 
X					(self :getx)	" X BY "
X					(self :gety)	" Y\n"
X				"SPEED IS: "
X					(self :getxv)	" XV BY "
X					(self :getyv)	" YV\n") ) ))
X
X; a function to make life easier
X
X(defun newship (mass name registry captain &aux new)
X	(setq new (ship :new))
X	(new :setx 0)
X	(new :sety 0)
X	(new :setxv 0)
X	(new :setyv 0)
X	(new :setm mass)
X	(new :setname name)
X	(new :setcaptain captain)
X	(new :setregistry registry)
X	(new :print)
X	new)
X
X; and an example object.
X
X(setq Bounty (newship 50 'Bounty 'England 'Bligh))
SHAR_EOF
if test 2464 -ne "`wc -c 'example.lsp'`"
then
	echo shar: error transmitting "'example.lsp'" '(should have been 2464 characters)'
fi
echo shar: extracting "'fact.lsp'" '(96 characters)'
if test -f 'fact.lsp'
then
	echo shar: over-writing existing file "'fact.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'fact.lsp'
X; good old factorial
X
X(defun fact (n)
X       (cond ((= n 1) 1)
X	     (t (* n (fact (- n 1))))))
SHAR_EOF
if test 96 -ne "`wc -c 'fact.lsp'`"
then
	echo shar: error transmitting "'fact.lsp'" '(should have been 96 characters)'
fi
echo shar: extracting "'fib.lsp'" '(90 characters)'
if test -f 'fib.lsp'
then
	echo shar: over-writing existing file "'fib.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'fib.lsp'
X(defun fib (x)
X       (cond ((< x 2) 1)
X             (t (+ (fib (1- x)) (fib (- x 2))))))
SHAR_EOF
if test 90 -ne "`wc -c 'fib.lsp'`"
then
	echo shar: error transmitting "'fib.lsp'" '(should have been 90 characters)'
fi
echo shar: extracting "'hanoi.lsp'" '(448 characters)'
if test -f 'hanoi.lsp'
then
	echo shar: over-writing existing file "'hanoi.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'hanoi.lsp'
X; Good ol towers of hanoi
X;
X; Usage:
X;      (hanoi <n>)
X;          <n> - an integer the number of discs
X
X(defun hanoi(n)
X  ( transfer 'A 'B 'C n ))
X
X(defun print-move ( from to )
X  (princ "Move Disk From ")
X  (princ from)
X  (princ " To ")
X  (princ to)
X  (princ "\n"))
X
X
X(defun transfer ( from to via n )
X  (cond ((equal n 1) (print-move from to ))
X	(t (transfer from via to (- n 1))
X	   (print-move from to)
X	   (transfer via to from (- n 1)))))
X
X
SHAR_EOF
if test 448 -ne "`wc -c 'hanoi.lsp'`"
then
	echo shar: error transmitting "'hanoi.lsp'" '(should have been 448 characters)'
fi
echo shar: extracting "'hdwr.lsp'" '(8603 characters)'
if test -f 'hdwr.lsp'
then
	echo shar: over-writing existing file "'hdwr.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'hdwr.lsp'
X; -*-Lisp-*-
X;
X; Jwahar R. Bammi
X; A simple description of hardware objects using xlisp
X; Mix and match instances of the objects to create your
X; organization.
X; Needs:
X; - busses and connection and the Design
X;   Class that will have the connections as instance vars.
X; - Print method for each object, that will display
X;   the instance variables in an human readable form.
X; Some day I will complete it.
X;
X;
X;
X; utility functions
X
X
X; function to calculate 2^n
X
X(defun pow2 (n)
X	(pow2x n 1))
X
X(defun pow2x (n sum)
X       (cond((equal n 0) sum)
X	    (t (pow2x (- n 1) (* sum 2)))))
X
X
X; hardware objects
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;The class areg
X
X(setq areg (Class :new '(value nbits max_val min_val)))
X
X; methods
X
X; initialization method
X; when a new instance is called for the user supplies
X; the parameter nbits, from which the max_val & min_val are derived
X
X(areg :answer :isnew '(n)
X	  '((self :init n)
X	    	self))
X
X(areg :answer :init '(n)
X	  '((setq value ())
X	    (setq nbits n)
X	    (setq max_val (- (pow2 (- n 1)) 1))
X	    (setq min_val (- (- 0 max_val) 1))))
X
X; load areg
X
X(areg :answer :load '(val)
X	  '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
X		  ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
X		  (t (setq value val)))))
X
X; see areg
X
X(areg :answer :see '()
X      '((cond ((null value) (princ "Register does not contain a value\n"))
X	      (t value))))
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X; The class creg ( a register that can be cleared and incremented)
X; subclass of a reg
X
X(setq creg (Class :new '() '() areg))
X
X; it inherites all the instance vars & methods of a reg
X; in addition to them it has the following methods
X
X(creg :answer :isnew '(n)
X      '((self :init n)
X	self))
X
X(creg :answer :init '(n)
X      '((setq value ())
X	(setq nbits n)
X	(setq max_val (- (pow2 n) 1))
X	(setq min_val 0)))
X
X(creg :answer :clr '()
X      '((setq value 0)))
X
X(creg :answer :inc '()
X      '((cond ((null value) (princ "Register does not contain a value\n"))
X	      (t (setq value (rem (+ value 1) (+ max_val 1)))))))
X
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Register bank
X; contains n areg's n_bits each
X
X(setq reg_bank (Class :new '(regs n_regs curr_reg)))
X
X;methods
X
X(reg_bank :answer :isnew '(n n_bits)
X	  '((self :init n n_bits)
X	    self))
X
X(reg_bank :answer :init '(n n_bits)
X	  '((setq regs ())
X	    (setq n_regs (- n 1))
X	    (self :initx n n_bits)))
X
X(reg_bank :answer :initx '(n n_bits)
X	  '((cond ((equal n 0) t)
X	          (t (list (setq regs (cons (areg :new n_bits) regs))
X		  (self :initx (setq n (- n 1)) n_bits))))))
X
X(reg_bank :answer :load '(reg val)
X	  '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
X		 (t (setq curr_reg (nth (+ reg 1) regs))
X		    (curr_reg :load val)))))
X
X(reg_bank :answer :see '(reg)
X	  '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
X		 (t (setq curr_reg (nth (+ reg 1) regs))
X		    (curr_reg :see)))))
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; The Class alu
X
X;alu - an n bit alu
X
X(setq alu (Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
X
X; methods
X
X(alu :answer :isnew '(n)
X     '((self :init n)
X       self))
X
X(alu :answer :init '(n)
X     '((setq n_bits n)
X       (setq maxu_val (- (pow2 n) 1))
X       (setq maxs_val (- (pow2 (- n 1)) 1))
X       (setq mins_val (- (- 0 maxs_val) 1))
X       (setq minu_val 0)
X       (setq nf 0)
X       (setq zf 0)
X       (setq vf 0)
X       (setq cf 0)))
X
X(alu :answer :check_arith '(a b)
X     '((cond ((and (self :arith_range a) (self :arith_range b)) t)
X	     (t ()))))
X
X(alu :answer :check_logic '(a b)
X     '((cond ((and (self :logic_range a) (self :logic_range b)) t)
X	     (t ()))))
X
X(alu :answer :arith_range '(a)
X     '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
X	     ((> a maxs_val) (princ (list "Operand out of range "a"\n")))
X             (t t))))
X
X(alu :answer :logic_range '(a)
X     '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
X             (t t))))
X
X(alu :answer :set_flags '(a b r)
X     '((if (equal 0 r) ((setq zf 1)))
X       (if (< r 0) ((setq nf 1)))
X       (if (or (and (and (< a 0) (< 0 b)) (>= r 0))
X		  (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
X       (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
X		  (and (>= r 0) (< b 0))) ((setq cf 1)))))
X       
X(alu :answer :+ '(a b &aux result)
X     '((cond ((null (self :check_arith a b)) ())
X	    (t (self :clear_flags)
X	       (setq result (+ a b))
X	       (if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
X		   (if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
X	       (self :set_flags a b result)
X	       result))))
X
X(alu :answer :& '(a b &aux result)
X     '((cond ((null (self :check_logic a b)) ())
X	    (t (self :clear_flags)
X	       (setq result (bit-and a b))
X	       (self :set_flags a b result)
X	       result))))
X
X(alu :answer :| '(a b &aux result)
X     '((cond ((null (self :check_logic a b)) ())
X	    (t (self :clear_flags)
X	       (setq result (bit-ior a b))
X	       (self :set_flags a b result)
X	       result))))
X
X(alu :answer :~ '(a  &aux result)
X     '((cond ((null (self :check_logic a 0)) ())
X	    (t (self :clear_flags)
X	       (setq result (bit-not a))
X	       (self :set_flags a 0 result)
X	       result))))	       
X
X(alu :answer :- '(a b)
X     '((self '+ a (- 0 b))))
X
X(alu :answer :passa '(a)
X     '(a))
X
X(alu :answer :zero '()
X     '(0))
X
X(alu :answer :com '(a)
X     '((self :- 0 a)))
X
X(alu :answer :status '()
X     '((princ (list "NF "nf"\n"))
X       (princ (list "ZF "zf"\n"))
X       (princ (list "CF "cf"\n"))
X       (princ (list "VF "vf"\n"))))
X
X(alu :answer :clear_flags '()
X     '((setq nf 0)
X       (setq zf 0)
X       (setq cf 0)
X       (setq vf 0)))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; The class Memory
X;
X
X(setq memory (Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
X
X; methods
X
X(memory :answer :isnew '(addr_bits data_bits)
X     '((self :init addr_bits data_bits)
X       self))
X
X(memory :answer :init '(addr_bits data_bits)
X     '((setq nabits addr_bits)
X       (setq ndbits data_bits)
X       (setq maxu_val (- (pow2 data_bits) 1))
X       (setq max_addr (- (pow2 addr_bits) 1))
X       (setq maxs_val (- (pow2 (- data_bits 1)) 1))
X       (setq mins_val (- 0 (pow2 (- data_bits 1))))
X       (setq undef (+ maxu_val 1))
X       (setq memry (array :new max_addr undef))))
X
X
X(memory :answer :load '(loc val)
X     '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
X	     ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
X	     ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
X	     (t (memry :load loc val)))))
X
X(memory :answer :write '(loc val)
X     '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
X	     ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
X	     ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
X	     (t (memry :load loc val)))))
X
X
X(memory :answer :read '(loc &aux val)
X     '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
X	     (t (setq val (memry :see loc))
X		(cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
X		      (t val))))))
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; The class array
X
X(setq array (Class :new '(arry)))
X
X; methods
X
X(array :answer :isnew '(n val)
X       '((self :init n val)
X	 self))
X
X(array :answer :init '(n val)
X	'((cond ((< n 0) t)
X	      (t (setq arry (cons val arry))
X		 (self :init (- n 1) val)))))
X
X(array :answer :see '(n)
X	       '((nth (+ n 1) arry)))
X
X
X(array :answer :load '(n val &aux left right temp)
X       '((setq left (self :left_part n arry temp))
X	 (setq right (self :right_part n arry))
X	 (setq arry (append left (list val)))
X	 (setq arry (append arry right))
X	 val))
X
X(array :answer :left_part '(n ary left)
X       '((cond ((equal n 0) (reverse left))
X	       (t (setq left (cons (car ary) left))
X		  (self :left_part (- n 1) (cdr ary) left)))))
X
X(array :answer :right_part '(n ary &aux right)
X       '((cond ((equal n 0) (cdr ary))
X	       (t (self :right_part (- n 1) (cdr ary))))))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
SHAR_EOF
if test 8603 -ne "`wc -c 'hdwr.lsp'`"
then
	echo shar: error transmitting "'hdwr.lsp'" '(should have been 8603 characters)'
fi
echo shar: extracting "'ifthen.lsp'" '(6843 characters)'
if test -f 'ifthen.lsp'
then
	echo shar: over-writing existing file "'ifthen.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'ifthen.lsp'
X; -*-Lisp-*-
X;
X; If then rules - mini expert from Ch. 18 of Winston and Horn
X; Written using recursion without progs
X; Added function 'how' to explain deductions
X;
X; Use:
X;	After loading type (deduce). It will make all the deductions
X;	given the list fact. If you want to know how it deduced something
X;	type (how '(a deduction)) for example (how '(animal is tiger))
X;	and so on.
X
X
X
X; rules data base
X
X(setq rules
X      '((rule identify1
X	      (if (animal has hair))
X	      (then (animal is mammal)))
X	(rule identify2
X	      (if (animal gives milk))
X	      (then (animal is mammal)))
X	(rule identify3
X	      (if (animal has feathers))
X	      (then (animal is bird)))
X	(rule identify4
X	      (if (animal flies)
X		  (animal lays eggs))
X	      (then (animal is bird)))
X	(rule identify5
X	      (if (animal eats meat))
X	      (then (animal is carnivore)))
X	(rule identify6
X	      (if (animal has pointed teeth)
X		  (animal has claws)
X		  (animal has forward eyes))
X	      (then (animal is carnivore)))
X	(rule identify7
X	      (if (animal is mammal)
X		  (animal has hoofs))
X	      (then (animal is ungulate)))
X	(rule identify8
X	      (if (animal is mammal)
X		  (animal chews cud))
X	      (then (animal is ungulate)
X		    (even toed)))
X	(rule identify9
X	      (if (animal is mammal)
X		  (animal is carnivore)
X		  (animal has tawny color)
X		  (animal has dark spots))
X	      (then (animal is cheetah)))
X	(rule identify10
X	      (if (animal is mammal)
X		  (animal is carnivore)
X		  (animal has tawny color)
X		  (animal has black stripes))
X	      (then (animal is tiger)))
X	(rule identify11
X	      (if (animal is ungulate)
X		  (animal has long neck)
X		  (animal has long legs)
X		  (animal has dark spots))
X	      (then (animal is giraffe)))
X	(rule identify12
X	      (if (animal is ungulate)
X		  (animal has black stripes))
X	      (then (animal is zebra)))
X	(rule identify13
X	      (if (animal is bird)
X		  (animal does not fly)
X		  (animal has long neck)
X		  (animal has long legs)
X		  (animal is black and white))
X	      (then (animal is ostrich)))
X	(rule identify14
X	      (if (animal is bird)
X		  (animal does not fly)
X		  (animal swims)
X		  (animal is black and white))
X	      (then (animal is penguin)))
X	(rule identify15
X	      (if (animal is bird)
X		  (animal flys well))
X	      (then (animal is albatross)))))
X; utility functions
X(defun squash(s)
X       (cond ((null s) ())
X	     ((atom s) (list s))
X	     (t (append (squash (car s))
X			(squash (cdr s))))))
X
X(defun p(s)
X       (princ (squash s)))
X
X; functions
X
X; function to see if an item is a member of a list
X
X(defun member(item list)
X       (cond((null list) ())	; return nil on end of list
X	    ((equal item (car list)) list) ; found
X	    (t (member item (cdr list))))) ; otherwise try rest of list
X
X; put a new fact into the facts data base if it is not already there
X
X(defun remember(newfact)
X       (cond((member newfact facts) ())	; if present do nothing
X	    (t ( setq facts (cons newfact facts)) newfact)))
X
X; is a fact there in the facts data base
X
X(defun recall(afact)
X       (cond ((member afact facts) afact)	; it is here
X	     (t ())))				; no it is'nt
X
X; given a rule check if all the if parts are confirmed by the facts data base
X
X(defun testif(iflist)
X       (cond((null iflist) t)	; all satisfied
X	    ((recall (car iflist)) (testif (cdr iflist))) ; keep searching
X	    					          ; if one is ok
X	    (t ())))					; not in facts DB
X
X; add the then parts of the rules which can be added to the facts DB
X; return the ones that are added
X
X(defun usethen(thenlist addlist)
X       (cond ((null thenlist) addlist) ; all exhausted
X	     ((remember (car thenlist))
X	     (usethen (cdr thenlist) (cons (car thenlist) addlist)))
X	     (t (usethen (cdr thenlist) addlist))))
X
X; try a rule
X; return t only if all the if parts are satisfied by the facts data base
X; and at lest one then ( conclusion ) is added to the facts data base
X
X(defun tryrule(rule &aux ifrules thenlist addlist)
X       (setq ifrules (cdr(car(cdr(cdr rule)))))
X       (setq thenlist (cdr(car(cdr(cdr(cdr rule))))))
X       (setq addlist '())
X       (cond (( testif ifrules)
X	      (cond ((setq addlist (usethen thenlist addlist))
X		     (p (list "Rule " (car(cdr rule)) "\n\tDeduced " addlist "\n\n"))
X		     (setq ruleused (cons rule ruleused))
X		     t)
X		    (t ())))
X	     (t ())))
X
X; step through one iteration if the forward search
X; looking for rules that can be deduced from the present fact data base
X
X(defun stepforward( rulelist)
X       (cond((null rulelist) ())	; all done
X	    ((tryrule (car rulelist)) t)
X	    ( t (stepforward(cdr rulelist)))))
X
X; stepforward until you cannot go any further
X
X(defun deduce()
X      (cond((stepforward rules) (deduce))
X	   (t t)))
X
X; function to answer if a fact was used to come to a certain conclusion
X; uses the ruleused list cons'ed by tryrule to answer
X
X(defun usedp(rule)
X       (cond ((member rule ruleused) t)	; it has been used
X	     (t () )))			; no it hasnt
X
X; function to answer how a fact was deduced
X
X(defun how(fact)
X       (how2 fact ruleused nil))
X
X(defun how2(fact rulist found)
X       (cond ((null rulist)	; if the rule list exhausted
X	      (cond (found t)   ; already answered the question return t
X		    ((recall fact) (p (list fact " was a given fact\n")) t) ;known fact
X		    (t (p (list fact " -- not a fact!\n")) ())))
X	      
X	      ((member fact (thenpart (car rulist))) 	; if rulist not empty
X	       (setq found t)	; and fact belongs to the then part of a rule
X	       (p (list fact " was deduced because the following were true\n"))
X	       (printifs (car rulist))
X	       (how2 fact (cdr rulist) found))
X	      (t (how2 fact (cdr rulist) found))))
X
X; function to return the then part of a rule
X
X(defun thenpart(rule)
X       (cdr(car(cdr(cdr(cdr rule))))))
X
X; function to print the if part of a given rule
X
X(defun printifs(rule)
X       (pifs (cdr(car(cdr(cdr rule))))))
X
X(defun pifs(l)
X	(cond ((null l) ())
X	      (t (p (list "\t" (car l) "\n"))
X		 (pifs (cdr l)))))
X
X
X; initial facts data base
X; Uncomment one or make up your own
X; Then run 'deduce' to find deductions
X; Run 'how' to find out how it came to a certain deduction
X
X;(setq facts
X;      '((animal has dark spots)
X;	(animal has tawny color)
X;	(animal eats meat)
X;	(animal has hair)))
X
X(setq facts
X      '((animal has hair)
X	(animal has pointed teeth)
X	(animal has black stripes)
X	(animal has claws)
X	(animal has forward eyes)
X	(animal has tawny color)))
X
X
X(setq rl1
X      	'(rule identify14
X	      (if (animal is bird)
X		  (animal does not fly)
X		  (animal swims)
X		  (animal is black and white))
X	      (then (animal is penguin))))
X
X(setq rl2
X        '(rule identify10
X	      (if (animal is mammal)
X		  (animal is carnivore)
X		  (animal has tawny color)
X		  (animal has black stripes))
X	      (then (animal is tiger))))
X
X; Initialization
X(expand 10)
X(setq ruleused nil)
SHAR_EOF
if test 6843 -ne "`wc -c 'ifthen.lsp'`"
then
	echo shar: error transmitting "'ifthen.lsp'" '(should have been 6843 characters)'
fi
echo shar: extracting "'init.lsp'" '(1963 characters)'
if test -f 'init.lsp'
then
	echo shar: over-writing existing file "'init.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'init.lsp'
X; get some more memory
X(expand 1)
X
X; some fake definitions for Common Lisp pseudo compatiblity
X(setq first  car)
X(setq second cadr)
X(setq rest   cdr)
X
X; some more cxr functions
X(defun caddr (x) (car (cddr x)))
X(defun cadddr (x) (cadr (cddr x)))
X
X; (when test code...) - execute code when test is true
X(defmacro when (test &rest code)
X          `(cond (,test ,@code)))
X
X; (unless test code...) - execute code unless test is true
X(defmacro unless (test &rest code)
X          `(cond ((not ,test) ,@code)))
X
X; (makunbound sym) - make a symbol be unbound
X(defun makunbound (sym) (setq sym '*unbound*) sym)
X
X; (objectp expr) - object predicate
X(defun objectp (x) (eq (type-of x) :OBJECT))
X
X; (filep expr) - file predicate
X(defun filep (x) (eq (type-of x) :FILE))
X
X; (unintern sym) - remove a symbol from the oblist
X(defun unintern (sym) (cond ((member sym *oblist*)
X                             (setq *oblist* (delete sym *oblist*))
X                             t)
X                            (t nil)))
X
X; (mapcan ...)
X(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
X
X; (mapcon ...)
X(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
X
X; (save fun) - save a function definition to a file
X(defmacro save (fun)
X         `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
X                 (fval ',fun)
X                 (fp (openo fname)))
X                (cond (fp (print (cons (if (eq (car fval) 'lambda)
X                                           'defun
X                                           'defmacro)
X                                       (cons fun (cdr fval))) fp)
X                          (close fp)
X                          fname)
X                      (t nil))))
X
X; (debug) - enable debug breaks
X(defun debug ()
X       (setq *breakenable* t))
X
X; (nodebug) - disable debug breaks
X(defun nodebug ()
X       (setq *breakenable* nil))
X
X; initialize to enable breaks but no trace back
X(setq *breakenable* t)
X(setq *tracenable* nil)
SHAR_EOF
if test 1963 -ne "`wc -c 'init.lsp'`"
then
	echo shar: error transmitting "'init.lsp'" '(should have been 1963 characters)'
fi
echo shar: extracting "'prolog.lsp'" '(4302 characters)'
if test -f 'prolog.lsp'
then
	echo shar: over-writing existing file "'prolog.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'prolog.lsp'
X;; The following is a tiny Prolog interpreter in MacLisp
X;; written by Ken Kahn and modified for XLISP by David Betz.
X;; It was inspired by other tiny Lisp-based Prologs of
X;; Par Emanuelson and Martin Nilsson.
X;; There are no side-effects anywhere in the implementation.
X;; Though it is VERY slow of course.
X
X(defun prolog (database &aux goal)
X       (do () ((not (progn (princ "Query?") (setq goal (read)))))
X              (prove (list (rename-variables goal '(0)))
X                     '((bottom-of-environment))
X                     database
X                     1)))
X
X;; prove - proves the conjunction of the list-of-goals
X;;         in the current environment
X
X(defun prove (list-of-goals environment database level)
X      (cond ((null list-of-goals) ;; succeeded since there are no goals
X             (print-bindings environment environment)
X             (not (y-or-n-p "More?")))
X            (t (try-each database database
X                         (cdr list-of-goals) (car list-of-goals)
X                         environment level))))
X
X(defun try-each (database-left database goals-left goal environment level 
X                 &aux assertion new-enviroment)
X       (cond ((null database-left) nil) ;; fail since nothing left in database
X             (t (setq assertion
X                      (rename-variables (car database-left)
X                                        (list level)))
X                (setq new-environment
X                      (unify goal (car assertion) environment))
X                (cond ((null new-environment) ;; failed to unify
X                       (try-each (cdr database-left) database
X                                 goals-left goal
X                                 environment level))
X                      ((prove (append (cdr assertion) goals-left)
X                              new-environment
X                              database
X                              (+ 1 level)))
X                      (t (try-each (cdr database-left) database
X                                   goals-left goal
X                                   environment level))))))
X
X(defun unify (x y environment &aux new-environment)
X       (setq x (value x environment))
X       (setq y (value y environment))
X       (cond ((variable-p x) (cons (list x y) environment))
X             ((variable-p y) (cons (list y x) environment))
X             ((or (atom x) (atom y))
X                  (cond ((equal x y) environment)
X    	                (t nil)))
X             (t (setq new-environment (unify (car x) (car y) environment))
X                (cond (new-environment (unify (cdr x) (cdr y) new-environment))
X    		      (t nil)))))
X
X(defun value (x environment &aux binding)
X       (cond ((variable-p x)
X              (setq binding (assoc x environment :test #'equal))
X              (cond ((null binding) x)
X                    (t (value (cadr binding) environment))))
X             (t x)))
X
X(defun variable-p (x)
X       (and x (listp x) (eq (car x) '?)))
X
X(defun rename-variables (term list-of-level)
X       (cond ((variable-p term) (append term list-of-level))
X             ((atom term) term)
X             (t (cons (rename-variables (car term) list-of-level)
X                      (rename-variables (cdr term) list-of-level)))))
X
X(defun print-bindings (environment-left environment)
X       (cond ((cdr environment-left)
X              (cond ((= 0 (nth 2 (caar environment-left)))
X                     (prin1 (cadr (caar environment-left)))
X                     (princ " = ")
X                     (print (value (caar environment-left) environment))))
X              (print-bindings (cdr environment-left) environment))))
X
X;; a sample database:
X(setq db '(((father madelyn ernest))
X           ((mother madelyn virginia))
X	   ((father david arnold))
X	   ((mother david pauline))
X	   ((father rachel david))
X	   ((mother rachel madelyn))
X           ((grandparent (? grandparent) (? grandchild))
X            (parent (? grandparent) (? parent))
X            (parent (? parent) (? grandchild)))
X           ((parent (? parent) (? child))
X            (mother (? parent) (? child)))
X           ((parent (? parent) (? child))
X            (father (? parent) (? child)))))
X
X;; the following are utilities
X(defun y-or-n-p (prompt)
X       (princ prompt)
X       (eq (read) 'y))
X
X;; start things going
X(prolog db)
SHAR_EOF
if test 4302 -ne "`wc -c 'prolog.lsp'`"
then
	echo shar: error transmitting "'prolog.lsp'" '(should have been 4302 characters)'
fi
echo shar: extracting "'queens.lsp'" '(1408 characters)'
if test -f 'queens.lsp'
then
	echo shar: over-writing existing file "'queens.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'queens.lsp'
X;
X; Place n queens on a board
X;  See Winston and Horn Ch. 11
X; 
X; Usage:
X;	(queens <n>)
X;          where <n> is an integer -- the size of the board - try (queens 4)
X
X(defun cadar (x)
X  (car (cdr (car x))))
X
X; Do two queens threaten each other ?
X(defun threat (i j a b)
X  (or (equal i a)			;Same row
X      (equal j b)			;Same column
X      (equal (- i j) (- a b))		;One diag.
X      (equal (+ i j) (+ a b))))		;the other diagonal
X
X; Is poistion (n,m) on the board safe for a queen ?
X(defun conflict (n m board)
X  (cond ((null board) nil)
X	((threat n m (caar board) (cadar board)) t)
X	(t (conflict n m (cdr board)))))
X
X
X; Place queens on a board of size SIZE
X(defun queens (size)
X  (prog (n m board)
X	(setq board nil)
X	(setq n 1)			;Try the first row
X	loop-n
X	(setq m 1)			;Column 1
X	loop-m
X	(cond ((conflict n m board) (go un-do-m))) ;Check for conflict
X	(setq board (cons (list n m) board))       ; Add queen to board
X	(cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
X	       (print (reverse board))))           ; Print config
X	(go loop-n)			           ; Next row which column?
X	un-do-n
X	(cond ((null board) (return 'Done)) 	   ; Tried all possibilities
X	      (t (setq m (cadar board))		   ; No, Undo last queen placed
X		 (setq n (caar board))
X		 (setq board (cdr board))))
X
X	un-do-m
X	(cond ((> (setq m (1+ m)) size)          ; Go try next column
X	       (go un-do-n))
X	      (t (go loop-m)))))
SHAR_EOF
if test 1408 -ne "`wc -c 'queens.lsp'`"
then
	echo shar: error transmitting "'queens.lsp'" '(should have been 1408 characters)'
fi
echo shar: extracting "'queens2.lsp'" '(2326 characters)'
if test -f 'queens2.lsp'
then
	echo shar: over-writing existing file "'queens2.lsp'"
fi
sed 's/^X//' << \SHAR_EOF > 'queens2.lsp'
X;
X; Place n queens on a board (graphical version)
X;  See Winston and Horn Ch. 11
X; 
X; Usage:
X;	(queens <n>)
X;          where <n> is an integer -- the size of the board - try (queens 4)
X
X(defun cadar (x)
X  (car (cdr (car x))))
X
X; Do two queens threaten each other ?
X(defun threat (i j a b)
X  (or (equal i a)			;Same row
X      (equal j b)			;Same column
X      (equal (- i j) (- a b))		;One diag.
X      (equal (+ i j) (+ a b))))		;the other diagonal
X
X; Is poistion (n,m) on the board safe for a queen ?
X(defun conflict (n m board)
X  (cond ((null board) nil)
X	((threat n m (caar board) (cadar board)) t)
X	(t (conflict n m (cdr board)))))
X
X
X; Place queens on a board of size SIZE
X(defun queens (size)
X  (prog (n m board soln)
X	(setq soln 0)			;Solution #
X	(setq board nil)
X	(setq n 1)			;Try the first row
X	loop-n
X	(setq m 1)			;Column 1
X	loop-m
X	(cond ((conflict n m board) (go un-do-m))) ;Check for conflict
X	(setq board (cons (list n m) board))       ; Add queen to board
X	(cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
X	       (print-board (reverse board) (setq soln (1+ soln))))) ; Print it
X	(go loop-n)			           ; Next row which column?
X	un-do-n
X	(cond ((null board) (return 'Done)) 	   ; Tried all possibilities
X	      (t (setq m (cadar board))		   ; No, Undo last queen placed
X		 (setq n (caar board))
X		 (setq board (cdr board))))
X
X	un-do-m
X	(cond ((> (setq m (1+ m)) size)          ; Go try next column
X	       (go un-do-n))
X	      (t (go loop-m)))))
X
X
X;Print a board
X(defun print-board  (board soln &aux size)
X  (setq size (length board))		;we can find our own size
X  (terpri)
X  (princ "\t\tSolution: ")
X  (print soln)
X  (terpri)
X  (princ "\t")
X  (print-header size 1)
X  (terpri)
X  (print-board-aux board size 1)
X  (terpri))
X
X; Put Column #'s on top
X(defun print-header (size n)
X  (cond ((> n size) terpri)
X	(t (princ n)
X	   (princ " ")
X	   (print-header size (1+ n)))))
X
X(defun print-board-aux (board size row)
X  (terpri)
X  (cond ((null board))
X	(t (princ row)			;print the row #
X	   (princ "\t")
X	   (print-board-row (cadar board) size 1) ;Print the row
X	   (print-board-aux (cdr board) size (1+ row)))))  ;Next row
X
X(defun print-board-row (column size n)
X  (cond ((> n size))
X	(t (cond ((equal column n) (princ "Q"))
X		 (t (princ ".")))
X	   (princ " ")
X	   (print-board-row column size (1+ n)))))
SHAR_EOF
if test 2326 -ne "`wc -c 'queens2.lsp'`"
then
	echo shar: error transmitting "'queens2.lsp'" '(should have been 2326 characters)'
fi
#	End of shell archive
exit 0

-- 
					Jwahar R. Bammi
			       Usenet:  .....!decvax!cwruecmp!bammi
			        CSnet:  bammi@case
				 Arpa:  bammi%case@csnet-relay
			   CompuServe:  71515,155