OS_Develop/dos_compilers
OS_Develop/dos_compilers
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PC-LISP v3

Browse Source
This commit is contained in:
davidly 2024-07-04 18:51:32 -07:00
parent 5c767c0c2b
commit 98aa02b895
16 changed files with 6128 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
Ashwood-Smith PC-LISP v3/DIFF.L Normal file
View File

@ -0,0 +1,107 @@
; DIFF.L FOR PC-LISP V2.13
; ~~~~~~~~~~~~~~~~~~~~~~~~
; This module is kind of fun, it takes an expression in a prefix lisp
; like form and will compute the derivative of the expression with respect
; to the indicated variable. After symbolic differentiation is done some
; folding is done to remove redundant stuff from the expression. Eg we get
; rid of things multiplied by zero, and fold things with 0 added to them,
; or things raised to the power 1. This reduces the output complexity
; significantly.
;
; Peter Ashwood-Smith
; September 1986.
;
; D(e,X) -
; Will compute the symbolic derivative of expression e with respect
; to varible X. We take the expression in standard lisp prefix form and will
; use the following rules of differentiation.
;
; D(x) = 1
; D(a) = 0
; D(ln u) = D(u)/u
; D(u+v) = D(u)+D(v)
; D(u-v) = D(u)-D(v)
; D(u*v) = D(u)*v + u*D(v)
; D(u/v) = D(u)*v + (u*D(v))/v^2
; D(v^u) = (v^u)*(u*D(v)/v + D(u)*ln(v))
;
(defun D(e X &aux u v)
(cond ((equal e X) 1)
((atom e) 0)
(t (setq u (cadr e) v (caddr e))
(caseq (car e)
(ln `(/ ,(D u X) ,u))
(+ `(+ ,(D u X) ,(D v X)))
(- `(- ,(D u X) ,(D v X)))
(* `(+ (* ,(D u X) ,v) (* ,(D v X) ,u)))
(/ `(- (/ ,(D u X) ,v)
(/ (* ,u ,(D v X)) (^ ,v 2))))
(^ `(* ,e (+ (/ (* ,v ,(D u X)) ,u)
(* ,(D v X) (ln ,u)))))
(t (princ "ERROR") (exit)]
;
; Fold(e) -
; Will traverse the expression 'e' and construct a new expression.
; It checks for things like (* 1 <exp>), (* <exp> 0), (^ <exp> 1), (+ <exp> 0)
; and replaces them with the appropriate things <exp>,0,<exp> and <exp>
; respectively. These simple algabraic modifications greatly reduce the output
; complexity but do not do a complete job by any means. We use the macros
; ?times, ?plus and ?power to do the dirty work for us. We set displace-macros
; to t to cause PC-LISP to substitute the code into the body of Fold thus
; making it much faster.
;
(setq displace-macros t)
(defmacro ?times(v e)
`(and (eq (car ,e) '*) (member ,v ,e]
(defmacro ?plus(v e)
`(and (eq (car ,e) '+) (member ,v ,e]
(defmacro ?power(v e)
`(and (eq (car ,e) '^) (eq (caddr ,e) ,v]
(defun Fold(e)
(cond ((atom e) e)
(t (setq e (cons (Fold (car e)) (Fold (cdr e))))
(cond ((?times 0 e) 0)
((?times 1 e) (cond ((eq (cadr e) 1) (caddr e))
(t (cadr e))))
((?power 1 e) (cadr e))
((?plus 0 e) (cond ((eq (cadr e) 0) (caddr e))
(t (cadr e))))
(t e]
(defun Differentiate(e x)
(Fold (D e x)]
; ----------------- end if differentiate module ------------------
(princ "\t\tSYMBOLIC DIFFERENCIATION\n\n")
(princ "Following is the Input Expression Y\n")
(setq y '(* x (ln (+ x a))))
(pp-form y)
(princ "\nComputing 1st Derivitive of Y with respect to x, Y'\n")
(setq Dy (Differentiate y 'x))
(pp-form Dy)
(princ "\nComputing 2nd Derivitive of Y with respect to x, Y''\n")
(setq DDy (Differentiate Dy 'x))
(pp-form DDy)
(princ "\nComputing 3rd Derivitive of Y with respect to x, Y'''\n")
(setq DDDy (Differentiate DDy 'x))
(pp-form DDDy)
(princ "\nComputing 4th Derivitive of Y with respect to x, Y''''\n")
(setq DDDDy (Differentiate DDDy 'x))
(pp-form DDDDy)
(princ "\nComputing 5th Derivitive of Y with respect to x, Y'''''\n")
(setq DDDDDy (Differentiate DDDDy 'x))
(pp-form DDDDDy)
(princ "\n\nDone (finally)\n")

39
Ashwood-Smith PC-LISP v3/DRAGON.L Normal file
View File

@ -0,0 +1,39 @@
;; DRAGON.L FOR PC-LISP V2.13
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Draw an Nth order Dragon Curve requires Turtle.l routines to run.
;; Taken From Byte April 1986. Try (DragonCurve 16) then put on supper,
;; watch the news and come back in an hour and see the results. It takes
;; about 1/2 hour on my machine so on a normal IBM-PC it should take about
;; an 1.5 hours.
;;
;; Peter Ashwood-Smith.
;; August 1986
;;
;; P.S - This dragon is nicknamed "spot"
(load 'turtle)
(defun Dragon(sign level)
(cond ((zerop level) (TurtleForward Global_Step_Size))
(t (setq level (1- level))
(TurtleRight (times 45 sign))
(Dragon -1 level)
(TurtleLeft (times 90 sign))
(Dragon 1 level)
(TurtleRight (times 45 sign))
)
)
)
(defun DragonCurve (n)
(setq Global_Step_Size 1) ; StepSize is global variable
(TurtleGraphicsUp)
(TurtleCenter)
(TurtleGoTo 330 50)
(TurtleRight 30) ; angle the serpent a bit
(Dragon 1 n)
(gc)
)

33
Ashwood-Smith PC-LISP v3/HANOI.L Normal file
View File

@ -0,0 +1,33 @@
;; HANOI.L for PC-LISP.EXE (V2.13)
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Another program that was found with some XLISP stuff and modified to
;; run under PC-LISP. Again I do not know who the author is.
;;
;; Peter Ashwood-Smith
;; August 22nd, 1986
;; 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 )
(patom "Move Disk From ")
(patom from)
(patom " To ")
(patom to)
(patom "\n")
)
(defun transfer ( from to via n )
(cond ((equal n 1) (print-move from to ))
(t (transfer from via to (1- n))
(print-move from to)
(transfer via to from (1- n)]

33
Ashwood-Smith PC-LISP v3/IF.L Normal file
View File

@ -0,0 +1,33 @@
;--- super if macro
; This macro allow the following forms:
; (If a then b) ==> (cond (a b))
; (If a thenret) ==> (cond (a))
; (If a then b else c) ==> (cond (a b) (t c))
; (If a then b b2 ==> (cond (a b b2) (c d d2) (t e))
; elseif c then d d2
; else e)
;
;
(defun If macro (lis)
(prog (majlis minlis revl)
(do ((revl (reverse lis) (cdr revl)))
((null revl))
(cond ((eq (car revl) 'else)
(setq majlis `((t ,@minlis) ,@majlis)
minlis nil))
((or (eq (car revl) 'then) (eq (car revl) 'thenret))
(setq revl (cdr revl)
majlis `((,(car revl) ,@minlis) ,@majlis)
minlis nil))
((eq (car revl) 'elseif))
((eq (car revl) 'If)
(setq majlis `(cond ,@majlis)))
(t (setq minlis `( ,(car revl) ,@minlis)))))
; we displace the previous macro, that is we actually replace
; the if list structure with the corresponding cond, meaning
; that the expansion is done only once
(rplaca lis (car majlis))
(rplacd lis (cdr majlis))
(return majlis)))
;--- msg : print a message consisting of strings and values

299
Ashwood-Smith PC-LISP v3/MATCH.L Normal file
View File

@ -0,0 +1,299 @@
;; MATCH.L for PC-LISP.EXE (V2.13)
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; A DEDUCTIVE DATA BASE RETRIEVER AS PER LISPcraft CHAPTERS 21&22
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; This file called match.l implements all of the functions in
;; chapters 21 and 22 of LISPcraft by R.Wilensky. Together they form
;; a deductive data base retriever with two access functions. One is
;; called (insert) and the other (retrieve). Insert takes implications
;; and base cases and inserts them into the given data base. (retrieve)
;; returns a list of matches made with the data base and any bindings
;; neccssary to make the match true. Hence an output like (nil) means
;; one match requiring no bindings. The functions have been slightly
;; modified to run with PC-LISP. Note that they require the PC-LISP.L
;; file to be loaded specificially for the let macro and a few other
;; goodies. If you put PC-LISP.L in the current directory it will be
;; automatically loaded. Or you can put it in a library directory, see
;; the (load) function.
;;
;; August 22nd 1986
;; Peter Ashwood-Smith
;;
;; Example queries:
;; (mammal Fido) gives (nil) meaning Yes he is a mammal
;; (dog ?x) gives (?x Fido) meaning Yes if (?x is Fido)
;; (mammal ?x) etc.. you get the idea.
;; (? Fido)
;;
;; You really cannot get much out of this example unless you get
;; the LISPcraft book. Have Fun!
;;
;; Main processing Loop - input a data base query, expand the variables
;; ?x to (*var* x) as the read macro in LISPcraft page 295 would do then
;; pass the request to the (retrieve) function.
;;
(setsyntax '|?| 'vmacro '(lambda()(list '*var* (read))))
(setq displace-macros t) ;runs much faster if let is displaced at eval time
(defun ProcessQueries (data-base)
(prog (InputQuery)
loop (princ "query?")
(setq InputQuery (read))
(cond ((null InputQuery) (return)))
(princ "ans=")
(patom (CompressVariables (retrieve InputQuery data-base)))
(princ (ascii 10))
(go loop)
)
)
;;
;; Opposite of Read Macro for ? - turn list elements like (*var* x) into
;; ?x
;;
(defun CompressVariables (List)
(cond ((null List) ())
((atom List) List)
((eq (car List) '*var*)
(implode (list '|?| (cadr List)))
)
(t (cons(CompressVariables(car List))(CompressVariables (cdr List))))
)
)
;;
;; top level matcher function, just drives the recursive next level
;; by setting bindings to nil.
;;
(defun match (pattern1 pattern2)
(match-with-bindings pattern1 pattern2 nil)
)
(defun match-with-bindings (pattern1 pattern2 bindings)
(cond ((pattern-var-p pattern1)
(variable-match pattern1 pattern2 bindings)
)
((pattern-var-p pattern2)
(variable-match pattern2 pattern1 bindings)
)
((atom pattern1)
(cond ((eq pattern1 pattern2)
(list bindings)
)
)
)
((atom pattern2) nil)
(t (let ((car-result
(match-with-bindings
(car pattern1)(car pattern2) bindings)))
(and car-result
(match-with-bindings
(cdr pattern1)
(cdr pattern2)
(car car-result)
)
)
)
)
)
)
(defun variable-match (pattern-var item bindings)
(cond ((equal pattern-var item) (list bindings))
(t (let ((var-binding (get-binding pattern-var bindings)))
(cond (var-binding
(match-with-bindings var-binding item bindings))
((not (contained-in pattern-var item bindings))
(list (add-binding pattern-var item bindings)))
)
)
)
)
)
(defun contained-in (pattern-var item bindings)
(cond ((atom item) nil)
((pattern-var-p item)
(or (equal pattern-var item)
(contained-in pattern-var
(get-binding item bindings)
bindings)
)
)
(t (or (contained-in pattern-var (car item) bindings)
(contained-in pattern-var (cdr item) bindings)
)
)
)
)
(defun add-binding (pattern-var item bindings)
(cons (list pattern-var item) bindings)
)
(defun get-binding (pattern-var bindings)
(cadr (assoc pattern-var bindings))
)
(defun pattern-var-p (item)
(and (listp item) (eq '*var* (car item)))
)
;;
;; Fast Data Base Manager Operations. Using matcher function above to perform
;; deductive retreival. Indexing as per LISPcraft chapter 22.
;;
(defun replace-variables(item)
(let ((!bindings ()))
(replace-variables-with-bindings item)))
(defun replace-variables-with-bindings(item)
(cond ((atom item) item)
((pattern-var-p item)
(let ((var-binding (get-binding item !bindings)))
(cond (var-binding)
(t (let ((newvar (makevar (gensym 'var))))
(setq !bindings
(add-binding item newvar !bindings))
newvar))
)
)
)
(t (cons (replace-variables-with-bindings (car item))
(replace-variables-with-bindings (cdr item))
)
)
)
)
(defun makevar (atom)
(list '*var* atom)
)
(defun query (request data-base)
(apply 'append (mapcar '(lambda(item)(match item request))
data-base
)
)
)
(defun index (item data-base)
(let ((place (cond ((atom (car item)) (car item))
((pattern-var-p (car item)) '*var*)
(t '*list*)
)
)
)
(putprop place (cons (replace-variables item)(get place data-base))
data-base)
(putprop data-base
(enter place (get data-base '*keys*))
'*keys*)
)
)
(defun enter (e l)
(cond ((not (memq e l)) (cons e l))
(t l)
)
)
(defun fast-query (request data-base)
(cond ((pattern-var-p (car request))
(apply 'append
(mapcar '(lambda(key)(query request (get key data-base)))
(get data-base '*keys*)
)
)
)
(t (append
(query request (get (cond ((atom (car request))
(car request)
)
(t '*list*)
)
data-base
)
)
(query request (get '*var* data-base))
)
)
)
)
;;
;; deductive retreiver (LISPcraft page 314) use backward chaining to establish
;; bindings.
;;
(defun retrieve (request data-base)
(append
(fast-query request data-base)
(apply 'append
(mapcar '(lambda(bindings)
(retrieve
(substitute-vars
(get-binding '(*var* antecedent) bindings)
bindings)
data-base))
(fast-query (list '<- request '(*var* antecedent))
data-base)
)
)
)
)
;;
;; substitute variables for bindings recursively. LISPcraft page 315.
;;
(defun substitute-vars (item bindings)
(cond ((atom item) item)
((pattern-var-p item)
(let ((binding (get-binding item bindings)))
(cond (binding (substitute-vars binding bindings))
(t item)
)
)
)
(t (cons (substitute-vars (car item) bindings)
(substitute-vars (cdr item) bindings)
)
)
)
)
;;
;; page 315 of LISPcraft add too !d-b1!
;; by calling index to insert the implications and base cases.
;;
(index '(<- (scales ?x) (fish ?x)) '!d-b1!) ; fishes have scales
(index '(<- (fins ?x) (fish ?x)) '!d-b1!) ; fishes have fins
(index '(<- (legs ?x) (mammal ?x)) '!d-b1!) ; some mammals have legs
(index '(<- (mammal ?x) (dog ?x)) '!d-b1!) ; a dog is a mammal
(index '(<- (dog ?x) (poodle ?x)) '!d-b1!) ; a poodle is a dog
(index '(poodle Fido) '!d-b1!) ; fido is a poodle
(index '(horse Terry) '!d-b1!) ; terry is a horse
(index '(fish Eric) '!d-b1!) ; Eric is a fish
;;
;; start processing queries from data base #1 which was entered above
;; some good things to try are (mammal Fido) which will return (nil)
;; meaning that one match was found needing no bindings to make it true.
;; this was established via the chain (poodle Fido)-->(dog Fido)-->
;; (mammal Fido).
;;
(defun run() (ProcessQueries '!d-b1!))
(princ "Data Base Retreiver Loaded and Ready To Go")
(princ (ascii 10))
(princ "Just type (run) to start it, have fun.")
(princ (ascii 10))

321
Ashwood-Smith PC-LISP v3/MATH.L Normal file
View File

@ -0,0 +1,321 @@
;================; Bill Forseth
; TRIG FUNCTIONS ; 817 1/2 N. 10 ave E.
; 11.27.89 ; Duluth, MN 55805
;================; (218) 724-8910
; NOTES: All function inputs evaluating to 'undefined' are returned as '0'.
; BUGS: PC-LISP's sin and cos functions evaluate pi at 3.141. In increasing
; the the length of the fractional part of pi cos and sin had to be
; semi-redefined (via functions chkman and round, mostly). Thus the
; angle functions return 0, -.5, .5, 1, -1, 2 etc. when they should -
; BUT for very small angle differences (i +/- 0.00001 radians where
; i is any integer) the result becomes rounded.
; As far as I know the equations are accurate - they were checked with
; formulas found in any standard algebra/trig/calc textbook.
; FUTURE: Elaboration of differentials, perhaps symbolic routines for
; factoring standard and differential combinations.
;-------------------------------------------------
; PPOWER
; Returns x to the n-th (where x and n may be
; positive or negative, whole numbers or fractions).
; Attmepts at taking the root of a negative are headed
; off and the function returns the abs value.
; Syntax: (ppower <constant> <exponent>)
; ie: (ppower 25 -0.5)
;--------------------------------------------------
(defun ppower (x n)
(cond
((zerop x) 0) ((= 1 n) x)
((or (zerop n) (= 1 x)) 1)
((minusp n) (invert (ppower x (abs n))))
((> 1 n) (expt (abs x) n))
(t
(** x (ppower x (diff n 1))))))
;---------------------------------------
; LLOG
; Returns log(a) / log(b)
; Syntax: (llog <argument1> <argument2>)
; ie: (llog 2 16)
;---------------------------------------
(defun llog (a b)
(cond
((or (= 1 b) (= 1 a) (zerop a)
(zerop b) (minusp a) (minusp b)) 0)
(t (// (log b) (log a)))))
;----------------------------------------
; ADJRAD
; Puts x in the range of 0 <= x < 2pi,
; x in radians.
; Syntax: (adjrad <argument>)
; ie: (adjrad 31.41)
;----------------------------------------
(defun adjrad (x)
(cond
((= (abs x) (2pi)) 0)
((< x 0) (adjrad (add x (2pi))))
((> x (2pi)) (adjrad (diff x (2pi))))
(t x)))
;----------------------------------------
; ADJDEG
; Puts d in the range of 0 <= d < 360,
; d in degrees.
; Syntax: (adjdeg <argument>)
; ie: (adjdeg -780)
;----------------------------------------
(defun adjdeg (d)
(cond
((or (zerop d) (= (abs d) 360)) 0)
((> d 360) (adjdeg (diff d 360)))
((< d 0) (adjdeg (add d 360)))
(t d)))
;-------------------------------
; D2R
; Converts degrees to radians.
; Syntax: (d2r <argument>)
; ie: (d2r 180)
;-------------------------------
(defun d2r (x)
(// (** (adjdeg x) (pi)) 180))
;-------------------------------
; R2D
; Converts radians to degrees.
; Syntax: (r2d <argument>)
; ie: (r2d 3.14)
;-------------------------------
(defun r2d (x)
(// (** (adjrad x) 180) (pi)))
;---------------------------------------
; PI functions
; All arguments in positive or negative,
; whole numbers or fractions.
;---------------------------------------
(defun pi () 3.141592) ;Returns the value of pi to 6th place
;(not rounded)
;Syntax: (pi)
(defun pi/ (x) (// (pi) x)) ;Returns pi divided by x
;Syntax: (pi/ <argument>)
(defun pi* (x) (** (pi) x)) ;Returns pi times x
;Syntax: (pi* <argument>)
(defun pi*/ (n d) ;Returns pi times n/d
(** (pi) (// n d))) ;Syntax: (pi*/ <argument1> <argument2>)
(defun pi/* (n d) ;<-- forgiving function
(** (pi) (// n d)))
;Shorthand pi functions for frequently used angles - -
(defun 2pi () (pi* 2)) ;360 deg.
(defun pi2 () (pi/ 2)) ;90 "
(defun pi3 () (pi/ 3)) ;60 "
(defun pi4 () (pi/ 4)) ;45 "
(defun pi6 () (pi/ 6)) ;30 "
;-----------------------------------------
; SINr
; Modified sin for the current value of pi
; Syntax: (sinr <argument>)
;-----------------------------------------
(defun sinr (x) (chkman (sin (adjrad x))))
;-----------------------------------------
; COSr
; Modified cos for the current value of pi
; Syntax: (cosr <argument>)
;-----------------------------------------
(defun cosr (x) (chkman (cos (adjrad x))))
;--------------------------------------
; TANr
; Returns the tangent of x, where x is
; in radians.
; Syntax: (tanr <argument>)
;--------------------------------------
(defun tanr (x)
(cond
((or (zerop (cosr x)) (zerop (sinr x))) 0)
(t (chkman (adjrad (// (sinr x) (cosr x)))))))
;-------------------------------
; SINd
; Returns sin of DEGREE argument
; Syntax: (sind <argument>)
;-------------------------------
(defun sind (d) (chkman (adjrad (sinr (d2r d)))))
;-------------------------------
; COSd
; Returns cos of DEGREE argument
; Syntax: (cosd <argument>)
;-------------------------------
(defun cosd (d) (chkman (adjrad (cosr (d2r d)))))
;---------------------------------------
; TANd
; Returns the tangent of DEGREE argument
; Syntax: (tand <argument>)
;---------------------------------------
(defun tand (d)
(cond
((or (zerop (cosd d)) (zerop (sind d))) 0)
(t (chkman (adjrad (// (sind d) (cosd d)))))))
;-----------------------------
; INVERSE functions
; Arguments (___r) in radians,
; (___d) in degrees.
;-----------------------------
(defun secr (x) (adjrad (invert (cosr x))))
(defun cscr (x) (adjrad (invert (sinr x))))
(defun cotr (x) (adjrad (invert (tanr x))))
(defun secd (d) (adjdeg (invert (cosd d))))
(defun cscd (d) (adjdeg (invert (sind d))))
(defun cotd (d) (adjdeg (invert (tand d))))
;--------------------------
; DERIVITIVE functions
; All arguments in radians.
;--------------------------
(defun sin_prime (x) (cosr x))
(defun cos_prime (x) (neg (sinr x)))
(defun tan_prime (x) (chkman (adjrad (ppower (secr x) 2))))
(defun sec_prime (x) (chkman (adjrad (** (secr x) (tanr x)))))
(defun csc_prime (x) (chkman (adjrad (neg (** (cscr x) (cotr x))))))
(defun cot_prime (x) (chkman (adjrad (ppower (cscr x) 2))))
;------------------------------------------------
; DOUBLE and HALF angles formulas.
; All arguments in radians.
; To use degrees use (d2r d) as the arguments.
; To have the return in degrees nest the function
; inside (r2d (<. . .>))
;-------------------------------------------------
(defun sinA+B (a b)
(chkman (adjrad (add (** (sinr a) (cosr b)) (** (cosr a) (sinr b))))))
(defun sinA-B (a b)
(chkman (adjrad (diff (** (sinr a) (cosr b)) (** (cosr a) (sinr b))))))
(defun cosA+B (a b)
(chkman (adjrad (diff (** (cosr a) (cosr b)) (** (sinr a) (sinr b))))))
(defun cosA-B (a b)
(chkman (adjrad (add (** (cosr a) (cosr b)) (** (sinr a) (sinr b))))))
(defun tanA+B (a b)
(cond
((zerop (cosA+B a b)) 0)
(t (chkman (adjrad (// (sinA+B a b) (cosA+B a b)))))))
(defun tanA-B (a b)
(cond
((zerop (cosA-B a b)) 0)
(t (chkman (adjrad (// (sinA-B a b) (cosA-B a b)))))))
(defun sin2A (a)
(chkman (adjrad (** 2 (sinr a) (cosr a)))))
(defun cos2A (a)
(chkman (adjrad (diff (ppower (cosr a) 2) (ppower (sinr a) 2)))))
(defun tan2A (a)
(cond
((zerop (cos2A a)) 0)
(t (chkman (adjrad (// (sin2A a) (cos2A a)))))))
(defun sinhalfA (a)
(chkman (adjrad (sqrt (abs (// (diff 1 (cosr a)) 2))))))
(defun coshalfA (a)
(chkman (adjrad (sqrt (abs (// (add 1 (cosr a)) 2))))))
(defun tanhalfA (a)
(cond
((zerop (coshalfA a)) 0)
(t (chkman (adjrad (// (sinhalfA a) (coshalfA a)))))))
;-------------------------
; MISC functions
;-------------------------
(defun invert (x) ;returns 1/x
(cond ((zerop x) 0) (t (chkman (// 1 x)))))
(defun neg (x) (** -1 x)) ;returns -x
(defun // fexpr(l) (eval (cons 'quotient l))) ;shorthand div. of floats
(defun ** fexpr(l) (eval (cons 'times l))) ;shorthand mult. of floats
(defun chkman (x) ;returns nearest whole number if
(cond ;fraction is very small or large
((< (abs (diff (abs x) (abs (round x)))) 0.00001)
(round x))
(t x)))
(defun round (x) ;rounding function
(cond
((zerop x) 0)
((plusp x)
(cond
((< (diff x (fix x)) .5) (fix x))
(t (add 1 (fix x)))))
(t (cond
((< (diff (abs x) (fix (abs x))) .5) (fix x))
(t (neg (diff 1 (fix x))))))))
(defun gint (x) ;greatest integer function
(cond
((zerop x) 0)
((plusp x) (fix x))
((minusp x)
(cond
((= x (fix x)) x)
(t (diff (fix x) 1))))
(t x)))
(defun rangep (a x b) ;true if a <= x <= b
(cond
((and (not (< x a)) (not (> x b))) t)
(t nil)))


3713
Ashwood-Smith PC-LISP v3/PC-LISP.DOC Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
Ashwood-Smith PC-LISP v3/PC-LISP.EXE Normal file
View File

Binary file not shown.

351
Ashwood-Smith PC-LISP v3/PC-LISP.L Normal file
View File

@ -0,0 +1,351 @@
;; PC-LISP.L for PC-LISP.EXE V2.15
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; A small library of functions to help fill in the gap between PC and
;; Franz Lisp. These functions are not documented in the PC-LISP.DOC file but
;; any Franz manual will cover them in detail. Especially the backquote
;; and other macro definitions towards the end of the file. These functions
;; were written pretty hastily so there could be bugs. Check them out for
;; yourself to make sure they behave in the way you are used to with Franz.
;;
;; This file is automatically loaded by PC-LISP.EXE. It should either
;; be located in the current working directory, or in a library directory
;; whose path is set in the LISP_LIB environment variable. All load files
;; should be put in one of your LISP_LIB directories. You could also strip
;; comments and white space from this file to make it load faster. This
;; is important if you load this file every time you run PC-LISP.
;;
;; Peter Ashwood-Smith
;; November 1986
;;
;; Pretty Print: (pp [(F file) (E expr) (P port)] symbol)
;; ~~~~~~~~~~~~
;; Print in a readable way the function associated with 'symbol'. If
;; the parameter (F file) is specified the output goes to file 'file. If
;; the parameter (P port) is specified the output goes to the open port
;; 'port'. If the parameter (E expr) is specified the expression 'expr'
;; is evaluated before the function is pretty printed. Makes use of the
;; predefined symbol poport whose binding is 'stdout'.
(setq displace-macros t) ; override Franz default (faster do loops)
(defun pp fexpr(l)
(prog (expr name port alt)
(setq port poport)
(cond ((= (length l) 1) (setq name (car l)))
((= (length l) 2) (setq name (cadr l) alt (car l)))
(t (return nil))
)
(cond ((null (getd name)) (return nil)))
(setq expr (cons 'def (cons name (list (getd name)))))
(cond ((null alt) (go SKIP)))
(cond ((eq (car alt) 'F) (setq port (fileopen (cadr alt) 'w)))
((eq (car alt) 'P) (setq port (cadr alt)))
((eq (car alt) 'E) (eval (cadr alt)))
(t (return nil)))
(cond ((null port) (patom "cannot open port\n") (return nil)))
SKIP (pp-form expr port 0)
(cond ((not (equal port poport)) (close port)))
(return t)
)
)
;; _SCL_ Spit Character Loop
;; ~~~~~~~~~~~~~~~~~~~~~~~~~
;; Prints 'char' 'n' times on port 'port', used by msg for (N) and (B)
(defun _SCL_(port char n)
(prog nil
nxt: (cond ((zerop n) (return)))
(patom char port)
(setq n (1- n))
(go nxt:)
)
)
;; (msg [B|N|D] [ (P pt) (B n) | (N n)] s*)
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Prints a message on standard output port 'poport'. Where N is a new
;; line, (N n) means n new lines. B is a blank, (B n) means n blanks
;; D means (Dran port) unsupported in PC-LISP. (P pt) means switch output
;; to port pt rather than poport. s, is any s expression which will be
;; evaluated and then printed on current output port.
(defun msg fexpr(l)
(prog (s op)
(setq op poport)
nxt: (cond ((null l)(return)))
(setq s (car l) l (cdr l))
(cond ((eq s 'N) (patom "\n" op))
((eq s 'B) (patom " " op))
((eq s 'D) (patom "msg : Drain unsupported\n"))
((listp s)
(cond ((eq (car s) 'P)(setq op (cadr s)))
((eq (car s) 'B)(_SCL_ op " " (cadr s)))
((eq (car s) 'N)(_SCL_ op "\n" (cadr s)))
(t (patom (eval s) op))
)
)
(t (patom (eval s) op))
)
(go nxt:)
)
)
;; (lineread [port])
;; ~~~~~~~~~~~~~~~~~
;; Very simple line read function. Takes atoms from the piport or port until
;; a new line is encountered. It returns these atoms or S-expressions as a
;; list 'ret.
(defun lineread fexpr(l)
(prog (port ret)
(setq port piport)
(cond ((not (null l)) (setq port (eval (car l)))))
(setq ret (list (read port)))
nxt: (cond ((eq (readc port) '|\n|)(return ret)))
(setq ret (append ret (list (read port))))
(go nxt:)
)
)
;; ----------- ASSORTED SMALL FUNCTIONS ------------
(defun tailp(l1 l2)(cond ((null l2) nil)((eq l1 l2) l1)(t(tailp l1(cdr l2]
(defun bcdp(x) nil)
(defun bigp(x) nil)
(defun dtpr(x) (and (listp x) (not (null x))))
(defun consp(x) (and (listp x) (not (null x))))
(defun litatom(n) (and(atom n)(not(floatp n]
(defun purep(n) nil)
(defun symbolp(n) (litatom n))
(defun valuep(n) nil)
(defun vectorp(n) nil)
(defun typep(n)(type n))
(defun eqstr(a b)(equal a b))
(defun neq(a b)(not(eq a b)))
(defun nequal(a b)(not(equal a b)))
(defun append1(a b)(append a (list b)))
(defun ncons(a)(cons a nil))
(defun xcons(a b)(cons b a))
(defun nthelem(n l) (nth (1- n) l))
(defun minus(n)(- 0 n))
(defun onep(n)(= 1 n))
(defun infile(f)(fileopen f 'r))
(defun pntlen(a) (flatsize a))
(defun probef(f &aux tmp)(setq tmp (fileopen f 'r))(and tmp (close tmp)))
(defun shell()(exec "COMMAND.COM")) ; must have a COMMAND.COM on PATH!
(defun error n
(cond ((= n 1) (patom (arg 1)) (terpri) (err nil))
((= n 2) (patom (arg 1)) (patom (arg 2)) (terpri) (err nil))
(t (error "error bad args"))]
(defun signp(test exp)
(cond ((eq test 'ge) (or (zerop exp)(plusp exp)))
((eq test 'g ) (plusp exp))
((eq test 'n ) (not (zerop exp)))
((eq test 'e ) (zerop exp))
((eq test 'le) (or (zerop exp)(minusp exp)))
((eq test 'l) (minusp exp))
(t (princ "-- error signp bad test ---\n"))))
;; ----------- ASSORTED SMALL MACROS --------------
(defun >& macro(l) (cons '> (cdr l)))
(defun >= macro(l) (cons 'not (list (cons '< (cdr l)))))
(defun >=& macro(l) (cons 'not (list (cons '< (cdr l)))))
(defun <& macro(l) (cons '< (cdr l)))
(defun <= macro(l) (cons 'not (list (cons '> (cdr l)))))
(defun <=& macro(l) (cons 'not (list (cons '> (cdr l)))))
(defun =& macro(l) (cons '= (cdr l)))
(defun terpri macro(l) ; makes (terpri [port])
(append (list 'princ "\n")(cdr l))) ; into (princ "\n" [port])
(defun tyo macro(l) ; makes (princ (asci f) [port])
(cons 'princ (cons (cons 'ascii (list (cadr l))) (cddr l))))
(defun store macro(l) ; makes (store (x -dims-) exp)
(cons (caadr l) ; into (x exp -dims-)
(append (cddr l) (cdadr l))))
(defun arraycall macro(l) ; makes (arraycall f a -n-)
(cddr l)) ; into (a -n-)
;; BACKQUOTE READ MACRO AND PARTS
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; This file describes the back quote macro for PC-LISP. It works in
;; exactly the same way as the FRANZ backquote macro works. Basically the
;; backquote macro ` is supposed to work together with the comma , and at
;; @ macros. As follows: Backquote has the same effect as ' except that any
;; elements or sub elements that are preceeded by , are evaluated. If an
;; element is preceeded by ,@ then the element is evaluated and should
;; evaluate to a list. This list is spliced into the built list. I use
;; cons to do list building and append to do list splicing. For example
;; the input: `(a ,b c) will be read in as (a (*unquote* b) c) by the
;; back quote read macro because the comma macro will have read the b and
;; built up the list (*unquote* b). Next the back quote macro passes control
;; to the _BQB_ function (Back Quote Builder). This will construct the list
;; (cons 'a (cons b (cons 'c nil))) which when evaluated gives the desired
;; result. If the , were followed by an @ then the @ would build the form
;; (*splice* b). Then the , would get this form and the function _CB_ comma
;; builder would then make then pass the form unchanged. Next the backquote
;; builder _BQB_ would get the form (a (*splice* b) c) and build the form
;; (cons 'a (append b (cons 'c nil))) which will cause the value of b to be
;; spliced into the list rather than forming a sublist element as desired.
(defun _BQB_(Sexp)
(cond ((null Sexp) Sexp)
((atom Sexp) (list 'quote Sexp))
((eq (car Sexp) '*unquote*)
(cadr Sexp))
((and(listp (car Sexp)) (eq (caar Sexp) '*splice*))
(list 'append (cadar Sexp)
(_BQB_ (cdr Sexp))))
( t (list 'cons (_BQB_ (car Sexp))
(_BQB_ (cdr Sexp))))
)
)
(defun _CB_(Sexp)
(cond ((null Sexp) Sexp)
((atom Sexp) (list '*unquote* Sexp))
((eq (car Sexp) '*splice*) Sexp)
(t (list '*unquote* Sexp))
)
)
(setsyntax '|`| 'vmacro '(lambda()(_BQB_ (read))))
(setsyntax '|,| 'vmacro '(lambda()(_CB_ (read))))
(setsyntax '|@| 'vmacro '(lambda()(list '*splice* (read))))
;; macro : (let ((p1 v1)(p2 v2)...(pn vn)) e1 e2 ... en)
;; ~~~~~
;; Let macro introduces local variables. Much used in Franz code it
;; basically creates a lambda expression of the form:
;;
;; ((lambda(p1 p2 ... pn) e1 e2 ... en) v1 v2 ...vn)
;; Note that (p1 v1) may be of the form p1 in which case the variable
;; is bound to nil.
(defun let macro(l)
`((lambda ,(mapcar '_lvar (cadr l))
,@(cddr l)
)
,@(mapcar '_lval (cadr l]
(defun _lvar (l)(cond ((atom l) l) (t (car l]
(defun _lval (l)(cond ((atom l) nil) (t (cadr l]
;; macro defmacro
;; ~~~~~~~~~~~~~~
;; Like defun except that it declares a macro. This is more convenient
;; than using the defun name macro(l) because access to variables can be
;; named.
(defun defmacro fexpr(l)
(putd (car l)
(cons 'macro
(list '(defmacroarg)
`((lambda ,(__dmlats (cadr l))
,@(cddr l))
,@(__dmal (cadr l))]
(defun defcmacro fexpr(l) ; no such thing as compiler yet but
(putd (car l) ; keeps interpreter happy
(cons 'macro
(list '(defmacroarg)
`((lambda ,(__dmlats (cadr l))
,@(cddr l))
,@(__dmal (cadr l))]
(defun __dma(l a)
(cond ((null l) nil)
((atom l) (setq __dmalhold (cons a __dmalhold)))
(t (__dma (car l) (cons 'car (list a)))
(__dma (cdr l) (cons 'cdr (list a)))]
(defun __dmal(l &aux __dmalhold)
(__dma l '(cdr defmacroarg))
(reverse __dmalhold ]
(defun __dmlats(l)
(cond ((null l) nil)
((atom l) (list l))
( t (append (__dmlats (car l)) (__dmlats (cdr l)))]
;; (do "symbol" "exp1" "exp2" "test" -"exps"-) ; case 1
;; (do -"(symbol [exp1 [exp2]])"- "test" -"exps"-) ; case 2
;;
(defun _do2a_(l) (cond ((cdr l)(cons (car l) (list(cadr l))))(t nil]
(defun _do2b_(l) (cond ((cddr l)(cons (car l) (list(caddr l))))(t nil]
(defun _do2_(l) ; complex do loop case, many locals
`(prog ,(mapcar 'car (cadr l))
(PAR-setq ,@(apply 'append (mapcar '_do2a_ (cadr l))))
_dlab_
(cond (,(caaddr l) (return ,@(cdaddr l)) ))
,@(cdddr l)
(PAR-setq ,@(apply 'append (mapcar '_do2b_ (cadr l))))
(go _dlab_)
)
)
(defun _do1_(l) ; simple do loop case, one local
`(prog (,(nth 1 l))
(setq ,(nth 1 l) ,(nth 2 l))
_dlab_ (cond (,(nth 4 l) (return)))
,@(cdddddr l)
(setq ,(nth 1 l) ,(nth 3 l))
(go _dlab_)
)
)
(defun do macro(l) ; select simple/complex case.
(cond ((atom (cadr l)) (_do1_ l))
(t (_do2_ l))))
;; This macro allow the following forms:
;; (if a then b) ==> (cond (a b))
;; (if a thenret) ==> (cond (a))
;; (if a then b else c) ==> (cond (a b) (t c))
;; (if a then b b2 ==> (cond (a b b2) (c d d2) (t e))
;; elseif c then d d2
;; else e)
;;
;; I stole this from the SLANG package and changed its name to 'if from
;; 'If.
;;
(defun if macro (lis)
(prog (majlis minlis revl)
(do ((revl (reverse lis) (cdr revl)))
((null revl))
(cond ((eq (car revl) 'else)
(setq majlis `((t ,@minlis) ,@majlis)
minlis nil))
((or (eq (car revl) 'then) (eq (car revl) 'thenret))
(setq revl (cdr revl)
majlis `((,(car revl) ,@minlis) ,@majlis)
minlis nil))
((eq (car revl) 'elseif))
((eq (car revl) 'if)
(setq majlis `(cond ,@majlis)))
(t (setq minlis `( ,(car revl) ,@minlis)))))
; we displace the previous macro, that is we actually replace
; the if list structure with the corresponding cond, meaning
; that the expansion is done only once
(rplaca lis (car majlis))
(rplacd lis (cdr majlis))
(return majlis)))
;; A couple of rareley used definitions but just to complete the chapter
;; on mapping functions, here they are:
;;
(defun mapcan macro(l) `(apply 'nconc (mapcar ,@(cdr l))))
(defun mapcon macro(l) `(apply 'nconc (maplist ,@(cdr l))))
;; The progS functions again to fill in some gaps
;;
(defun progn macro(l) `(prog nil ,@(cdr l)))
(defmacro prog1(a . b) `(prog (__p1ret) (setq __p1ret ,a) ,@b __p1ret))
(defmacro prog2(a b . c) `(prog (__p2ret) ,a (setq __p2ret ,b) ,@c __p2ret))

759
Ashwood-Smith PC-LISP v3/Q&A.L Normal file
View File

@ -0,0 +1,759 @@
;; Q&A.L - quality assurance tests
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; A set of calls and correct results to make sure that PC-LISP is
;; behaving itself. These are run after every change to the source to
;; make sure things are kosher. If a new function is added a set of
;; tests should be added also. Test results are printed on file whose
;; open port is 'where'.
(defun Q&A(ListOfTests where tracing)
(prog (input result wwanted)
(patom (ascii 10) where)
(patom '|=============== NEXT TEST SUIT ================| where)
(patom (ascii 10) where)
LAB: (cond ((null ListOfTests) (return t)))
(setq input (caar ListOfTests) wanted (cadar ListOfTests))
(cond (tracing (patom input)(patom "\n")))
(setq wanted (eval wanted))
(setq result (eval input))
(setq wwanted (eval wanted))
(cond ((and (null (equal wwanted result))
(null (NearlyEqual wwanted result)))
(patom "FAIL: Input, Expected and Actual :\n" where)
(patom input)
(patom "\n" where)
(patom wwanted)
(patom "\n" where)
(patom result)
(patom "\n" where)))
(setq ListOfTests (cdr ListOfTests))
(go LAB:)
)
)
;; TEST OF MATH FUNCTIONS
;; ~~~~~~~~~~~~~~~~~~~~~~
;; Test the math functions to make sure they are producing sensible results.
;; No precision tests, these were done before math library was added to PC-LISP
(setq List#1_Math_Functions
'( ( (abs 5000) 5000 )
( (abs -5000) 5000 )
( (acos (cos 1.0)) 1.0 )
( (asin (sin 1.0)) 1.0 )
( (acos (cos .45)) .45 )
( (asin (sin .45)) .45 )
( (sum (times (cos .45) (cos .45) )
(times (sin .45) (sin .45) )) 1.0 )
( (atan 1.0 1.0 ) .785398163 )
( (atan .22 1.0 ) .216550305 )
( (log 2.718281828) 1.0 )
( (log (exp 10)) 10 )
( (expt 2 8) 256 )
( (expt 3 6) (* 3 3 3 3 3 3 ))
( (expt 2.2 3.3) (exp (times 3.3 (log 2.2))) )
( (fact 0) 1 )
( (fact 10) (* 10 (fact 9)) )
( (fact 5) (* 5 4 3 2 1) )
( (log10 (* 10 10 10 10 10 10 10 10)) 8 )
( (log10 1) 0 )
( (max) 0 )
( (min) 0 )
( (max 14) 14 )
( (min 14) 14 )
( (max 0 1 2 -3 10 -14 50 100 0 -10 -19) 100 )
( (min 0 1 2 -3 10 -14 50 100 0 -10 -13) -14 )
( (mod 8 2) 0 )
( (mod 16 3) 1 )
( (mod -16 -3) -1 )
( (mod -16 3) -1 )
( (mod 16 -3) 1 )
( (> 15 (random 15)) t )
( (> 1 (random 1)) t )
( (not (= (random) (random))) t )
( (sqrt (* 2345 2345)) 2345 )
( (sqrt 49) 7 )
( (sqrt 1) 1 )
( (*) 1 )
( (/) 1 )
( (+) 0 )
( (-) 0 )
( (* 5 4 3 2 1) (fact 5) )
( (/ 1000 10 10 10) 1 )
( (+ 1 2 3 4 5) 15 )
( (- 10 1 2 3 1 2 1) 0 )
( (add1 8) 9 )
( (add1 8.0) 9.0 )
( (sub1 8) 7 )
( (sub1 8.0) 7.0 )
( (times) 1 )
( (add) 0 )
( (diff) 0 )
( (quotient) 1 )
( (times 2.0) 2.0 )
( (add 2.0) 2.0 )
( (diff 2.0) 2.0 )
( (quotient 2.0) 2.0 )
( (add 2.2 2.2 2.2 2.2 2.2) 11 )
( (diff 11 2.2 2.2 2.2 2.2 2.2) 0 )
( (times 1.0 2.0 3.0 4.0 5.0) (fact 5) )
( (quotient 8.0 2.0 2.0 2.0) 1 )
( (oddp 10) nil )
( (oddp 0) nil )
( (oddp -10) nil )
( (oddp 11) t )
( (evenp -11) nil )
( (evenp 10) t )
( (evenp 0) t )
( (evenp -10) t )
( (evenp 11) nil )
( (evenp -11) nil )
( (and (zerop 0) (zerop 0.0)) t )
( (zerop 8) nil )
( (zerop -8.0) nil )
( (minusp 0) nil )
( (minusp 8.0) nil )
( (minusp 8) nil )
( (minusp -1.0) t )
( (plusp 0) nil )
( (plusp -8.0) nil )
( (plusp -8) nil )
( (plusp 1.0) t )
( (< 0 0) nil )
( (> 0 0) nil )
( (= 0 0) t )
( (< -10 10) t )
( (> 10 -10) t )
( (= -10 -10) t )
( (< 10 -10) nil )
( (> -10 10) nil )
( (1+ 0) 1 )
( (1- 0) -1 )
( (1+ 100) 101 )
( (1- -100) -101 )
( (greaterp 1.0) t )
( (lessp 1.0) t )
( (greaterp 10.0 9.9 9.8 9 8.9) t )
( (lessp 1.0 2.0 3.0 3.9 4 5 6 7) t )
( (greaterp 10.0 9.9 9.8 9 9.0) nil )
( (lessp 1.0 2.0 3.0 4.0 4 5 6 7) nil )
( (fixp 10) t )
( (fixp -10.0) nil )
( (fixp 'a) nil )
( (fixp '(a)) nil )
( (fixp poport) nil )
( (fixp "no") nil )
( (numberp 0) t )
( (numberp 0.0) t )
( (numberp 'a) nil )
( (numberp '(a)) nil )
( (numberp poport) nil )
( (numberp "no") nil )
( (lsh 1 8) 256 )
( (lsh 256 -8) 1 )
)
)
;; TEST OF SIMPLE PREDICATE FUNCTIONS
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; T and Nil quality assurance tests. Make sure that they behave as they should
;; do. Note particularly that imploding and exploding of nil should produce the
;; nil atom/list.
(setq List#2_Predicates
'( ( (eq nil nil) t )
( (eq 10 10) t )
( (eq 11 10) nil )
( (eq nil t) nil )
( (eq 'nil nil) t )
( (eq "hi" "hi") nil )
( (atom nil) t )
( (atom "hi") t )
( (atom Hunk_126) nil )
( (equal ''nil ''()) t )
( (equal '("hi") '("hi")) t )
( (equal '(a . (b . (c . (d)))) '(a b c d)) t )
( (equal Hunk_126 Hunk_126) t )
( (eq Hunk_126 Hunk_126) t )
( (equal Hunk_50 Hunk_126) nil )
( (eq Hunk_50 Hunk_126) nil )
( (atom t) t )
( (equal (explode nil) '(n i l)) t )
( (eq (implode '(n i l)) nil) t )
( (eq (implode '("n" "i" "l")) nil) t )
( (eq nil t) nil )
( (eq 'a 'a) t )
( (eq 2.8 2.8) nil )
( (eq '(a b) '(a b)) nil )
( (equal '(a b) '(a b)) t )
( (equal '((a)((b))) '((a)((b))) ) t )
( (equal '((a)((d))) '((a)((b))) ) nil )
( (eq Data_1 Data_1) t )
( (equal Data_1 Data_1) t )
( (equal (getd 'Data_Array) (getd 'Data_Array2)) t )
( (null nil) t )
( (not nil) t )
( (null 'a) nil )
( (not 'a) nil )
( (not "a") nil )
( (alphalessp 'abc 'abd) t )
( (alphalessp 'abd 'abc) nil )
( (alphalessp 'abc 'abc) nil )
( (alphalessp "abc" "abd") t )
( (alphalessp 'abd "abc") nil )
( (alphalessp "abc" 'abc) nil )
( (arrayp (getd 'Data_Array)) t )
( (arrayp 8) nil )
( (arrayp 8.8) nil )
( (arrayp poport) nil )
( (atom 'a) t )
( (atom 8) t )
( (atom Data_1) nil )
( (atom poport) t )
( (null (boundp 'poport)) nil )
( (boundp (gensym)) nil )
( (floatp 'a) nil )
( (floatp 8.0) t )
( (floatp 8 ) nil )
( (floatp '|800|) nil )
( (floatp Data_1) nil )
( (floatp poport) nil )
( (floatp "hi") nil )
( (floatp Hunk_1) nil )
( (hunkp 'a) nil )
( (hunkp 8) nil )
( (hunkp '|800|) nil )
( (hunkp Data_1) nil )
( (hunkp poport) nil )
( (hunkp "hi") nil )
( (hunkp Hunk_1) t )
( (listp 'a) nil )
( (listp 8) nil )
( (listp '|800|) nil )
( (listp Data_1) t )
( (listp poport) nil )
( (listp "hi") nil )
( (listp Hunk_1) nil )
( (portp 'a) nil )
( (portp 8) nil )
( (portp '|800|) nil )
( (portp Data_1) nil )
( (portp poport) t )
( (portp "hi") nil )
( (portp Hunk_1) nil )
( (stringp 'a) nil )
( (stringp 8) nil )
( (stringp '|800|) nil )
( (stringp Data_1) nil )
( (stringp poport) nil )
( (stringp "hi") t )
( (stringp Hunk_1) nil )
( (and) t )
( (or) t )
( (and t) t )
( (or t) t )
( (and t t) t )
( (and t nil) nil )
( (or t nil) t )
( (or nil nil nil nil t nil nil nil) t )
( (or nil nil nil nil nil nil nil nil) nil )
( (setq x 1) 1 )
( (and (atom '(a)) (setq x 2)) nil )
( (= x 2) nil )
( (or (+ 2 2) (setq x 3)) 4 )
( (= x 3) nil )
( (or nil (+ 3 4) nil) 7 )
( (and (+ 2 2) (+ 2 3) t (+ 2 4)) 6 )
)
)
;; TEST OF SELECTORS AND CREATORS
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Check all functions that have no side effects that select part of a list
;; or atom, or that create a new list or atom for quality.
(setq List#3_Selectors_Creators
'( ( (append) nil )
( (append nil) nil )
( (append nil nil nil) nil )
( (append '(a) nil '(b)) ''(a b) )
( (append '(a b (g)) nil '(h(i)) '(j(k))) ''(a b (g) h (i) j (k)) )
( (nconc ) nil )
( (nconc nil) nil )
( (nconc nil nil nil) nil )
( (nconc '(a) nil '(b)) ''(a b) )
( (nconc '(a b (g)) nil '(h(i)) '(j(k))) ''(a b (g) h (i) j (k)) )
( (ascii 97) ''a )
( (ascii 126) ''|~| )
( (assoc 'a nil) nil )
( (assoc nil nil) nil )
( (assoc 'a '((a . b) (c . d) (e . f))) ''(a . b) )
( (assoc 'x '((a . b) (c . d) (e . f))) nil )
( (assoc '(e) '((a . b) (c . d) ((e) . f))) ''((e) . f) )
( (car nil) nil )
( (cdr nil) nil )
( (cdr '(a)) nil )
( (cdr '(a . b)) ''b )
( (cdr '(a b c)) ''(b c) )
( (car '(a)) ''a )
( (car '(a . b)) ''a )
( (car '((a))) ''(a) )
( (caaar '(( (a) xx ) xx ) ) ''a )
( (cdddr '(a b c d e) ) ''(d e) )
( (cadddr '(a b c d e xx xx )) ''d )
( (cons 'a nil) ''(a) )
( (cons 'a 'nil) ''(a) )
( (cons 'a 'b) ''(a . b))
( (cons 'a '(b c)) ''(a b c))
( (cons '(a) 'b) ''((a) . b) )
( (cons nil nil) ''(nil) )
( (explode nil) ''(n i l) )
( (explode 'a) ''(a) )
( (explode 'abcdefg) ''(a b c d e f g))
( (explode "abcdefg") ''(a b c d e f g))
( (explode 987) ''(|9| |8| |7|) )
( (exploden nil) ''(110 105 108) )
( (exploden 'abc) ''(97 98 99) )
( (exploden "abc") ''(97 98 99) )
( (eq 'a (implode (explode 'a))) t )
( (eq 'abcd (implode (explode 'abcd))) t )
( (eq nil (implode (explode nil))) t )
( (length nil) 0 )
( (length '(a)) 1 )
( (length '((a))) 1 )
( (length '(a b c d)) 4 )
( (ldiff nil nil) nil )
( (ldiff '(a b c) nil) ''(a b c) )
( (ldiff '(a b c) '(a)) ''(b c) )
( (ldiff '(a b c 1 2) '(a b c 1 2)) nil )
( (ldiff '("a" "b" "c") '("a" "b" "c")) ''("a" "b" "c") )
( (list) nil )
( (list 'a) ''(a) )
( (list 'a 'b 'c) ''(a b c) )
( (list 'a '(b) 'c) ''(a(b)c) )
( (list nil nil nil nil nil) ''(nil nil nil nil nil) )
( (member 'a '(x y z a b c)) ''(a b c) )
( (memq 'a '(x y z a b c)) ''(a b c) )
( (member 'k '(x y z a b c)) nil )
( (memq 'k '(x y z a b c)) nil )
( (member '(a b) '(x y z (a b) c)) ''((a b) c) )
( (memq '(a b) '(x y z (a b) c)) nil )
( (listp (setq z '((a b) (c d) e))) t )
( (memq (cadr z) z) ''((c d) e) )
( (nth 0 nil) nil )
( (nth 10 nil) nil )
( (nth -10 nil) nil )
( (nth 0 '((a)b c d)) ''(a) )
( (nth 3 '(a b c d)) ''d )
( (nthchar nil 0) nil )
( (nthchar nil 1) ''n )
( (nthchar nil 3) ''l )
( (nthchar 'abcde 3) ''c )
( (nthchar "abcde" 1) ''a )
( (nthchar 'abcde 5) ''e )
( (nthchar 'abcde 6) nil )
( (nthchar "abcde" -1) nil )
( (pairlis '(a) '(b) nil) ''((a . b)) )
( (pairlis '((a)) '((b)) nil) ''(((a) b)) )
( (pairlis '(a c) '(d f) '(g h)) ''((a . d)(c . f) g h) )
( (quote nil) nil )
( (quote a) ''a )
( (quote (a b c)) ''(a b c) )
( (remove 'a '(a b c)) ''(b c) )
( (remove 'a '(a a b c) 1) ''(a b c) )
( (remove 'a nil 4) nil )
( (remq 1 '(a a 1 c) 1) ''(a a c) )
( (remq 'a '(a a 1 c) 1) ''(a 1 c) )
( (reverse nil) nil )
( (reverse '(a)) ''(a) )
( (reverse '(a b)) ''(b a) )
( (reverse '(a b c d e)) ''(e d c b a) )
( (reverse (reverse '(a b c d e))) ''(a b c d e) )
( (reverse '((a b) nil c d)) ''(d c nil (a b)) )
( (> 50 (sizeof 'symbol)) t )
( (> 50 (sizeof 'flonum)) t )
( (> 50 (sizeof 'port)) t )
( (> 50 (sizeof "fixnum")) t )
( (> 50 (sizeof 'string)) t )
( (> 50 (sizeof "list")) t )
( (> 50 (sizeof "array")) t )
( (subst 'a 'b nil) nil )
( (subst 'a 'b '(a . b)) ''(a . a) )
( (subst 'a 'b '(a b a b)) ''(a a a a) )
( (subst 'a '(1 2) '((1 2) (1 2) ((1 2)))) ''(a a (a)) )
( (listp (setq L '(a b c))) t )
( (dsubst 'a 'b L) ''(a a c) )
( (equal L '(a a c)) t )
( (memusage nil) 0 )
( (memusage 'a) (+ 2 (sizeof 'symbol)) )
( (memusage "a") (+ 2 (sizeof "string")) )
( (fixp (memusage (oblist))) t )
( (type nil) ''list )
( (type t) ''symbol )
( (type 8) ''fixnum )
( (type '|8|) ''symbol )
( (type poport) ''port )
( (type "hi") ''string )
( (type '(a b c)) ''list )
( (type (getd 'Data_Array)) ''array )
( (last nil) nil )
( (last '(a)) ''a )
( (last '(a . b)) ''b )
( (last '(a b c (d e))) ''(d e) )
( (nthcdr 10 nil) nil )
( (nthcdr 0 '(a)) ''(a) )
( (nthcdr 1 '(a . b)) ''b )
( (nthcdr 3 '(a b c (d e))) ''((d e)) )
( (nthcdr 2 '(a b c (d e))) ''(c(d e)) )
( (nthcdr -1.0 '(a b)) ''(nil a b) )
( (character-index 'abcde 'a) 1 )
( (character-index 'abcde 'b) 2 )
( (character-index 'abcde 'e) 5 )
( (character-index 'abcde 'x) nil )
( (character-index "abcde" "cde") 3 )
( (character-index "" "") nil )
( (get_pname 'junk) "junk" )
( (get_pname "junk") "junk" )
( (substring "abcdefghijklm" 0) nil )
( (substring "abcdefghijklm" 1) "abcdefghijklm" )
( (substring "abcdefghijklm" 1 1) "a" )
( (substring "abcdefghijklm" 3 3) "cde" )
( (substring "abcdefghijklm" 13 1) "m" )
( (substring "abcdefghijklm" 13 2) nil )
( (substring "abcdefghijklm" 12 2) "lm" )
( (substring 'abcdefghijklm -1 1) "m" )
( (substring "abcdefghijklm" -2) "lm" )
( (substring 'abcdefghijklm -30) nil )
( (substring "abcdefghijklm" 10 40) nil )
( (concat) nil )
( (concat nil) nil )
( (concat 'a 'b nil) ''abnil )
( (concat "a" "b" nil) ''abnil )
( (concat "a" "bcd" nil "ef" nil) ''abcdnilefnil )
( (concat "a" nil "b" ) ''anilb )
( (concat "a") ''a )
( (concat 'a) ''a )
( (concat 15 "hello" 15) ''15hello15 )
( (not(null(member '15hello15 (oblist)))) t )
( (uconcat) nil )
( (uconcat nil) nil )
( (uconcat 'a 'b nil) ''abnil )
( (uconcat "a" "b" nil) ''abnil )
( (uconcat "a" "bcd" nil "ef" nil) ''abcdnilefnil )
( (uconcat "a" nil "b" ) ''anilb )
( (uconcat "a") ''a )
( (uconcat 'a) ''a )
( (atom (setq z (uconcat 16 "hello" 16))) t )
( (not (member z (oblist))) t )
( (atom (setq z (gensym 'hi))) t )
( (not (member z (oblist))) t )
( (atom (intern z)) t )
( (not(not(member z (oblist)))) t )
( (atom (remob z)) t )
( (not(member z (oblist))) t )
( (atom (remob 'xyz)) t )
( (atom (setq z (maknam '(x y z)))) t )
( (eq z 'xyz) nil )
( (atom (remob 'xyz)) t )
( (atom (intern z)) t )
( (eq z (concat 'x 'y 'z)) t )
( (sort '(e d c b a) nil) ''(a b c d e) )
( (sort '(a b c d e) '(lambda(x y)(not(alphalessp x y)))) ''(e d c b a))
( (sort '(1 2 3 4 5) '<) ''(1 2 3 4 5) )
( (sort '(1 2 3 4 5) '>) ''(5 4 3 2 1) )
( (sortcar '((1 x)(2 y)) '>) ''((2 y)(1 x)) )
)
)
(setq List#4_File_IO_Functions
'( ( (portp (setq pp (fileopen 'junk 'w))) t )
( (print Data_1 pp) 'Data_1 )
( (print Data_1 pp) 'Data_1 )
( (patom Data_1 pp) 'Data_1 )
( (close pp) t )
( (portp (setq pp (fileopen 'junk 'r))) t )
( (read pp) 'Data_1 )
( (read pp) 'Data_1 )
( (read pp) 'Data_1 )
( (read pp 'at-end) ''at-end )
( (read pp) nil )
( (close pp) t )
( (portp (setq pp (fileopen 'junk 'r))) t )
( (readc pp) ''|(| )
( (readc pp) ''|a| )
( (readc pp) ''| | )
( (readc pp) ''|(| )
( (readc pp) ''|b| )
( (car (read pp)) ''c )
( (close pp) t )
( (portp (setq pp (fileopen 'junk 'w))) t )
( (patom '|8| pp) ''|8| )
( (princ '|8| pp) t )
( (close pp) t )
( (portp (setq pp (fileopen 'junk 'r))) t )
( (read pp) 88 )
( (readstr "a") ''a )
( (readstr "(a)") ''(a) )
( (readstr "(a b)") ''(a b) )
( (readstr "'(a b)") '''(a b) )
( (readstr "(a b" "c d)") ''(a b c d) )
( (readstr "(a b" "1 d)") ''(a b 1 d) )
( (readstr "(a b" "1.0 d)") ''(a b 1.0 d) )
( (readstr) nil )
( (readstr "" ) nil )
( (readstr " " " ") nil )
( (readstr "1.2e10") 1.2e10 )
( (readlist) nil )
( (readlist '(a)) ''a )
( (readlist '("(a b c" "d e f)")) ''(a b cd e f) )
( (close pp) t )
( (flatc nil) 3 )
( (flatsize nil) 3 )
( (flatc '|a b|) 3 )
( (flatsize '|a b|) 5 )
( (flatsize Data_2) 73 )
( (flatsize Data_2 10) 13 )
( (flatc Data_2) 71 )
( (flatc Data_2 10) 13 )
( (null (setq Old_pp (getd 'pp))) nil )
( (pp (F junk) pp) t )
( (cdr (boundp '$ldprint)) t )
( (setq $ldprint nil) nil )
( (load 'junk) t )
( (setq $ldprint t) t )
( (equal (getd 'pp) Old_pp) t )
( (sys:unlink 'junk) 0 )
;
; NOTE FILEPOS tests are missing.
;
)
)
;;
(setq List#5_Side_Effects
'(
( (eval '(car '(a b c))) ''a )
( (apply 'car '((a b c))) ''a )
( (funcall 'cons 'a '(b c)) ''(a b c) )
( (mapcar 'atom '(a (b) (c))) ''(t nil nil) )
( (mapc 'atom '(a (b) (c))) ''(a(b)(c)) )
( (maplist 'cons '(a b) '(x y)) ''(((a b) x y)((b)y)) )
( (map 'cons '(a b) '(x y)) ''(a b) )
( (def first (lambda(x)(car x))) ''first )
( (apply 'first '((a b c))) ''a )
( (funcall 'first '(a b c)) ''a )
( (def second(lambda(x)(first(cdr x)))) ''second )
( (def pluss(nlambda(l)(eval(cons '+ l)))) ''pluss )
( (apply 'pluss '(1 2 3)) ''6 )
( (funcall 'pluss 1 2 3) ''6 )
( (def firstm (macro(l)(cons 'car (cdr l)))) ''firstm )
( (def ttest(lexpr(n)(cons(arg 1)(cons n (listify 1))))) ''ttest )
( (def tj(lambda(a &optional b (c 3) &rest d &aux e (f 4))
(list a b c d e f))) ''tj )
( (car (setq a (getd 'first))) ''lambda )
( (car (setq b (getd 'second))) ''lambda )
( (car (setq c (getd 'pluss))) ''nlambda )
( (car (setq d (getd 'firstm))) ''macro )
( (car (setq e (getd 'ttest))) ''lexpr )
( (car (setq f (getd 'tj ))) ''lexpr )
( (defun first(x)(car x)) ''first )
( (defun second(x)(first(cdr x))) ''second )
( (defun pluss fexpr(l)(eval(cons '+ l))) ''pluss )
( (defun firstm macro(l)(cons 'car (cdr l))) ''firstm )
( (defun ttest n (cons (arg 1) (cons n (listify 1)))) ''ttest )
( (defun ttj(a &optional b (c 3) &rest d &aux e (f 4))
(list a b c d e f)) ''ttj )
( (equal (getd 'first) a) t )
( (equal (getd 'second) b) t )
( (equal (getd 'pluss) c) t )
( (equal (getd 'firstm) d) t )
( (equal (getd 'ttest) e) t )
( (equal (getd 'ttj) f) t )
( (ttj 'a) ''(a nil 3 nil nil 4) )
( (ttj 'a 'b) ''(a b 3 nil nil 4) )
( (ttj 'a 'b 'c) ''(a b c nil nil 4) )
( (ttj 'a 'b 'c 'd) ''(a b c (d) nil 4) )
( (first '(a b c)) ''a )
( (second '(a b c)) ''b )
( (pluss (+ 1 1) 3 3) 8 )
( (setq displace-macros nil) nil )
( (listp (setq x '(firstm '(a b c)))) t )
( (eval x) ''a )
( (equal x '(firstm '(a b c))) t )
( (macroexpand '(firstm '(a b c))) ''(car '(a b c)) )
( (setq displace-macros t) t )
( (eval x) ''a )
( (equal x '(car '(a b c))) t )
( (ttest 'a 'b 'c) ''(a 3 a b c) )
( (ttest 1 2 3 4 5) ''(1 5 1 2 3 4 5) )
( (fixp (setq free%cons (car (memstat)))) t )
( (fixp (setq oldcount $gccount$)) t )
( (gc) t )
( (= (+ oldcount 1) $gccount$) t )
( (< (car (memstat)) free%cons) t )
( (listp (setq oldlist (oblist))) t )
( (atom (setq temp (intern(gensym)))) t )
( (AtomInList? temp oldlist) nil )
( (AtomInList? temp (oblist)) t )
( (car (explode (gensym))) ''g )
( (car (explode (gensym "X"))) ''X )
( (car (explode (gensym 'Y))) ''Y )
)
)
(setq List#6_Destructives
'( ( (listp (setq L '(x y 1))) t )
( (attach 'a L) ''(a x y 1) )
( (attach nil L) ''(nil a x y 1) )
( (equal L '(nil a x y 1)) t )
( (delq 1 L) ''(nil a x y) )
( (equal L '(nil a x y)) t )
( (listp (setq L '("a" "a" "b" "a" "c" "a" "d"))) t )
( (delete "a" L 2) ''("b" "a" "c" "a" "d") )
( (listp (setq L '("a" "a" "b" "a" "c" "a" "d"))) t )
( (delq "a" L 2) ''("a" "a" "b" "a" "c" "a" "d") )
( (listp (setq L '(x a b c))) t )
( (delete 'a L) ''(x b c) )
( (delete 'b L) ''(x c) )
( (delete 'c L) ''(x) )
( (delete 'x L) nil )
( (hunksize (hunk 'a)) 1 )
( (hunksize (hunk "a" "b" "c" "d" "e")) 5 )
( (hunksize (makhunk 120)) 120 )
( (hunksize (makhunk '(1 2 3 4 5))) 5 )
( (hunkp (setq H (hunk 1 2 3 4 5 6 7 8 9 10))) t )
( (hunkp (setq I (hunk 1))) t )
( (hunk-to-list H) ''(1 2 3 4 5 6 7 8 9 10) )
( (hunk-to-list I) ''(1) )
( (cxr 0 I) 1 )
( (cxr 0 H) 1 )
( (cxr 9 H) 10 )
( (hunkp (rplacx 9 H "end")) t )
( (hunkp (rplacx 0 H "start")) t )
( (equal H (hunk "start" 2 3 4 5 6 7 8 9 "end")) t )
( (listp (setq X (copy '(a b c d)) Y X)) t )
( (eq X Y) t )
( (rplaca X 1) ''(1 b c d) )
( (eq X Y) t )
( (setq Z (copy X)) 'X )
( (rplacd X '(2 3)) ''(1 2 3) )
( (eq X Y) t )
( (eq X Z) nil )
)
)
(setq List#7_ControlFlow
'( ( (setq a 'A b 'B c 'C d 'D) ''D )
( (catch (throw 'x)) ''x )
( (catch (car (cdr (car (car (throw 'x)))))) ''x )
( (catch (car (throw 'x 'tag))) ''x )
( (catch (car (throw 'x 'tag)) 'tag) ''x )
( (catch (car (throw 'x 'tag)) '(tag1 tag2 tag3 tag)) ''x )
( (catch ((lambda(a b)(throw 'x)) nil nil)) ''x )
( (list a b) ''(A B) )
( (catch (prog (a b) c (throw 'x) d)) ''x )
( (list a b) ''(A B) )
( (catch ((nlambda(a)(throw 'x)) nil)) ''x )
( (list a b) ''(A B) )
( (catch ((macro(a)(throw 'x)) nil)) ''x )
( (list a b) ''(A B) )
( (catch ((lexpr(a)(throw 'x)) 1 2)) ''x )
( (list a b) ''(A B) )
( (errset (err 'x) nil) ''x )
( (sstatus chainatom t) t )
( (errset (car (cdr (car 8))) nil) ''(nil) )
( (sstatus chainatom nil) t )
( (errset (car (cdr (car 8))) nil) nil )
( (errset (car '(a b c))) ''(a) )
)
)
(setq List#8_Sets
'( ( (null (set-create '(nil nil nil))) t )
( (null (set-create nil)) t )
( (hunkp (setq s1 (set-create '(a (a) a ((a)))))) t )
( (hunkp (setq s2 (set-create '(a (a))))) t )
( (set-list s1) ''((a) a ((a))) )
( (set-list s2) ''((a) a) )
( (set-list (set-and s1)) ''((a) a ((a))) )
( (set-list (set-or s1)) ''((a) a ((a))) )
( (set-list (set-diff s1)) ''((a) a ((a))) )
( (set-list (set-and s1 s1)) ''((a) a ((a))) )
( (set-list (set-or s1 s1)) ''((a) a ((a))) )
( (set-list (set-diff s1 s1)) nil )
( (set-list (set-and s1 '(a))) ''(a) )
( (set-list (set-and s1 s2)) ''((a) a) )
( (set-list (set-or s1 '(b))) ''((a) b a ((a))) )
( (set-list (set-or s1 s2)) ''((a) a ((a))) )
( (set-list (set-diff s1 s2)) ''(((a))) )
( (set-list (set-or '(a) '(b) '(c) nil)) ''(c b a) )
( (set-list (set-or '(a b) '(b a) '(c b a))) ''(c b a) )
( (set-list (set-and '(a) '(b) '(c))) nil )
( (set-list (set-and '(a) '(a) '(a))) ''(a) )
( (set-list (set-and '(a b) '(b a) '(c b a))) ''(b a) )
( (set-list (set-and '(a b) nil '(c b a))) nil )
( (set-list (set-diff '(a b) '(b a) '(c b a))) nil )
( (set-list (set-diff '(a b) '(b))) ''(a) )
( (set-list (set-diff nil '(b))) nil )
( (set-member (set-create (oblist)) 'set-create) t )
)
)
;; Some data lists that are used by some of the test routines.
;; Do not change them as their contents are important to test results.
(setq Data_1 '(a(b(c(d(e(f(g)))(h)(((((i)(((j)((k))(l]
(setq Data_2 '(a(b(c(d(e(f('|g xx|)))(h . hi)(((((22)(((j)((k))(l]
(array Data_Array t 5 20)
(array Data_Array2 t 5 20)
(setq Hunk_126 (makhunk 126))
(setq Hunk_50 (makhunk 50))
(setq Hunk_1 (makhunk 1))
;; Function AtomInList?(a l)
;; ~~~~~~~~~~~~~~~~~~~~~~~~~
;; Look through list l for atom a. If found return true else return nil.
(defun AtomInList?(a l)
(prog ()
LOOP: (and (null l) (return nil))
(and (eq (car l) a) (return t))
(setq l (cdr l))
(go LOOP:)
)
)
;; Function Nearly Equal(a b)
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Returns t if a and b are both numbers that are pretty close to each
;; other. The tolerance is .00001 just to give an idea that things are ok.
(defun NearlyEqual(a b)
(cond ((or (not (numbp a)) (not (numbp b))) nil)
((greaterp 0.00001 (abs (difference a b))) t)
(t nil)
)
)
;; Function run(tracing)
;; ~~~~~~~~~~~~~~~~~~~~~~
;; Initiate one q&a test - trace if 'tracing' is non nil. This test can
;; only be run once because of the expected side effects.
;;
(defun run(tracing)
(prog (where)
(setq where poport)
(Q&A List#1_Math_Functions where tracing)
(Q&A List#2_Predicates where tracing)
(Q&A List#3_Selectors_Creators where tracing)
(Q&A List#4_File_IO_Functions where tracing)
(Q&A List#5_Side_Effects where tracing)
(Q&A List#6_Destructives where tracing)
(Q&A List#7_ControlFlow where tracing)
(Q&A List#8_Sets where tracing)
(return t)
)
)

98
Ashwood-Smith PC-LISP v3/QUEENS.L Normal file
View File

@ -0,0 +1,98 @@
;
; 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)
;
; I do not know who the original Author of this is but it was found with some
; XLISP example lisp programs. This has been slightly modified to run on
; PC-LISP V2.13.
;
; Peter Ashwood-Smith
; August 22nd, 1986
; Do two queens threaten each other ?
(defun threat (i j a b)
(or (= i a) ;Same row
(= j b) ;Same column
(= (- i j) (- a b)) ;One diag.
(= (+ 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 ())
(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
(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)
(prog (size)
(setq size (length board)) ;we can find our own size
(princ "\f\n\t\tSolution: ")
(princ soln)
(princ "\n\n\t")
(print-header size 1)
(princ "\n")
(print-board-aux board size 1)
(princ "\n")
)
)
; Put Column #'s on top
(defun print-header (size n)
(cond ((> n size) (princ "\n"))
(t (prog () (patom n)
(princ " ")
(print-header size (1+ n))))))
(defun print-board-aux (board size row)
(princ "\n")
(cond ((null board) ())
(t (prog ()
(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 (prog ()
(cond ((equal column n) (princ "Q"))
(t (princ ".")))
(princ " ")
(print-board-row column size (1+ n))))))

44
Ashwood-Smith PC-LISP v3/README Normal file
View File

@ -0,0 +1,44 @@
PC-LISP V3.00 (C) February 1st 1990 Peter Ashwood-Smith
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is a PC-LISP source or executable distribution disk. To
unpack the disk use the 'arc' utility provided on the disk. You can
get arc instructions by typing 'arc'. To get a list of files in the
archive 'src.arc' or 'exe.arc' type 'arc l src.arc' or 'arc l exe.arc'
To extract all the files in the archive onto your hard disk. Copy
the disk contents to a directory on your hard disk then type.
"arc x exe.arc *.*" or "arc x src.arc *.*"
After which you can erase the exe.arc or src.arc file as well as
the arc.exe program. You now have a directory that contains either the
entire pc-lisp executable distribution or the pc-lisp source distribution.
You will probably then want to copy the files *.L to a direcory
of lisp programs, say \liblisp. Then add to your autoexec.bat file the
statement: "set LISP_LIB=\liblisp"
Have fun and regards,
Peter Ashwood-Smith
N.B.
There are a number of undocumented functions in 3.00. In
particular if you look in Q&A.L you will see the code that self tests
them. A short description of the undocumented non Franz functions
follows:
(toupper str) -> string str zapped to upper case chars.
(tolower str) -> string str zapped to lower case chars.
(readln [port] [eof]) -> next line read from [port]/piport as a string
or nil/eof on end of file.
(strlen str) -> length of the string or atom str as a fixnum.
(strcomp str) -> string str without ANY blanks in it at all ie compressed.
(strtrim str) -> string str without any trailing blanks.
(strpad str n) -> string str padded/truncated to 'n' chars long.
In addition the Franz 'autoload property is now allowed and it is
possible to put the property 'autoload on an atom with a property value
which is a string naming the file where the function can be found. See
LISPcraft for more details.

205
Ashwood-Smith PC-LISP v3/TTT.LSP Normal file
View File

@ -0,0 +1,205 @@
; Prove you can't win at tic-tac-toe if the opponent is competent.
; Tested with PC-LISP V3.00. Likely won't work with more modern LISP implementations.
; This takes roughly 20 minutes to run on a 4.77Mhz 8086.
; This runs in about 2.2 seconds in the NTVDM emulator on an Intel i9-14900KF.
; I am not proficient in LISP; there are likely easy ways to improve performance.
; More recent versions of LISP have helpful functions including:
; /= not equal
; bitwise operators like logand
; byte datatype instead of 4-byte integers
; But Common LISP doesn't seem to have hunks.
(setq score-win 6)
(setq score-tie 5)
(setq score-lose 4)
(setq score-max 9)
(setq score-min 2)
(setq piece-blank 0)
(setq piece-x 1)
(setq piece-o 2)
(setq moves 0)
(setq board (hunk 0 0 0 0 0 0 0 0 0))
(setq winpiece piece-blank)
(defun iswin (x y z)
(setq winpiece (cxr x board))
(cond ((and (not (= winpiece piece-blank)) (= winpiece (cxr y board)) (= winpiece (cxr z board)))))
)
(defun winner()
(cond ((or (iswin 0 1 2)
(iswin 0 3 6)
(iswin 1 4 7)
(iswin 2 5 8)
(iswin 3 4 5)
(iswin 4 0 8)
(iswin 4 2 6)
(iswin 6 7 8))
winpiece)
(t piece-blank)
)
)
(defun proc0(x)
(cond ((or (and (= x (cxr 1 board)) (= x (cxr 2 board)))
(and (= x (cxr 3 board)) (= x (cxr 6 board)))
(and (= x (cxr 4 board)) (= x (cxr 8 board))))
x) (t piece-blank))
)
(defun proc1(x)
(cond ((or (and (= x (cxr 0 board)) (= x (cxr 2 board)))
(and (= x (cxr 4 board)) (= x (cxr 7 board))))
x) (t piece-blank))
)
(defun proc2(x)
(cond ((or (and (= x (cxr 0 board)) (= x (cxr 1 board)))
(and (= x (cxr 5 board)) (= x (cxr 8 board)))
(and (= x (cxr 4 board)) (= x (cxr 6 board))))
x) (t piece-blank))
)
(defun proc3(x)
(cond ((or (and (= x (cxr 4 board)) (= x (cxr 5 board)))
(and (= x (cxr 0 board)) (= x (cxr 6 board))))
x) (t piece-blank))
)
(defun proc4(x)
(cond ((or (and (= x (cxr 0 board)) (= x (cxr 8 board)))
(and (= x (cxr 2 board)) (= x (cxr 6 board)))
(and (= x (cxr 1 board)) (= x (cxr 7 board)))
(and (= x (cxr 3 board)) (= x (cxr 5 board))))
x) (t piece-blank))
)
(defun proc5(x)
(cond ((or (and (= x (cxr 3 board)) (= x (cxr 4 board)))
(and (= x (cxr 2 board)) (= x (cxr 8 board))))
x) (t piece-blank))
)
(defun proc6(x)
(cond ((or (and (= x (cxr 7 board)) (= x (cxr 8 board)))
(and (= x (cxr 0 board)) (= x (cxr 3 board)))
(and (= x (cxr 2 board)) (= x (cxr 4 board))))
x) (t piece-blank))
)
(defun proc7(x)
(cond ((or (and (= x (cxr 6 board)) (= x (cxr 8 board)))
(and (= x (cxr 1 board)) (= x (cxr 4 board))))
x) (t piece-blank))
)
(defun proc8(x)
(cond ((or (and (= x (cxr 6 board)) (= x (cxr 7 board)))
(and (= x (cxr 2 board)) (= x (cxr 5 board)))
(and (= x (cxr 0 board)) (= x (cxr 4 board))))
x) (t piece-blank))
)
(defun mmMax (alpha beta depth move) (prog (i value nextDepth) ; this is how local variables are declared
(setq moves (+ 1 moves))
;(princ "max: ") (princ board) (princ " ") (princ alpha) (princ " ") (princ beta) (princ " ") (princ move) (princ " ") (princ depth) (princ "\n")
(cond ((> depth 3)
;(setq win (winner)) ; almost 2x slower than using procs
;(setq win (funcall (concat 'proc move) piece-o)) ; slower than using the procs hunk
(setq win (funcall (cxr move procs) piece-o))
(cond ((= win piece-o) (return score-lose))))
)
(setq value score-min)
(setq nextDepth (+ 1 depth))
(setq i 0)
_nexti_
(cond ((= (cxr i board) piece-blank)
(rplacx i board piece-x)
(setq score (mmMin alpha beta nextDepth i))
(rplacx i board piece-blank)
(cond ((= score score-win)
(return score-win))
((> score value)
(setq value score)
(cond ((>= value beta)
(return value))
((> value alpha)
(setq alpha value))))
))
)
(cond ((< i 8)
(setq i (+ i 1))
(go _nexti_))
)
(return value)
))
(defun mmMin (alpha beta depth move) (prog (i value nextDepth) ; this is how local variables are declared
(setq moves (+ 1 moves))
;(princ "min: ") (princ board) (princ " ") (princ alpha) (princ " ") (princ beta) (princ " ") (princ move) (princ " ") (princ depth) (princ "\n")
(cond ((> depth 3)
;(setq win (winner)) ; almost 2x slower than using procs
;(setq win (funcall (concat 'proc move) piece-x)) ; slower than using the procs hunk
(setq win (funcall (cxr move procs) piece-x))
(cond ((= win piece-x) (return score-win))
((= depth 8) (return score-tie))
))
)
(setq value score-max)
(setq nextDepth (+ 1 depth))
(setq i 0)
_nexti_
(cond ((= (cxr i board) piece-blank)
(rplacx i board piece-o)
(setq score (mmMax alpha beta nextDepth i))
(rplacx i board piece-blank)
(cond ((= score score-lose)
(return score-lose))
((< score value)
(setq value score)
(cond ((<= value alpha)
(return value))
((< value beta)
(setq beta value))))
))
)
(cond ((< i 8)
(setq i (+ i 1))
(go _nexti_))
)
(return value)
))
(defun runmm (position)
(rplacx position board piece-x)
(mmMin score-min score-max 0 position)
(rplacx position board piece-blank)
)
(setq procs (hunk proc0 proc1 proc2 proc3 proc4 proc5 proc6 proc7 proc8))
; solve for each of the 3 unique (after reflections) opening moves
(setq startTime (sys:time))
(runmm 0)
(runmm 1)
(runmm 4)
(setq endTime (sys:time))
(princ "moves: ") (princ moves) (princ "\n") ; should be 6493
(princ "elapsed seconds: ") (princ (- endTime startTime)) (princ "\n")
;(princ "memstat: ") (princ (memstat)) (princ "\n")
;(gc)
;(princ "memstat post gc: ") (princ (memstat)) (princ "\n")
(exit)

122
Ashwood-Smith PC-LISP v3/TURTLE.L Normal file
View File

@ -0,0 +1,122 @@
;; TURTLE.L for PC-LISP.EXE V2.13
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; A set of rough turtle graphics primitives to demonstrate PC-LISP's BIOS
;; graphics routines. These routines are pretty self explanitory. The first
;; 5 defun's define the primitives, next are a set of routines to draw things
;; like squares, triangles etc. Try the function (GraphicsDemo). It will
;; draw Squirals, Trianglerals, etc. Note that the BIOS line drawing is really
;; slow. This is because the BIOS 'set dot/pixel' routine is used for every
;; point in a line. Using the BIOS has the advantage however of portability,
;; these routines work on virtually every MS-DOS machine. The global variable
;; !Mode controls the graphics resolution that will be used. It is set by
;; default to 6, I set it to 8 or 9 for my Tandy 2000. You can adjust the code
;; to support your machines higher resolution modes. More 640x400 modes can be
;; supported by (= !Mode NN) at ### PATCH POINT 1 ### where NN is the value
;; to pass to (#srcmde#) Ie the value to pass in AH when INT 10H is generated
;; with AL=0 (the BIOS Set CRT Mode call). If your machines has high resolution
;; modes besides the 640x400 say X * Y resolution associated with mode NN then
;; add the following code at ### PATCH POINT 2 ### (where AA is X/2, BB is Y/2
;; CC is the ratio X/Y and DD is the number of pixels that should correspond
;; to one Turtle movement Unit):
;;
;; ((= !Mode NN)
;; (setq CenterX AA CenterY BB Scale CC Lfactor DD)
;; (TurtleCenter))
;;
;; Peter Ashwood-Smith
;; August 22nd, 1986
;;
(setq !Mode 6) ; default setting
(defun TurtleGraphicsUp()
(#scrmde# !Mode)(#scrsap# 0)
(cond ((= !Mode 6) ; 640x200 B&W mode
(setq CenterX 100 CenterY 100 Scale 3.2 Lfactor 1)
(TurtleCenter))
;
((= !Mode 7)
(patom '|mode 7 not allowed|))
;
((or (= !Mode 8) (= !Mode 9) ; Tandy 2000 640x400
(= !Mode 64) ; AT&T 6300 640x400?
; ### PATCH POINT 1 ###
)
(setq CenterX 266 CenterY 200 Scale 1.2 Lfactor 2)
(TurtleCenter))
;
; ### PATCH POINT 2
;
(t (patom '|unsupported mode|))
)
)
(defun TurtleGraphicsDown()
(#scrmde# 2))
(defun TurtleCenter()
(setq Lastx CenterX Lasty CenterY Heading 1.570796372))
(defun TurtleRight(n)
(setq Heading (plus Heading (times n 0.01745329))))
(defun TurtleLeft(n)
(setq Heading (diff Heading (times n 0.01745329))))
(defun TurtleGoTo(x y)
(setq Lastx (quotient x Scale) Lasty (times y Lfactor) ))
(defun TurtleForward(n)
(setq n (times n Lfactor)
Newx (plus Lastx(times(cos Heading)n))
Newy (plus Lasty(times(sin Heading)n)))
(#scrline# (times Lastx Scale) Lasty (times Newx Scale) Newy 1)
(setq Lastx Newx Lasty Newy)
)
;
; end of Turtle Graphics primitives, start of Graphics demonstration code
; you can cut this out if you like and leave the Turtle primitives intact.
;
(defun Line_T(n)
(TurtleForward n) (TurtleRight 180)
(TurtleForward (quotient n 4))
)
(defun Square(n)
(TurtleForward n) (TurtleRight 90)
(TurtleForward n) (TurtleRight 90)
(TurtleForward n) (TurtleRight 90)
(TurtleForward n)
)
(defun Triangle(n)
(TurtleForward n) (TurtleRight 120)
(TurtleForward n) (TurtleRight 120)
(TurtleForward n)
)
(defun Make(ObjectFunc Size times skew)
(prog()
TOP:(cond ((zerop times) (return)))
(ObjectFunc Size)
(TurtleRight skew)
(setq times (1- times))
(go TOP:)
)
)
(defun GraphicsDemo()
(TurtleGraphicsUp)
(Make Square 40 18 5) (Make Square 60 18 5)
(gc) ; idle work
(TurtleGraphicsUp)
(Make Triangle 40 18 5) (Make Triangle 60 18 5)
(gc) ; idle work
(TurtleGraphicsUp)
(Make Line_T 80 50 10)
(gc) ; idle work
(TurtleGraphicsDown)
)

2
Ashwood-Smith PC-LISP v3/m.bat Normal file
View File

@ -0,0 +1,2 @@
ntvdm -r:. -p PC-LISP.exe %1.lsp

2
Ashwood-Smith PC-LISP v3/m.sh Normal file
View File

@ -0,0 +1,2 @@
ntvdm -r:. -u -p PC-LISP.EXE $1.lsp