Subversion Repositories programming

;Written By: Ira Snyder (parts from Dr. Soroka)
;Due Date:   02-28-2005
;Homework #: HW11
;License: Unknown, except for the code indicated as being
;         written by Ira Snyder, which is in the Public Domain

; POLY.LSP
;
; add code for (* i2 i3) &c
;
; on T 050118 at 1730
; It reads & prints polynomials.
;
; on T 050118 at 0830
; All new.
; Brought over the ARITH code & began altering it to handle polynomials.
;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ASSUMPTIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                          ;;;
;;; Since it was not specified, I decided to make POLY- work in same way     ;;;
;;; as the lisp function -. (POLY- P1 P2) would be written in infix as       ;;;
;;; P1 - P2.                                                                 ;;;
;;;                                                                          ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;
; Loop -- read:
; a polynomial 
; or a reference
; or an expression involving references.
;
(defun POLY nil
  (setf $HISTORY nil)
  (let ((I 0)
        (POLY))
    (loop
      (format t "~%(i~s) " I)
      (setf INPUT (read))
      (cond
        ((member INPUT '(exit halt quit stop)) (return nil))
        ((eq INPUT 'history) (SHOW-HISTORY)) 
        ((and (REFERENCEP INPUT) (not (VALID-REFERENCE-P INPUT)))
                 (format t "Reference out of range: ~s" INPUT)
                 )
        ((REFERENCEP INPUT)    ; this reference is valid
          (let ((OUTPUT (GET-REFERENCE INPUT)))
            (format t "(o~s) " I)
            (format t "~s~%" OUTPUT)
            (setf $HISTORY (append $HISTORY (list OUTPUT)))
            (setf I (1+ I))
            )
          )
        ((atom INPUT) (format t "Illegal expression: ~s" INPUT))
        ((VALID-OP-REF-REF INPUT) 
          (let ((OUTPUT (EXECUTE-EXPRESSION INPUT)))
            (format t "(o~s)~%" I)
            (WRITE-POLY OUTPUT)
            (setf $HISTORY (append $HISTORY (list OUTPUT)))
            (setf I (1+ I))
            ) ;end let
          )
        ((not (VALID-IN-EXP INPUT)))
        (t (let ((INTERMS (IE2INTERMS INPUT)))
             (setf POLY (mapcar #'(lambda (INTERM) (VALID-INTERM nil INTERM))
                                INTERMS))
             )
           (format t "(o~s)~%" I) 
           (WRITE-POLY POLY)
           (setf $HISTORY (append $HISTORY (list POLY)))
           (setf I (1+ I))
           )
        ) ;end cond
    ) ;end loop
  ) ;end let
) ;end defun

; VALID-OP-REF-REF recognizes forms like (* i2 i3)
; where the references are valid.
; Appropriate error messages are printed if needed.
(defun VALID-OP-REF-REF (EXP)
  (cond
    ((not (= 3 (length EXP))) nil)
    ((not (member (car EXP) '(+ - *))) nil)
    ((not (VALID-REFERENCE-P (cadr EXP)))
      (format t "Reference out of range: ~s" (cadr EXP))
      nil)
    ((not (VALID-REFERENCE-P (caddr EXP)))
      (format t "Reference out of range: ~s" (caddr EXP))
      nil)
    (t t)
  )
)

;
; (VALID-REFERENCE-P S) returns T iff S is of the form i8 or o8 and the number
;                       specifies a valid $HISTORY entry.
;
(defun VALID-REFERENCE-P (S)
  (and (REFERENCEP S)
       (let ((N (parse-integer (subseq (symbol-name S) 1))))
         (and (>= N 0) (< N (length $HISTORY)))
       )
  )
)

;
; (REFERENCEP S) returns T iff S is of the form i5 or o16 etc.
;
(defun REFERENCEP (S)
  (and (symbolp S)
       (or (char= #\I (char (symbol-name S) 0))
           (char= #\O (char (symbol-name S) 0)))
       (> (length (symbol-name S)) 1)
       (DIGIT-STRING-P (subseq (symbol-name S) 1))
  )
)

;
; (VALID-IN-EXP EXP)
;
; A valid IN-EXP is an append of valid INTERMs.
; E.g. (+ 3 - x ^ 2) is an append of (+ 3) and (- x ^ 2).
;
(defun VALID-IN-EXP (EXP)
  (cond
    ((atom EXP) (format t "Sorry, but ~s is not legal here.~%" EXP)
                nil)
    (t (let ((INTERMS (IE2INTERMS EXP)))
         (every #'(lambda (INTERM) (VALID-INTERM t INTERM))
                INTERMS)
       ))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SEE BELOW FOR IMPLEMENTATION OF WRITE-POLY                               ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;
; (IE2INTERMS EXP) returns a list of the INTERMS in EXP.
; For example, (3 - x ^ 2 + 7 x) --> ((3) (-  x ^ 2) (+ 7 x)).
; Note:  Some may not be legal!
;
(defun IE2INTERMS (EXP)
  (let ((RESULT nil)
        (REST EXP))
    (loop
      (if (null REST) (return (reverse RESULT)))
      (setf RESULT (cons (TAKE-INTERM REST) RESULT))
      (setf REST (DROP-INTERM REST))
    ) ;end-loop
  ) ;end-let
)

;
; (TAKE-INTERM IN-EXP) returns the first INTERM of IN-EXP
;
(defun TAKE-INTERM (EXP)
  (let ((INTERM (list (car EXP)))
        (REST (cdr EXP)))
    (loop
      (if (null REST) (return (reverse INTERM)))
      (if (member (car REST) '(+ -)) (return (reverse INTERM)))
      (setf INTERM (cons (car REST) INTERM))
      (setf REST (cdr REST))
    ) ;end loop
  ) ;end let
)

;
; (DROP-INTERM IN-EXP) returns ALL BUT the first INTERM of IN-EXP
;
(defun DROP-INTERM (EXP)
  (let ((INTERM (list (car EXP)))
        (REST (cdr EXP)))
    (loop
      (if (null REST) (return REST))
      (if (member (car REST) '(+ -)) (return REST))
      (setf INTERM (cons (car REST) INTERM))
      (setf REST (cdr REST))
    ) ;end loop
  ) ;end let
)

;
; (VALID-INTERM PFLAG EXP)
;
; Convert things like (- 2 x ^ 7) into (-2 7) if possible.
; If not possible, then return nil.
; If PFLAG is T, then error messages are printed.
;
(defun VALID-INTERM (PFLAG EXP) (VALID-INTERM0 PFLAG EXP EXP))

;
; Grab off the sign, if any.
;
(defun VALID-INTERM0 (PFLAG INTERM L)
  (cond
    ((atom L) (format PFLAG "Invalid INTERM: ~s" INTERM)
              nil)
    ((eq '- (car L)) (VALID-INTERM1 PFLAG INTERM -1 (cdr L)))
    ((eq '+ (car L)) (VALID-INTERM1 PFLAG INTERM 1 (cdr L)))
    (t               (VALID-INTERM1 PFLAG INTERM 1 L))
  )
)

;
; Grab off the coefficient, if any.
;
(defun VALID-INTERM1 (PFLAG INTERM SIGN L)
  (cond
    ((null L) (format PFLAG "Invalid INTERM: ~s" INTERM)
              nil)
    ((eq 'x (car L)) (VALID-INTERM2 PFLAG INTERM SIGN 1 L))
    ((numberp (car L)) (VALID-INTERM2 PFLAG INTERM SIGN (car L) (cdr L)))
    (t (format PFLAG "Invalid INTERM -- numeric coefficient expected: ")
       (format PFLAG "~s" INTERM)
       nil)
  )
)

;
; Handle constant terms here.
;
(defun VALID-INTERM2 (PFLAG INTERM SIGN COEF L)
  (cond
    ((null L) (list (* SIGN COEF) 0))
    ((eq 'x (car L)) (VALID-INTERM3 PFLAG INTERM SIGN COEF (cdr L)))
    (t (format PFLAG "Invalid INTERM -- X was expected: ")
       (format PFLAG "~s" INTERM)
       nil)
  )
)

;
; No exponent exits here:
;
(defun VALID-INTERM3 (PFLAG INTERM SIGN COEF L)
  (cond
    ((null L) (list (* SIGN COEF) 1))
    ((eq '^ (car L)) (VALID-INTERM4 PFLAG INTERM SIGN COEF (cdr L)))
    (t (format PFLAG "Invalid INTERM -- ^ was expected: ")
       (format PFLAG "~s" INTERM))
  )
)

;
; Grab the exponent.
;
(defun VALID-INTERM4 (PFLAG INTERM SIGN COEF L)
  (cond
    ((null L) (format PFLAG "Invalid INTERM -- exponent missing: ")
              (format PFLAG "~s" INTERM))
    ((cdr L) (format PFLAG "Invalid INTERM -- extra stuff at end: ")
             (format PFLAG "~s" INTERM))
    ((not (numberp (car L))) 
      (format PFLAG "Invalid INTERM -- exponent must be numeric: ")
      (format PFLAG "~s" INTERM))
    (t (list (* SIGN COEF) (car L)))
  )
)

;
; (EXECUTE-EXPRESSION EXP) processes things like (* I5 i6).
;
(defun EXECUTE-EXPRESSION (EXP)
  (let ((OP (car EXP))
        (ARG1 (GET-REFERENCE (cadr EXP)))
        (ARG2 (GET-REFERENCE (caddr EXP))))
    (cond
      ((eq OP '*) (POLY* ARG1 ARG2))
      ((eq OP '+) (POLY+ ARG1 ARG2))
      ((eq OP '-) (POLY- ARG1 ARG2))
      (t (format t "EXECUTE-EXPRESSION: Illegal operator: ~s" OP))
    ) ;end-cond
  ) ;end-let
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The below 4 functions (POLY*, POLY+, and POLY-) were implemented         ;;;
;;; on 02-20-2005 by Ira Snyder for HW11                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This function takes two polynomials represented in PNF,
;;; and returns the result of multiplying them together.
;;; The two do loops take each sublist of P1 and P2, and call
;;; POLY*1 on the two lists.
(defun POLY* (P1 P2)
  (do ((P1 P1 (cdr P1)) 
       (RESULT nil))
      ((null P1) RESULT)
    (do ((P2 P2 (cdr P2)))
        ((null P2) RESULT)
      (setf RESULT (cons (POLY*1 (car P2) (car P1)) RESULT))
    )
  )
)

;;; This function takes two pairs of numbers, each representing
;;; a coefficient and power of a variable. It returns the multiplication
;;; of these two pairs, as a new pair.
(defun POLY*1 (PAIR1 PAIR2)
  (list (* (car PAIR1) (car PAIR2)) (+ (cadr PAIR1) (cadr PAIR2)))
)

;;; This function takes two lists, each in PNF, and returns a new
;;; list which is the addition of P1 and P2.
(defun POLY+ (P1 P2)
  (do ((P1 P1 (cdr P1))
       (RESULT P2))
      ((null P1) RESULT)
    (setf RESULT (INSERT (car P1) RESULT))
  )
)

;;; This function takes two lists, each in PNF, and returns a new
;;; list which is the subtraction of P2 from P1.
(defun POLY- (P1 P2)
  (do ((P2 P2 (cdr P2))
       (RESULT P1))
      ((null P2) RESULT)
    (setf RESULT (INSERT (list (* -1 (caar P2)) (cadar P2)) RESULT))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of things implemented by Ira Snyder for HW11                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;
; (GET-REFERENCE REF) looks up things like I8 in $HISTORY.
;                     Assume that REF is legal.
;
(defun GET-REFERENCE (REF)
  (let ((N (parse-integer (subseq (symbol-name REF) 1))))
    (nth N $HISTORY)
  )
)

;
; (DIGIT-STRING-P string) returns T iff all chars in STRING are digits.
;
(defun DIGIT-STRING-P (STR)
  (let ((I 0))
    (loop 
      (if (>= I (length STR)) (return t))
      (if (not (digit-char-p (char STR I))) (return nil))
      (setf I (1+ I))
    ) ;end loop
  ) ;end let
)

(defun SHOW-HISTORY nil
  (let ((I 0))
    (mapc #'(lambda (ITEM) (format t ">(i~s) ~s~%" I ITEM)
                           (setf I (1+ I)))
          $HISTORY)
  )
) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Below is code added by Ira Snyder on 02-20-2005                          ;;;
;;; This code implements WRITE-POLY, PNF and all supporting                  ;;;
;;; functionsfrom HW08                                                       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Given a list in unsorted, unreduced Polynomial
;;; Normal Form, and returns a list in perfect PNF
(defun PNF (L)
  (do ((L L (cdr L))
       (RET nil))
      ((null L) RET)
    (setf RET (INSERT (car L) RET))
    (setf RET (DEL-ZERO-COEF RET))
  )
)

;;; Given a pair of numbers (in a list) and a list of pairs
;;; this inserts the pair into the list in it's correct place
;;; including combining coefficients
(defun INSERT (PAIR LIST)
  (let ((FPTR (caar LIST))) ;this is needed so we don't change 
                            ;the list outside this function
    (cond
      ((null LIST)                  (cons PAIR LIST))
      ((> (cadr PAIR) (cadar LIST)) (cons PAIR LIST))
      ((= (cadr PAIR) (cadar LIST)) (progn
                                      (setf FPTR (+ (car PAIR) FPTR))
                                      (cons (list FPTR (cadar LIST))
                                            (cdr LIST))))
      (t                            (cons (car LIST) (INSERT PAIR (cdr LIST))))
    )
  )
)

;;; Deletes all of the pairs that have zero coefficients in
;;; a PNF list
(defun DEL-ZERO-COEF (L)
  (cond
    ((null L) nil)
    ((= 0 (caar L)) (DEL-ZERO-COEF (cdr L)))
    (t              (cons (car L) (DEL-ZERO-COEF (cdr L))))
  )
)

;;; This takes a non-negative integer, and returns a string
;;; containing the number of spaces specified by the integer
(defun SPACES (N)
  (do ((N N (1- N))
       (STR (format nil "")))
      ((zerop N) STR)
    (setf STR (concatenate 'string STR " "))
  )
)

;;; This checks if nil was passed. If it was, print a blank line, then
;;; a "0" line. Else pass the list off to the WRITE-POLY1 function.
(defun WRITE-POLY (L)
  (cond
    ((null L) (format t "~%0~%"))
    (t        (WRITE-POLY1 L))
  )
)

;;; Given a list in Polynomial Normal Form, this will print
;;; the human readable form of the list on two lines.
;;; Example:
;;;   INPUT:  ((1 1) (2 3) (-10 0) (3 2) (2 1))
;;;   OUTPUT:      3      2      
;;;   OUTPUT: + 2 x  + 3 x  + 3 x - 10
(defun WRITE-POLY1 (L)
  (do ((L (PNF L) (cdr L))
       (EXP  (format nil ""))
       (COEF (format nil "")))
      ((null L) (format t "~A~%~A~%" EXP COEF))
    (setf COEF (concatenate 'string COEF (WRITE-NUM (caar L) (cadar L))))
    (MAKE-EQUAL EXP COEF)
    (setf EXP  (concatenate 'string EXP  (WRITE-EXP (caar L) (cadar L))))
    (MAKE-EQUAL EXP COEF)
  )
)

;;; Given a coefficient and an exponent, output the correct expression
;;; to represent it.
;;; Examples:
;;; INPUT:  3 4
;;; OUTPUT: + 3 x
;;;
;;; INPUT:  3 0
;;; OUTPUT: + 3
;;;
;;; INPUT:  -3 0
;;; OUTPUT: - 3
(defun WRITE-NUM (NUM EXP)
  (cond
    ; don't output an x if we have a zero exponent
    ((zerop EXP) (if (plusp NUM) (format nil " + ~A" NUM) 
                                 (format nil " - ~A" (abs NUM))))
    ((plusp NUM) (format nil " + ~A x" NUM))
    (t           (format nil " - ~A x" (abs NUM)))
  )
)

;;; Given a coefficient and an exponent, output the exponent.
;;; NOTE: I chose to have the syntax of WRITE-EXP match the syntax of WRITE-NUM
;;;       even though I do not use the parameter NUM in the code. This was for
;;;       uniformity reasons.
(defun WRITE-EXP (NUM EXP)
  (cond
    ((zerop EXP) nil)
    ((= EXP 1)   nil)
    (t           (format nil "~A" EXP))
  )
)

;;; When called with two strings as arguments, this macro expands to
;;; make them the same length, regardless of which is longer.
(defmacro MAKE-EQUAL (S1 S2)
  `(cond
     ((> (length ,S1) (length ,S2)) (let ((DIFF (- (length ,S1) (length ,S2))))
                                    (setf ,S2 (concatenate 'string ,S2 (SPACES DIFF)))))
     ((< (length ,S1) (length ,S2)) (let ((DIFF (- (length ,S2) (length ,S1))))
                                    (setf ,S1 (concatenate 'string ,S1 (SPACES DIFF)))))
     (t                             nil)
   )
)