sources-request@mirror.UUCP (08/18/86)
Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 111
Archive-name: xlisp1.6/Part05
#! /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
# object.lsp
# pcturtle.lsp
# pp.lsp
# prolog.lsp
# pt.lsp
# queens.lsp
# queens2.lsp
# simplepp.lsp
# trace.lsp
# This archive created: Mon Jul 14 10:16:59 1986
export PATH; PATH=/bin:$PATH
if test -f 'art.lsp'
then
echo shar: will not over-write existing file "'art.lsp'"
else
cat << \SHAR_EOF > 'art.lsp'
; This is an example using the object-oriented programming support in
; XLISP. The example involves defining a class of objects representing
; dictionaries. Each instance of this class will be a dictionary in
; which names and values can be stored. There will also be a facility
; for finding the values associated with names after they have been
; stored.
; Create the 'Dictionary' class and establish its instance variable list.
; The variable 'entries' will point to an association list representing the
; entries in the dictionary instance.
(setq Dictionary (Class :new '(entries)))
; Setup the method for the ':isnew' initialization message.
; This message will be send whenever a new instance of the 'Dictionary'
; class is created. Its purpose is to allow the new instance to be
; initialized before any other messages are sent to it. It sets the value
; of 'entries' to nil to indicate that the dictionary is empty.
(Dictionary :answer :isnew '()
'((setq entries nil)
self))
; Define the message ':add' to make a new entry in the dictionary. This
; message takes two arguments. The argument 'name' specifies the name
; of the new entry; the argument 'value' specifies the value to be
; associated with that name.
(Dictionary :answer :add '(name value)
'((setq entries
(cons (cons name value) entries))
value))
; Create an instance of the 'Dictionary' class. This instance is an empty
; dictionary to which words may be added.
(setq d (Dictionary :new))
; Add some entries to the new dictionary.
(d :add 'mozart 'composer)
(d :add 'winston 'computer-scientist)
; Define a message to find entries in a dictionary. This message takes
; one argument 'name' which specifies the name of the entry for which to
; search. It returns the value associated with the entry if one is
; present in the dictionary. Otherwise, it returns nil.
(Dictionary :answer :find '(name &aux entry)
'((cond ((setq entry (assoc name entries))
(cdr entry))
(t
nil))))
; Try to find some entries in the dictionary we created.
(d :find 'mozart)
(d :find 'winston)
(d :find 'bozo)
; The names 'mozart' and 'winston' are found in the dictionary so their
; values 'composer' and 'computer-scientist' are returned. The name 'bozo'
; is not found so nil is returned in this case.
SHAR_EOF
fi # end of overwriting check
if test -f 'example.lsp'
then
echo shar: will not over-write existing file "'example.lsp'"
else
cat << \SHAR_EOF > 'example.lsp'
; Make the class ship and its instance variables be known
(setq ship (Class :new '(x y xv yv m name captain registry)))
(ship :answer :getx '() '( x )) ; just evaluate x
(ship :answer :getxv '() '( xv )) ; note that the method is a
(ship :answer :gety '() '( y )) ; list of forms, the value
(ship :answer :getyv '() '( yv )) ; of the last one being the
(ship :answer :getm '() '( m )) ; value of the method
(ship :answer :getname '() '( name ))
(ship :answer :getcaptain '() '( captain ))
(ship :answer :getregistry '() '( registry ))
; formal
; param
; of
; method
(ship :answer :setx '(to) '( (setq x to) ) )
(ship :answer :setxv '(to) '( (setq xv to) ) )
(ship :answer :sety '(to) '( (setq y to) ) )
(ship :answer :setyv '(to) '( (setq yv to) ) )
(ship :answer :setm '(to) '( (setq m to) ) )
(ship :answer :setname '(to) '( (setq name to) ) )
(ship :answer :setcaptain '(to) '( (setq captain to) ) )
(ship :answer :setregistry '(to) '( (setq registry to) ) )
(ship :answer :sail '(time)
; the METHOD for sailing
'( (princ (list "sailing for " time " hours\n"))
; note that this form is expressed in terms of objects: "self"
; is bound to the object being talked to during the execution
; of its message. It can ask itself to do things.
(self :setx (+ (self :getx)
(* (self :getxv) time)))
; This form performs a parallel action to the above, but more
; efficiently, and in this instance, more clearly
(setq y (+ y (* yv time)))
; Cute message for return value. Tee Hee.
"Sailing, sailing, over the bountiful chow mein..."))
; <OBJECT: #12345667> is not terribly instructive. How about a more
; informative print routine?
(ship :answer :print '() '((princ (list
"SHIP NAME: " (self :getname) "\n"
"REGISTRY: " (self :getregistry) "\n"
"CAPTAIN IS: " (self :getcaptain) "\n"
"MASS IS: " (self :getm) " TONNES\n"
"CURRENT POSITION IS: "
(self :getx) " X BY "
(self :gety) " Y\n"
"SPEED IS: "
(self :getxv) " XV BY "
(self :getyv) " YV\n") ) ))
; a function to make life easier
(defun newship (mass name registry captain &aux new)
(setq new (ship :new))
(new :setx 0)
(new :sety 0)
(new :setxv 0)
(new :setyv 0)
(new :setm mass)
(new :setname name)
(new :setcaptain captain)
(new :setregistry registry)
(new :print)
new)
; and an example object.
(setq Bounty (newship 50 'Bounty 'England 'Bligh))
SHAR_EOF
fi # end of overwriting check
if test -f 'fact.lsp'
then
echo shar: will not over-write existing file "'fact.lsp'"
else
cat << \SHAR_EOF > 'fact.lsp'
(defun factorial (n)
(cond ((= n 1) 1)
(t (* n (factorial (- n 1))))))
SHAR_EOF
fi # end of overwriting check
if test -f 'fib.lsp'
then
echo shar: will not over-write existing file "'fib.lsp'"
else
cat << \SHAR_EOF > 'fib.lsp'
(defun fib (x)
(if (< x 2)
x
(+ (fib (1- x)) (fib (- x 2)))))
SHAR_EOF
fi # end of overwriting check
if test -f 'hanoi.lsp'
then
echo shar: will not over-write existing file "'hanoi.lsp'"
else
cat << \SHAR_EOF > 'hanoi.lsp'
; Good ol towers of hanoi
;
; Usage:
; (hanoi <n>)
; <n> - an integer the number of discs
(defun hanoi(n)
( transfer 'A 'B 'C n ))
(defun print-move ( from to )
(princ "Move Disk From ")
(princ from)
(princ " To ")
(princ to)
(princ "\n"))
(defun transfer ( from to via n )
(cond ((equal n 1) (print-move from to ))
(t (transfer from via to (- n 1))
(print-move from to)
(transfer via to from (- n 1)))))
SHAR_EOF
fi # end of overwriting check
if test -f 'hdwr.lsp'
then
echo shar: will not over-write existing file "'hdwr.lsp'"
else
cat << \SHAR_EOF > 'hdwr.lsp'
; -*-Lisp-*-
;
; Jwahar R. Bammi
; A simple description of hardware objects using xlisp
; Mix and match instances of the objects to create your
; organization.
; Needs:
; - busses and connection and the Design
; Class that will have the connections as instance vars.
; - Print method for each object, that will display
; the instance variables in an human readable form.
; Some day I will complete it.
;
;
;
; utility functions
; function to calculate 2^n
(defun pow2 (n)
(pow2x n 1))
(defun pow2x (n sum)
(cond((equal n 0) sum)
(t (pow2x (- n 1) (* sum 2)))))
; hardware objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;The class areg
(setq areg (Class :new '(value nbits max_val min_val)))
; methods
; initialization method
; when a new instance is called for the user supplies
; the parameter nbits, from which the max_val & min_val are derived
(areg :answer :isnew '(n)
'((self :init n)
self))
(areg :answer :init '(n)
'((setq value ())
(setq nbits n)
(setq max_val (- (pow2 (- n 1)) 1))
(setq min_val (- (- 0 max_val) 1))))
; load areg
(areg :answer :load '(val)
'((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
(t (setq value val)))))
; see areg
(areg :answer :see '()
'((cond ((null value) (princ "Register does not contain a value\n"))
(t value))))
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The class creg ( a register that can be cleared and incremented)
; subclass of a reg
(setq creg (Class :new '() '() areg))
; it inherites all the instance vars & methods of a reg
; in addition to them it has the following methods
(creg :answer :isnew '(n)
'((self :init n)
self))
(creg :answer :init '(n)
'((setq value ())
(setq nbits n)
(setq max_val (- (pow2 n) 1))
(setq min_val 0)))
(creg :answer :clr '()
'((setq value 0)))
(creg :answer :inc '()
'((cond ((null value) (princ "Register does not contain a value\n"))
(t (setq value (rem (+ value 1) (+ max_val 1)))))))
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Register bank
; contains n areg's n_bits each
(setq reg_bank (Class :new '(regs n_regs curr_reg)))
;methods
(reg_bank :answer :isnew '(n n_bits)
'((self :init n n_bits)
self))
(reg_bank :answer :init '(n n_bits)
'((setq regs ())
(setq n_regs (- n 1))
(self :initx n n_bits)))
(reg_bank :answer :initx '(n n_bits)
'((cond ((equal n 0) t)
(t (list (setq regs (cons (areg :new n_bits) regs))
(self :initx (setq n (- n 1)) n_bits))))))
(reg_bank :answer :load '(reg val)
'((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
(t (setq curr_reg (nth (+ reg 1) regs))
(curr_reg :load val)))))
(reg_bank :answer :see '(reg)
'((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
(t (setq curr_reg (nth (+ reg 1) regs))
(curr_reg :see)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The Class alu
;alu - an n bit alu
(setq alu (Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
; methods
(alu :answer :isnew '(n)
'((self :init n)
self))
(alu :answer :init '(n)
'((setq n_bits n)
(setq maxu_val (- (pow2 n) 1))
(setq maxs_val (- (pow2 (- n 1)) 1))
(setq mins_val (- (- 0 maxs_val) 1))
(setq minu_val 0)
(setq nf 0)
(setq zf 0)
(setq vf 0)
(setq cf 0)))
(alu :answer :check_arith '(a b)
'((cond ((and (self :arith_range a) (self :arith_range b)) t)
(t ()))))
(alu :answer :check_logic '(a b)
'((cond ((and (self :logic_range a) (self :logic_range b)) t)
(t ()))))
(alu :answer :arith_range '(a)
'((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
((> a maxs_val) (princ (list "Operand out of range "a"\n")))
(t t))))
(alu :answer :logic_range '(a)
'((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
(t t))))
(alu :answer :set_flags '(a b r)
'((if (equal 0 r) ((setq zf 1)))
(if (< r 0) ((setq nf 1)))
(if (or (and (and (< a 0) (< 0 b)) (>= r 0))
(and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
(if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
(and (>= r 0) (< b 0))) ((setq cf 1)))))
(alu :answer :+ '(a b &aux result)
'((cond ((null (self :check_arith a b)) ())
(t (self :clear_flags)
(setq result (+ a b))
(if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
(if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
(self :set_flags a b result)
result))))
(alu :answer :& '(a b &aux result)
'((cond ((null (self :check_logic a b)) ())
(t (self :clear_flags)
(setq result (bit-and a b))
(self :set_flags a b result)
result))))
(alu :answer :| '(a b &aux result)
'((cond ((null (self :check_logic a b)) ())
(t (self :clear_flags)
(setq result (bit-ior a b))
(self :set_flags a b result)
result))))
(alu :answer :~ '(a &aux result)
'((cond ((null (self :check_logic a 0)) ())
(t (self :clear_flags)
(setq result (bit-not a))
(self :set_flags a 0 result)
result))))
(alu :answer :- '(a b)
'((self '+ a (- 0 b))))
(alu :answer :passa '(a)
'(a))
(alu :answer :zero '()
'(0))
(alu :answer :com '(a)
'((self :- 0 a)))
(alu :answer :status '()
'((princ (list "NF "nf"\n"))
(princ (list "ZF "zf"\n"))
(princ (list "CF "cf"\n"))
(princ (list "VF "vf"\n"))))
(alu :answer :clear_flags '()
'((setq nf 0)
(setq zf 0)
(setq cf 0)
(setq vf 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The class Memory
;
(setq memory (Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
; methods
(memory :answer :isnew '(addr_bits data_bits)
'((self :init addr_bits data_bits)
self))
(memory :answer :init '(addr_bits data_bits)
'((setq nabits addr_bits)
(setq ndbits data_bits)
(setq maxu_val (- (pow2 data_bits) 1))
(setq max_addr (- (pow2 addr_bits) 1))
(setq maxs_val (- (pow2 (- data_bits 1)) 1))
(setq mins_val (- 0 (pow2 (- data_bits 1))))
(setq undef (+ maxu_val 1))
(setq memry (array :new max_addr undef))))
(memory :answer :load '(loc val)
'((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
(t (memry :load loc val)))))
(memory :answer :write '(loc val)
'((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
(t (memry :load loc val)))))
(memory :answer :read '(loc &aux val)
'((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
(t (setq val (memry :see loc))
(cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
(t val))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The class array
(setq array (Class :new '(arry)))
; methods
(array :answer :isnew '(n val)
'((self :init n val)
self))
(array :answer :init '(n val)
'((cond ((< n 0) t)
(t (setq arry (cons val arry))
(self :init (- n 1) val)))))
(array :answer :see '(n)
'((nth (+ n 1) arry)))
(array :answer :load '(n val &aux left right temp)
'((setq left (self :left_part n arry temp))
(setq right (self :right_part n arry))
(setq arry (append left (list val)))
(setq arry (append arry right))
val))
(array :answer :left_part '(n ary left)
'((cond ((equal n 0) (reverse left))
(t (setq left (cons (car ary) left))
(self :left_part (- n 1) (cdr ary) left)))))
(array :answer :right_part '(n ary &aux right)
'((cond ((equal n 0) (cdr ary))
(t (self :right_part (- n 1) (cdr ary))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
SHAR_EOF
fi # end of overwriting check
if test -f 'ifthen.lsp'
then
echo shar: will not over-write existing file "'ifthen.lsp'"
else
cat << \SHAR_EOF > 'ifthen.lsp'
; -*-Lisp-*-
;
; If then rules - mini expert from Ch. 18 of Winston and Horn
; Written using recursion without progs
; Added function 'how' to explain deductions
;
; Use:
; After loading type (deduce). It will make all the deductions
; given the list fact. If you want to know how it deduced something
; type (how '(a deduction)) for example (how '(animal is tiger))
; and so on.
; rules data base
(setq rules
'((rule identify1
(if (animal has hair))
(then (animal is mammal)))
(rule identify2
(if (animal gives milk))
(then (animal is mammal)))
(rule identify3
(if (animal has feathers))
(then (animal is bird)))
(rule identify4
(if (animal flies)
(animal lays eggs))
(then (animal is bird)))
(rule identify5
(if (animal eats meat))
(then (animal is carnivore)))
(rule identify6
(if (animal has pointed teeth)
(animal has claws)
(animal has forward eyes))
(then (animal is carnivore)))
(rule identify7
(if (animal is mammal)
(animal has hoofs))
(then (animal is ungulate)))
(rule identify8
(if (animal is mammal)
(animal chews cud))
(then (animal is ungulate)
(even toed)))
(rule identify9
(if (animal is mammal)
(animal is carnivore)
(animal has tawny color)
(animal has dark spots))
(then (animal is cheetah)))
(rule identify10
(if (animal is mammal)
(animal is carnivore)
(animal has tawny color)
(animal has black stripes))
(then (animal is tiger)))
(rule identify11
(if (animal is ungulate)
(animal has long neck)
(animal has long legs)
(animal has dark spots))
(then (animal is giraffe)))
(rule identify12
(if (animal is ungulate)
(animal has black stripes))
(then (animal is zebra)))
(rule identify13
(if (animal is bird)
(animal does not fly)
(animal has long neck)
(animal has long legs)
(animal is black and white))
(then (animal is ostrich)))
(rule identify14
(if (animal is bird)
(animal does not fly)
(animal swims)
(animal is black and white))
(then (animal is penguin)))
(rule identify15
(if (animal is bird)
(animal flys well))
(then (animal is albatross)))))
; utility functions
(defun squash(s)
(cond ((null s) ())
((atom s) (list s))
(t (append (squash (car s))
(squash (cdr s))))))
(defun p(s)
(princ (squash s)))
; functions
; function to see if an item is a member of a list
(defun member(item list)
(cond((null list) ()) ; return nil on end of list
((equal item (car list)) list) ; found
(t (member item (cdr list))))) ; otherwise try rest of list
; put a new fact into the facts data base if it is not already there
(defun remember(newfact)
(cond((member newfact facts) ()) ; if present do nothing
(t ( setq facts (cons newfact facts)) newfact)))
; is a fact there in the facts data base
(defun recall(afact)
(cond ((member afact facts) afact) ; it is here
(t ()))) ; no it is'nt
; given a rule check if all the if parts are confirmed by the facts data base
(defun testif(iflist)
(cond((null iflist) t) ; all satisfied
((recall (car iflist)) (testif (cdr iflist))) ; keep searching
; if one is ok
(t ()))) ; not in facts DB
; add the then parts of the rules which can be added to the facts DB
; return the ones that are added
(defun usethen(thenlist addlist)
(cond ((null thenlist) addlist) ; all exhausted
((remember (car thenlist))
(usethen (cdr thenlist) (cons (car thenlist) addlist)))
(t (usethen (cdr thenlist) addlist))))
; try a rule
; return t only if all the if parts are satisfied by the facts data base
; and at lest one then ( conclusion ) is added to the facts data base
(defun tryrule(rule &aux ifrules thenlist addlist)
(setq ifrules (cdr(car(cdr(cdr rule)))))
(setq thenlist (cdr(car(cdr(cdr(cdr rule))))))
(setq addlist '())
(cond (( testif ifrules)
(cond ((setq addlist (usethen thenlist addlist))
(p (list "Rule " (car(cdr rule)) "\n\tDeduced " addlist "\n\n"))
(setq ruleused (cons rule ruleused))
t)
(t ())))
(t ())))
; step through one iteration if the forward search
; looking for rules that can be deduced from the present fact data base
(defun stepforward( rulelist)
(cond((null rulelist) ()) ; all done
((tryrule (car rulelist)) t)
( t (stepforward(cdr rulelist)))))
; stepforward until you cannot go any further
(defun deduce()
(cond((stepforward rules) (deduce))
(t t)))
; function to answer if a fact was used to come to a certain conclusion
; uses the ruleused list cons'ed by tryrule to answer
(defun usedp(rule)
(cond ((member rule ruleused) t) ; it has been used
(t () ))) ; no it hasnt
; function to answer how a fact was deduced
(defun how(fact)
(how2 fact ruleused nil))
(defun how2(fact rulist found)
(cond ((null rulist) ; if the rule list exhausted
(cond (found t) ; already answered the question return t
((recall fact) (p (list fact " was a given fact\n")) t) ;known fact
(t (p (list fact " -- not a fact!\n")) ())))
((member fact (thenpart (car rulist))) ; if rulist not empty
(setq found t) ; and fact belongs to the then part of a rule
(p (list fact " was deduced because the following were true\n"))
(printifs (car rulist))
(how2 fact (cdr rulist) found))
(t (how2 fact (cdr rulist) found))))
; function to return the then part of a rule
(defun thenpart(rule)
(cdr(car(cdr(cdr(cdr rule))))))
; function to print the if part of a given rule
(defun printifs(rule)
(pifs (cdr(car(cdr(cdr rule))))))
(defun pifs(l)
(cond ((null l) ())
(t (p (list "\t" (car l) "\n"))
(pifs (cdr l)))))
; initial facts data base
; Uncomment one or make up your own
; Then run 'deduce' to find deductions
; Run 'how' to find out how it came to a certain deduction
;(setq facts
; '((animal has dark spots)
; (animal has tawny color)
; (animal eats meat)
; (animal has hair)))
(setq facts
'((animal has hair)
(animal has pointed teeth)
(animal has black stripes)
(animal has claws)
(animal has forward eyes)
(animal has tawny color)))
(setq rl1
'(rule identify14
(if (animal is bird)
(animal does not fly)
(animal swims)
(animal is black and white))
(then (animal is penguin))))
(setq rl2
'(rule identify10
(if (animal is mammal)
(animal is carnivore)
(animal has tawny color)
(animal has black stripes))
(then (animal is tiger))))
; Initialization
(expand 10)
(setq ruleused nil)
SHAR_EOF
fi # end of overwriting check
if test -f 'init.lsp'
then
echo shar: will not over-write existing file "'init.lsp'"
else
cat << \SHAR_EOF > 'init.lsp'
; initialization file for XLISP 1.6
; get some more memory
(expand 1)
; some fake definitions for Common Lisp pseudo compatiblity
(setq first car)
(setq second cadr)
(setq rest cdr)
; (when test code...) - execute code when test is true
(defmacro when (test &rest code)
`(cond (,test ,@code)))
; (unless test code...) - execute code unless test is true
(defmacro unless (test &rest code)
`(cond ((not ,test) ,@code)))
; (makunbound sym) - make a symbol be unbound
(defun makunbound (sym) (setq sym '*unbound*) sym)
; (objectp expr) - object predicate
(defun objectp (x) (eq (type-of x) :OBJECT))
; (filep expr) - file predicate
(defun filep (x) (eq (type-of x) :FILE))
; (unintern sym) - remove a symbol from the oblist
(defun unintern (sym) (cond ((member sym *oblist*)
(setq *oblist* (delete sym *oblist*))
t)
(t nil)))
; (mapcan fun list [ list ]...)
(defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
; (mapcon fun list [ list ]...)
(defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
; (set-macro-character ch fun [ tflag ])
(defun set-macro-character (ch fun &optional tflag)
(setf (aref *readtable* ch) (cons (if tflag :tmacro :nmacro) fun))
t)
; (get-macro-character ch)
(defun get-macro-character (ch)
(if (consp (aref *readtable* ch))
(cdr (aref *readtable* ch))
nil))
; (save fun) - save a function definition to a file
(defmacro save (fun)
`(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
(fval (car ,fun))
(fp (openo fname)))
(cond (fp (print (cons (if (eq (car fval) 'lambda)
'defun
'defmacro)
(cons ',fun (cdr fval))) fp)
(close fp)
fname)
(t nil))))
; (debug) - enable debug breaks
(defun debug ()
(setq *breakenable* t))
; (nodebug) - disable debug breaks
(defun nodebug ()
(setq *breakenable* nil))
; initialize to enable breaks but no trace back
(setq *breakenable* t)
(setq *tracenable* nil)
SHAR_EOF
fi # end of overwriting check
if test -f 'object.lsp'
then
echo shar: will not over-write existing file "'object.lsp'"
else
cat << \SHAR_EOF > 'object.lsp'
; This is an example using the object-oriented programming support in
; XLISP. The example involves defining a class of objects representing
; dictionaries. Each instance of this class will be a dictionary in
; which names and values can be stored. There will also be a facility
; for finding the values associated with names after they have been
; stored.
; Create the 'Dictionary' class.
(setq Dictionary (Class 'new))
; Establish the instance variables for the new class.
; The variable 'entries' will point to an association list representing the
; entries in the dictionary instance.
(Dictionary 'ivars '(entries))
; Setup the method for the 'isnew' initialization message.
; This message will be send whenever a new instance of the 'Dictionary'
; class is created. Its purpose is to allow the new instance to be
; initialized before any other messages are sent to it. It sets the value
; of 'entries' to nil to indicate that the dictionary is empty.
(Dictionary 'answer 'isnew '()
'((setq entries nil)
self))
; Define the message 'add' to make a new entry in the dictionary. This
; message takes two arguments. The argument 'name' specifies the name
; of the new entry; the argument 'value' specifies the value to be
; associated with that name.
(Dictionary 'answer 'add '(name value)
'((setq entries
(cons (cons name value) entries))
value))
; Create an instance of the 'Dictionary' class. This instance is an empty
; dictionary to which words may be added.
(setq d (Dictionary 'new))
; Add some entries to the new dictionary.
(d 'add 'mozart 'composer)
(d 'add 'winston 'computer-scientist)
; Define a message to find entries in a dictionary. This message takes
; one argument 'name' which specifies the name of the entry for which to
; search. It returns the value associated with the entry if one is
; present in the dictionary. Otherwise, it returns nil.
(Dictionary 'answer 'find '(name &aux entry)
'((cond ((setq entry (assoc name entries))
(cdr entry))
(t
nil))))
; Try to find some entries in the dictionary we created.
(d 'find 'mozart)
(d 'find 'winston)
(d 'find 'bozo)
; The names 'mozart' and 'winston' are found in the dictionary so their
; values 'composer' and 'computer-scientist' are returned. The name 'bozo'
; is not found so nil is returned in this case.
SHAR_EOF
fi # end of overwriting check
if test -f 'pcturtle.lsp'
then
echo shar: will not over-write existing file "'pcturtle.lsp'"
else
cat << \SHAR_EOF > 'pcturtle.lsp'
; This is a sample XLISP program
; It implements a simple form of programmable turtle for IBM-PC compatible
; machines.
; To run it:
; A>xlisp pt
; This should cause the screen to be cleared and two turtles to appear.
; They should each execute their simple programs and then the prompt
; should return. Look at the code to see how all of this works.
; Get some more memory
(expand 1)
; Move the cursor to the currently set bottom position and clear the line
; under it
(defun bottom ()
(set-cursor by bx)
(clear-eos))
; Clear the screen and go to the bottom
(defun cb ()
(clear)
(bottom))
; ::::::::::::
; :: Turtle ::
; ::::::::::::
; Define "Turtle" class
(setq Turtle (Class :new '(xpos ypos char)))
; Answer ":isnew" by initing a position and char and displaying.
(Turtle :answer :isnew '() '(
(setq xpos (setq newx (+ newx 1)))
(setq ypos 12)
(setq char "*")
(self :display)
self))
; Message ":display" prints its char at its current position
(Turtle :answer :display '() '(
(set-cursor ypos xpos)
(princ char)
(bottom)
self))
; Message ":char" sets char to its arg and displays it
(Turtle :answer :char '(c) '(
(setq char c)
(self :display)))
; Message ":goto" goes to a new place after clearing old one
(Turtle :answer :goto '(x y) '(
(set-cursor ypos xpos) (princ " ")
(setq xpos x)
(setq ypos y)
(self :display)))
; Message ":up" moves up if not at top
(Turtle :answer :up '() '(
(if (> ypos 1)
(self :goto xpos (- ypos 1))
(bottom))))
; Message ":down" moves down if not at bottom
(Turtle :answer :down '() '(
(if (< ypos by)
(self :goto xpos (+ ypos 1))
(bottom))))
; Message ":right" moves right if not at right
(Turtle :answer :right '() '(
(if (< xpos 80)
(self :goto (+ xpos 1) ypos)
(bottom))))
; Message ":left" moves left if not at left
(Turtle :answer :left '() '(
(if (> xpos 1)
(self :goto (- xpos 1) ypos)
(bottom))))
; :::::::::::::
; :: PTurtle ::
; :::::::::::::
; Define "DPurtle" programable turtle class
(setq PTurtle (Class :new '(prog pc) '() Turtle))
; Message ":program" stores a program
(PTurtle :answer :program '(p) '(
(setq prog p)
(setq pc prog)
self))
; Message ":step" executes a single program step
(PTurtle :answer :step '() '(
(if (null pc)
(setq pc prog))
(if pc
(progn (self (car pc))
(setq pc (cdr pc))))
self))
; Message ":step#" steps each turtle program n times
(PTurtle :answer :step# '(n) '(
(dotimes (x n) (self :step))
self))
; ::::::::::::::
; :: PTurtles ::
; ::::::::::::::
; Define "PTurtles" class
(setq PTurtles (Class :new '(turtles)))
; Message ":make" makes a programable turtle and adds it to the collection
(PTurtles :answer :make '(x y &aux newturtle) '(
(setq newturtle (PTurtle :new))
(newturtle :goto x y)
(setq turtles (cons newturtle turtles))
newturtle))
; Message ":step" steps each turtle program once
(PTurtles :answer :step '() '(
(mapcar '(lambda (turtle) (turtle :step)) turtles)
self))
; Message ":step#" steps each turtle program n times
(PTurtles :answer :step# '(n) '(
(dotimes (x n) (self :step))
self))
; Initialize things and start up
(setq bx 1)
(setq by 21)
(setq newx 1)
; Create some programmable turtles
(cb)
(setq turtles (PTurtles :new))
(setq t1 (turtles :make 40 10))
(setq t2 (turtles :make 41 10))
(t1 :program '(:left :right :up :down))
(t2 :program '(:right :left :down :up))
SHAR_EOF
fi # end of overwriting check
if test -f 'pp.lsp'
then
echo shar: will not over-write existing file "'pp.lsp'"
else
cat << \SHAR_EOF > 'pp.lsp'
;+
; PP 1.0 : (C) Copyright 1985 by Gregory Frascadore
;
; This software may be copied, modified, and distributed to others as long
; as it is not sold for profit, and as long as this copyright notice is
; retained intact. For further information contact the author at:
; frascado%umn-cs.CSNET (on CSNET)
; 75106,662 (on CompuServe)
;-
;+
; PP 1.0
; DESCRIPTION
; PP is a function for producing pretty-printed XLISP code. Version 1.0
; works with XLISP 1.4 and may work with other versions of XLISP or other
; lisp systems.
;
; UPDATE HISTORY
; Version 1.0 - Original version, 11 April 1985 by Gregory Frascadore.
;
;-
;+
; pp
; This function pretty-prints an s-expression.
;
; format
; (pp <expr> [<sink>] )
;
; <expr> the expression to print.
; <sink> optional. the sink to print to. defaults to
; *standard-output*
; <maxlen> the threshold that pp uses to determine when an expr
; should be broken into several lines. The smaller the
; value, the more lines are used. Defaults to 45 which
; seems reasonable and works well too.
;-
(let ((pp-stack* nil)
(pp-istack* nil)
(pp-currentpos* nil)
(pp-sink* nil)
(pp-maxlen* nil))
(defun pp (*expr &optional *sink *maxlen)
(setq pp-stack* nil
pp-istack* '(0)
pp-currentpos* 0
pp-sink* *sink
pp-maxlen* *maxlen)
(if (null pp-sink*) (setq pp-sink* *standard-output*))
(if (null pp-maxlen*) (setq pp-maxlen* 45))
(pp-expr *expr)
(pp-newline)
t)
(defun pp-expr (*expr)
(cond ((consp *expr)
(pp-list *expr) )
(t (pp-prin1 *expr)) ) )
;+
; pp-list
; Pretty-print a list expression.
; IF <the flatsize length of *expr is less than pp-maxlen*>
; THEN print the expression on one line,
; ELSE
; IF <the car of the expression is an atom>
; THEN print the expression in the following form:
; "(atom <item1>
; <item2>
; ...
; <itemn> )"
; ELSE
; IF <the car of the expression is a list>
; THEN print the expression in the following form:
; "(<list1>
; <item2>
; ...
; <itemn> )"
;
;-
(defun pp-list (*expr)
(cond ((< (flatsize *expr) pp-maxlen*)
(pp-prin1 *expr) )
((atom (car *expr))
(pp-start)
(pp-prin1 (car *expr))
(pp-princ " ")
(pp-pushmargin)
(pp-rest (cdr *expr))
(pp-popmargin)
(pp-finish) )
(t (pp-start)
(pp-pushmargin)
(pp-rest *expr)
(pp-popmargin)
(pp-finish) ) ) )
;+
; pp-rest
; pp-expr each element of a list and do a pp-newline after every call to
; pp-expr except the last.
;-
(defun pp-rest (*rest)
(do* ((item* *rest (cdr item*)))
((null item*))
(pp-expr (car item*))
(if (not (null (cdr item*))) (pp-newline)) ) )
;+
; pp-newline
; Print out a newline character and indent to the current margin setting
; which is maintained at the top of the pp-istack. Note that is the
; current top of the pp-stack* is a ")" we push a " " so that we will know
; to print a space before closing any parenthesis which were started on a
; different line from the one they are being closed on.
;-
(defun pp-newline ()
(if (eql ")" (pp-top pp-stack*)) (pp-push " " pp-stack*))
(terpri pp-sink*)
(spaces (pp-top pp-istack*) pp-sink*)
(setq pp-currentpos* (pp-top pp-istack*)) )
;+
; pp-finish
; Print out the closing ")". If the top of the pp-stack* has a " " on it,
; then print out the space, then the ")" , and then pop both off the stack.
;-
(defun pp-finish ()
(cond ((eql ")" (pp-top pp-stack*))
(pp-princ ")") )
(t
(pp-princ " )")
(pp-pop pp-stack*) ) )
(pp-pop pp-stack*) )
;+
; pp-start
; Start printing a list. ie print the "(" and push a ")" on the pp-stack*
; so that pp-finish knows to print a ")" when closing an list.
;-
(defun pp-start ()
(pp-princ "(")
(pp-push ")" pp-stack*) )
;+
; pp-princ
; Prints out an expr without any quotes and updates the pp-currentpos*
; pointer so that we know where on the line the cursor is at.
;-
(defun pp-princ (*expr)
(setq pp-currentpos* (+ pp-currentpos* (flatc *expr)))
(princ *expr pp-sink*) )
;+
; pp-prin1
; Does the same thing as pp-prin1, except that the expr is printed with
; quotes if needed. Hence pp-prin1 uses flatsize to calc expr length instead
; of flatc.
;-
(defun pp-prin1 (*expr)
(setq pp-currentpos* (+ pp-currentpos* (flatsize *expr)))
(prin1 *expr pp-sink*) )
(defmacro pp-push (*item *stack)
`(setq ,*stack (cons ,*item ,*stack)) )
(defmacro pp-pop (*stack)
`(let ((top* (car ,*stack)))
(setq ,*stack (cdr ,*stack))
top*) )
(defun pp-top (*stack) (car *stack))
(defun pp-pushmargin ()
(pp-push pp-currentpos* pp-istack*) )
(defun pp-popmargin ()
(pp-pop pp-istack*) )
(defun spaces (n f)
(dotimes (x n) (write-char 32 f)))
)
SHAR_EOF
fi # end of overwriting check
if test -f 'prolog.lsp'
then
echo shar: will not over-write existing file "'prolog.lsp'"
else
cat << \SHAR_EOF > 'prolog.lsp'
;; The following is a tiny Prolog interpreter in MacLisp
;; written by Ken Kahn and modified for XLISP by David Betz.
;; It was inspired by other tiny Lisp-based Prologs of
;; Par Emanuelson and Martin Nilsson.
;; There are no side-effects anywhere in the implementation.
;; Though it is VERY slow of course.
(defun prolog (database &aux goal)
(do () ((not (progn (princ "Query?") (setq goal (read)))))
(prove (list (rename-variables goal '(0)))
'((bottom-of-environment))
database
1)))
;; prove - proves the conjunction of the list-of-goals
;; in the current environment
(defun prove (list-of-goals environment database level)
(cond ((null list-of-goals) ;; succeeded since there are no goals
(print-bindings environment environment)
(not (y-or-n-p "More?")))
(t (try-each database database
(cdr list-of-goals) (car list-of-goals)
environment level))))
(defun try-each (database-left database goals-left goal environment level
&aux assertion new-enviroment)
(cond ((null database-left) nil) ;; fail since nothing left in database
(t (setq assertion
(rename-variables (car database-left)
(list level)))
(setq new-environment
(unify goal (car assertion) environment))
(cond ((null new-environment) ;; failed to unify
(try-each (cdr database-left) database
goals-left goal
environment level))
((prove (append (cdr assertion) goals-left)
new-environment
database
(+ 1 level)))
(t (try-each (cdr database-left) database
goals-left goal
environment level))))))
(defun unify (x y environment &aux new-environment)
(setq x (value x environment))
(setq y (value y environment))
(cond ((variable-p x) (cons (list x y) environment))
((variable-p y) (cons (list y x) environment))
((or (atom x) (atom y))
(cond ((equal x y) environment)
(t nil)))
(t (setq new-environment (unify (car x) (car y) environment))
(cond (new-environment (unify (cdr x) (cdr y) new-environment))
(t nil)))))
(defun value (x environment &aux binding)
(cond ((variable-p x)
(setq binding (assoc x environment :test #'equal))
(cond ((null binding) x)
(t (value (cadr binding) environment))))
(t x)))
(defun variable-p (x)
(and x (listp x) (eq (car x) '?)))
(defun rename-variables (term list-of-level)
(cond ((variable-p term) (append term list-of-level))
((atom term) term)
(t (cons (rename-variables (car term) list-of-level)
(rename-variables (cdr term) list-of-level)))))
(defun print-bindings (environment-left environment)
(cond ((cdr environment-left)
(cond ((= 0 (nth 2 (caar environment-left)))
(prin1 (cadr (caar environment-left)))
(princ " = ")
(print (value (caar environment-left) environment))))
(print-bindings (cdr environment-left) environment))))
;; a sample database:
(setq db '(((father madelyn ernest))
((mother madelyn virginia))
((father david arnold))
((mother david pauline))
((father rachel david))
((mother rachel madelyn))
((grandparent (? grandparent) (? grandchild))
(parent (? grandparent) (? parent))
(parent (? parent) (? grandchild)))
((parent (? parent) (? child))
(mother (? parent) (? child)))
((parent (? parent) (? child))
(father (? parent) (? child)))))
;; the following are utilities
(defun y-or-n-p (prompt)
(princ prompt)
(eq (read) 'y))
;; start things going
(prolog db)
SHAR_EOF
fi # end of overwriting check
if test -f 'pt.lsp'
then
echo shar: will not over-write existing file "'pt.lsp'"
else
cat << \SHAR_EOF > 'pt.lsp'
; This is a sample XLISP program
; It implements a simple form of programmable turtle for VT100 compatible
; terminals.
; To run it:
; A>xlisp pt
; This should cause the screen to be cleared and two turtles to appear.
; They should each execute their simple programs and then the prompt
; should return. Look at the code to see how all of this works.
; Get some more memory
(expand 1)
; Clear the screen
(defun clear ()
(princ "\e[H\e[J"))
; Move the cursor
(defun setpos (x y)
(princ "\e[") (princ y) (princ ";") (princ x) (princ "H"))
; Kill the remainder of the line
(defun kill ()
(princ "\e[K"))
; Move the cursor to the currently set bottom position and clear the line
; under it
(defun bottom ()
(setpos bx (+ by 1))
(kill)
(setpos bx by)
(kill))
; Clear the screen and go to the bottom
(defun cb ()
(clear)
(bottom))
; ::::::::::::
; :: Turtle ::
; ::::::::::::
; Define "Turtle" class
(setq Turtle (Class :new '(xpos ypos char)))
; Answer ":isnew" by initing a position and char and displaying.
(Turtle :answer :isnew '() '(
(setq xpos (setq newx (+ newx 1)))
(setq ypos 12)
(setq char "*")
(self :display)
self))
; Message ":display" prints its char at its current position
(Turtle :answer :display '() '(
(setpos xpos ypos)
(princ char)
(bottom)
self))
; Message ":char" sets char to its arg and displays it
(Turtle :answer :char '(c) '(
(setq char c)
(self :display)))
; Message ":goto" goes to a new place after clearing old one
(Turtle :answer :goto '(x y) '(
(setpos xpos ypos) (princ " ")
(setq xpos x)
(setq ypos y)
(self :display)))
; Message ":up" moves up if not at top
(Turtle :answer :up '() '(
(if (> ypos 0)
(self :goto xpos (- ypos 1))
(bottom))))
; Message ":down" moves down if not at bottom
(Turtle :answer :down '() '(
(if (< ypos by)
(self :goto xpos (+ ypos 1))
(bottom))))
; Message ":right" moves right if not at right
(Turtle :answer :right '() '(
(if (< xpos 80)
(self :goto (+ xpos 1) ypos)
(bottom))))
; Message ":left" moves left if not at left
(Turtle :answer :left '() '(
(if (> xpos 0)
(self :goto (- xpos 1) ypos)
(bottom))))
; :::::::::::::
; :: PTurtle ::
; :::::::::::::
; Define "DPurtle" programable turtle class
(setq PTurtle (Class :new '(prog pc) '() Turtle))
; Message ":program" stores a program
(PTurtle :answer :program '(p) '(
(setq prog p)
(setq pc prog)
self))
; Message ":step" executes a single program step
(PTurtle :answer :step '() '(
(if (null pc)
(setq pc prog))
(if pc
(progn (self (car pc))
(setq pc (cdr pc))))
self))
; Message ":step#" steps each turtle program n times
(PTurtle :answer :step# '(n) '(
(dotimes (x n) (self :step))
self))
; ::::::::::::::
; :: PTurtles ::
; ::::::::::::::
; Define "PTurtles" class
(setq PTurtles (Class :new '(turtles)))
; Message ":make" makes a programable turtle and adds it to the collection
(PTurtles :answer :make '(x y &aux newturtle) '(
(setq newturtle (PTurtle :new))
(newturtle :goto x y)
(setq turtles (cons newturtle turtles))
newturtle))
; Message ":step" steps each turtle program once
(PTurtles :answer :step '() '(
(mapcar '(lambda (turtle) (turtle :step)) turtles)
self))
; Message ":step#" steps each turtle program n times
(PTurtles :answer :step# '(n) '(
(dotimes (x n) (self :step))
self))
; Initialize things and start up
(setq bx 0)
(setq by 20)
(setq newx 0)
; Create some programmable turtles
(cb)
(setq turtles (PTurtles :new))
(setq t1 (turtles :make 40 10))
(setq t2 (turtles :make 41 10))
(t1 :program '(:left :right :up :down))
(t2 :program '(:right :left :down :up))
SHAR_EOF
fi # end of overwriting check
if test -f 'queens.lsp'
then
echo shar: will not over-write existing file "'queens.lsp'"
else
cat << \SHAR_EOF > 'queens.lsp'
;
; Place n queens on a board
; See Winston and Horn Ch. 11
;
; Usage:
; (queens <n>)
; where <n> is an integer -- the size of the board - try (queens 4)
(defun cadar (x)
(car (cdr (car x))))
; Do two queens threaten each other ?
(defun threat (i j a b)
(or (equal i a) ;Same row
(equal j b) ;Same column
(equal (- i j) (- a b)) ;One diag.
(equal (+ i j) (+ a b)))) ;the other diagonal
; Is poistion (n,m) on the board safe for a queen ?
(defun conflict (n m board)
(cond ((null board) nil)
((threat n m (caar board) (cadar board)) t)
(t (conflict n m (cdr board)))))
; Place queens on a board of size SIZE
(defun queens (size)
(prog (n m board)
(setq board nil)
(setq n 1) ;Try the first row
loop-n
(setq m 1) ;Column 1
loop-m
(cond ((conflict n m board) (go un-do-m))) ;Check for conflict
(setq board (cons (list n m) board)) ; Add queen to board
(cond ((> (setq n (1+ n)) size) ; Placed N queens ?
(print (reverse board)))) ; Print config
(go loop-n) ; Next row which column?
un-do-n
(cond ((null board) (return 'Done)) ; Tried all possibilities
(t (setq m (cadar board)) ; No, Undo last queen placed
(setq n (caar board))
(setq board (cdr board))))
un-do-m
(cond ((> (setq m (1+ m)) size) ; Go try next column
(go un-do-n))
(t (go loop-m)))))
SHAR_EOF
fi # end of overwriting check
if test -f 'queens2.lsp'
then
echo shar: will not over-write existing file "'queens2.lsp'"
else
cat << \SHAR_EOF > 'queens2.lsp'
;
; Place n queens on a board (graphical version)
; See Winston and Horn Ch. 11
;
; Usage:
; (queens <n>)
; where <n> is an integer -- the size of the board - try (queens 4)
(defun cadar (x)
(car (cdr (car x))))
; Do two queens threaten each other ?
(defun threat (i j a b)
(or (equal i a) ;Same row
(equal j b) ;Same column
(equal (- i j) (- a b)) ;One diag.
(equal (+ i j) (+ a b)))) ;the other diagonal
; Is poistion (n,m) on the board safe for a queen ?
(defun conflict (n m board)
(cond ((null board) nil)
((threat n m (caar board) (cadar board)) t)
(t (conflict n m (cdr board)))))
; Place queens on a board of size SIZE
(defun queens (size)
(prog (n m board soln)
(setq soln 0) ;Solution #
(setq board nil)
(setq n 1) ;Try the first row
loop-n
(setq m 1) ;Column 1
loop-m
(cond ((conflict n m board) (go un-do-m))) ;Check for conflict
(setq board (cons (list n m) board)) ; Add queen to board
(cond ((> (setq n (1+ n)) size) ; Placed N queens ?
(print-board (reverse board) (setq soln (1+ soln))))) ; Print it
(go loop-n) ; Next row which column?
un-do-n
(cond ((null board) (return 'Done)) ; Tried all possibilities
(t (setq m (cadar board)) ; No, Undo last queen placed
(setq n (caar board))
(setq board (cdr board))))
un-do-m
(cond ((> (setq m (1+ m)) size) ; Go try next column
(go un-do-n))
(t (go loop-m)))))
;Print a board
(defun print-board (board soln &aux size)
(setq size (length board)) ;we can find our own size
(terpri)
(princ "\t\tSolution: ")
(print soln)
(terpri)
(princ "\t")
(print-header size 1)
(terpri)
(print-board-aux board size 1)
(terpri))
; Put Column #'s on top
(defun print-header (size n)
(cond ((> n size) terpri)
(t (princ n)
(princ " ")
(print-header size (1+ n)))))
(defun print-board-aux (board size row)
(terpri)
(cond ((null board))
(t (princ row) ;print the row #
(princ "\t")
(print-board-row (cadar board) size 1) ;Print the row
(print-board-aux (cdr board) size (1+ row))))) ;Next row
(defun print-board-row (column size n)
(cond ((> n size))
(t (cond ((equal column n) (princ "Q"))
(t (princ ".")))
(princ " ")
(print-board-row column size (1+ n)))))
SHAR_EOF
fi # end of overwriting check
if test -f 'simplepp.lsp'
then
echo shar: will not over-write existing file "'simplepp.lsp'"
else
cat << \SHAR_EOF > 'simplepp.lsp'
;
; a pretty-printer, with hooks for the editor
;
; First, the terminal width and things to manipulate it
(setq pp$terminal-width 79)
(defmacro get-terminal-width nil
pp$terminal_width)
(defmacro set-terminal-width (new-width)
(let ((old-width pp$terminal-width))
(setq pp$terminal-width new-width)
old-width))
;
; Now, a basic, simple pretty-printer
; pp$pp prints expression, indented to indent-level, assuming that things
; have already been indented to indent-so-far. It *NEVER* leaves the cursor
; on a new line after printing expression. This is to make the recursion
; simpler. This may change in the future, in which case pp$pp could vanish.
;
(defun pp$pp (expression indent-level indent-so-far)
; Step one, make sure we've indented to indent-level
(dotimes (x (- indent-level indent-so-far)) (princ " "))
; Step two, if it's an atom or it fits just print it
(cond ((or (not (consp expression))
(> (- pp$terminal-width indent-level) (flatsize expression)))
(prin1 expression))
; else, print open paren, the car, then each sub expression, then close paren
(t (princ "(")
(pp$pp (car expression) (1+ indent-level) (1+ indent-level))
(if (cadr expression)
(progn
(if (or (consp (car expression))
(> (/ (flatsize (car expression)) 3)
pp$terminal-width))
(progn (terpri)
(pp$pp (cadr expression)
(1+ indent-level)
0))
(pp$pp (cadr expression)
(+ 2 indent-level (flatsize (car expression)))
(+ 1 indent-level (flatsize (car expression)))))
(dolist (current-expression (cddr expression))
(terpri)
(pp$pp current-expression
(+ 2 indent-level
(flatsize (car expression)))
0))))
(princ ")")))
nil)
;
; Now, the thing that outside users should call
; We have to have an interface layer to get the final terpri after pp$pp.
; This also allows hiding the second and third args to pp$pp. Said args
; being required makes the pp recursion loop run faster (don't have to map
; nil's to 0).
; The where arg to pp is ingnored, as the obvious hack to pp$pp [adding
; an extra arg to every call to a print routine or pp$pp] doesn't work,
; printing nothing when where is nil.
;
(defun pp (expression &optional where)
"Print EXPRESSION on STREAM, prettily"
(pp$pp expression 0 0)
(terpri))
SHAR_EOF
fi # end of overwriting check
if test -f 'trace.lsp'
then
echo shar: will not over-write existing file "'trace.lsp'"
else
cat << \SHAR_EOF > 'trace.lsp'
(setq *tracelist* nil)
(defun evalhookfcn (expr &aux val)
(if (and (consp expr) (member (car expr) *tracelist*))
(progn (princ ">>> ") (print expr)
(setq val (evalhook expr evalhookfcn nil))
(princ "<<< ") (print val))
(evalhook expr evalhookfcn nil)))
(defun trace (fun)
(if (not (member fun *tracelist*))
(progn (setq *tracelist* (cons fun *tracelist*))
(setq *evalhook* evalhookfcn)))
*tracelist*)
(defun untrace (fun)
(if (null (setq *tracelist* (delete fun *tracelist*)))
(setq *evalhook* nil))
*tracelist*)
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0