Subversion Repositories programming

; 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 3 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)

   )

)