;;;
;;; solution3.lisp: Solution for selected exercises in LISP Tutorial 3
;;; Philip W. L. Fong
;;; SFU CMPT 310 (2001-1)
;;;

;;
;; Binary Trees
;;

(defun bin-tree-size (B)
  "Return the number of members in binary tree B."
  (if (bin-tree-leaf-p B)
      1
    (+ 1 
       (bin-tree-size (bin-tree-node-left B)) 
       (bin-tree-size (bin-tree-node-right B)))))

(defun bin-tree-postorder (B)
  "Create a list containing elements of B in postorder."
  (if (bin-tree-leaf-p B)
      (list (bin-tree-leaf-element B))
    (let
	((elmt  (bin-tree-node-element B))
	 (left  (bin-tree-node-left    B))
	 (right (bin-tree-node-right   B)))
      (append (bin-tree-postorder left)
	      (append (bin-tree-postorder right)
		      (cons elmt nil))))))

(defun fast-bin-tree-postorder (B)
  "A tail-recursive version of bin-tree-postorder."
  (postorder-aux B nil))

(defun postorder-aux (B A)
  "Append A to the end of the list containing elements of B in postorder."
  (if (bin-tree-leaf-p B)
      (cons (bin-tree-leaf-element B) A)
    (let
	((elmt  (bin-tree-node-element B))
	 (left  (bin-tree-node-left    B))
	 (right (bin-tree-node-right   B)))
      (postorder-aux left
		     (postorder-aux right 
				    (cons elmt A))))))

(defun bin-tree-inorder (B)
  "Create a list containing elements of B in inorder."
  (if (bin-tree-leaf-p B)
      (list (bin-tree-leaf-element B))
    (let
	((elmt  (bin-tree-node-element B))
	 (left  (bin-tree-node-left    B))
	 (right (bin-tree-node-right   B)))
      (append (bin-tree-inorder left) 
	      (cons elmt
		    (bin-tree-inorder right))))))

(defun fast-bin-tree-inorder (B)
  "A tail-recursive version of bin-tree-inorder."
  (inorder-aux B nil))

(defun inorder-aux (B A)
  "Append A to the end of the list containing elements of B in inorder."
  (if (bin-tree-leaf-p B)
      (cons (bin-tree-leaf-element B) A)
    (let
	((elmt  (bin-tree-node-element B))
	 (left  (bin-tree-node-left    B))
	 (right (bin-tree-node-right   B)))
      (inorder-aux left
		   (cons elmt
			 (inorder-aux right A))))))

;;
;; Sorted List
;;

(defun make-empty-sorted-list ()
  "Create empty sorted list."
  nil)

(defun sorted-list-empty-p (L)
  "Test if a sorted list L is empty."
  (null L))

(defun sorted-list-member-p (L E)
  "Test if element E is a member of a sorted list L."
  (if (null L)
      nil
    (if (> E (first L))
	(sorted-list-member-p (rest L) E)
      (= E (first L)))))

(defun sorted-list-insert (L E)
  "Insert element E into a sorted list L to produce a new sorted list."
  (if (null L)
      (list E)
    (if (> E (first L))
	(cons (first L) (sorted-list-insert (rest L) E))
      (if (= E (first L))
	  L
	(cons E L)))))

(defun sorted-list-remove (L E)
  "Remove element E from sorted list L to produce a new sorted list."
  (if (null L)
      nil
    (if (> E (first L))
	(cons (first L) (sorted-list-remove (rest L) E))
      (if (= E (first L))
	  (rest L)
	L))))

;;
;; Polynomials
;;
;; Newly introduced materials are tagged by ";-- new"
;;

;;
;; Constructors for polynomials
;;

(defun make-constant (num)
  num)

(defun make-variable (sym)
  sym)

;-- new
(defun make-negation (poly)
  (list '- poly))

(defun make-sum (poly1 poly2)
  (list '+ poly1 poly2))

;-- new
(defun make-difference (poly1 poly2)
  (list '- poly1 poly2))

(defun make-product (poly1 poly2)
  (list '* poly1 poly2))

(defun make-power (poly num)
  (list '** poly num))

;;
;; Recognizers for polynomials
;;

(defun constant-p (poly)
  (numberp poly))

(defun variable-p (poly)
  (symbolp poly))

;-- new
(defun negation-p (poly)
  (and (listp poly) (eq (first poly) '-) (null (rest (rest poly)))))

(defun sum-p (poly)
  (and (listp poly) (eq (first poly) '+)))

;-- new
(defun difference-p (poly)
  (and (listp poly) (eq (first poly) '-) (not (null (rest (rest poly))))))

(defun product-p (poly)
  (and (listp poly) (eq (first poly) '*)))

(defun power-p (poly)
  (and (listp poly) (eq (first poly) '**)))

;;
;; Selectors for polynomials
;;

(defun constant-numeric (const)
  const)

(defun variable-symbol (var)
  var)

;-- new
(defun negation-arg (neg)
  (second neg))

(defun sum-arg1 (sum)
  (second sum))

(defun sum-arg2 (sum)
  (third sum))

;-- new
(defun difference-arg1 (diff)
  (second diff))

;-- new
(defun difference-arg2 (diff)
  (third diff))

(defun product-arg1 (prod)
  (second prod))

(defun product-arg2 (prod)
  (third prod))

(defun power-base (pow)
  (second pow))

(defun power-exponent (pow)
  (third pow))

;;
;; Unevaluated derivative
;;

(defun make-derivative (poly x)
    (list 'd poly x))

(defun derivative-p (poly)
  (and (listp poly) (eq (first poly) 'd)))

;;
;; Differentiation function
;;

(defun d (poly x)
  (cond
   ((constant-p poly) 0)
   ((variable-p poly) 
    (if (equal poly x) 
	1 
      (make-derivative poly x)))
   ;-- new
   ((negation-p poly)
    (make-negation (d (negation-arg poly) x)))
   ((sum-p poly) 
    (make-sum (d (sum-arg1 poly) x) 
	      (d (sum-arg2 poly) x)))
   ;-- new
   ((difference-p poly)
    (make-difference (d (difference-arg1 poly) x)
		     (d (difference-arg2 poly) x)))
   ((product-p poly) 
    (make-sum (make-product (product-arg1 poly) 
			    (d (product-arg2 poly) x))
	      (make-product (product-arg2 poly) 
			    (d (product-arg1 poly) x))))
   ((power-p poly)
    (make-product (make-product (power-exponent poly)
				(make-power (power-base poly) 
					    (1- (power-exponent poly))))
		  (d (power-base poly) x)))))

;;
;; Simplification function
;;

(defun simplify (poly)
  "Simplify polynomial POLY."
  (cond
   ((constant-p poly) poly)
   ((variable-p poly) poly)
   ;-- new
   ((negation-p poly) 
    (let ((arg (simplify (negation-arg poly))))
      (make-simplified-negation arg)))
   ((sum-p poly)
    (let ((arg1 (simplify (sum-arg1 poly)))
	  (arg2 (simplify (sum-arg2 poly))))
      (make-simplified-sum arg1 arg2)))
   ((product-p poly)
    (let ((arg1 (simplify (product-arg1 poly)))
	  (arg2 (simplify (product-arg2 poly))))
      (make-simplified-product arg1 arg2)))
   ;-- new
   ((difference-p poly)
    (let ((arg1 (simplify (difference-arg1 poly)))
	  (arg2 (simplify (difference-arg2 poly))))
      (make-simplified-difference arg1 arg2)))
   ((power-p poly)
    (let ((base (simplify (power-base poly)))
	  (exponent (simplify (power-exponent poly))))
      (make-simplified-power base exponent)))
   ((derivative-p poly) poly)))

;-- new
(defun make-simplified-negation (arg)
  "Given simplified polynomial ARG, construct a simplified negation of ARG."
  (cond
   ((and (constant-p arg) (zerop arg)) arg)
   ((negation-p arg)                   (negation-arg arg))
   (t                                  (make-negation arg))))

(defun make-simplified-sum (arg1 arg2)
  "Given simplified polynomials ARG1 and ARG2, construct a simplified sum of ARG1 and ARG2."
  (cond
   ((and (constant-p arg1) (zerop arg1)) arg2)
   ((and (constant-p arg2) (zerop arg2)) arg1)
   ;-- new
   ((negation-p arg1)                   (make-simplified-difference 
					 arg2 (negation-arg arg1)))
   ;-- new
   ((negation-p arg2)                   (make-simplified-difference 
					 arg1 (negation-arg arg2)))
   (t                                   (make-sum arg1 arg2))))

;-- new
(defun make-simplified-difference (arg1 arg2)
  "Given simplified polynomials ARG1 and ARG2, construct a simplified difference of ARG1 and ARG2."
  (cond
   ((and (constant-p arg2) (zerop arg2)) arg1)
   ((and (constant-p arg1) (zerop arg1)) (make-simplified-negation arg2))
   ((negation-p arg2)                    (make-simplified-sum 
					  arg1 (negation-arg arg2)))
   (t                                    (make-difference arg1 arg2))))

(defun make-simplified-product (arg1 arg2)
  "Given simplified polynomials ARG1 and ARG2, construct a simplified product of ARG1 and ARG2."
  (cond
   ((and (constant-p arg1) (zerop arg1)) (make-constant 0))
   ((and (constant-p arg2) (zerop arg2)) (make-constant 0))
   ((and (constant-p arg1) (= arg1 1))   arg2)
   ((and (constant-p arg2) (= arg2 1))   arg1)
   ;-- new
   ((and (constant-p arg1) (= arg1 -1))  (make-simplified-negation arg2))
   ;-- new
   ((and (constant-p arg2) (= arg2 -1))  (make-simplified-negation arg1))
   (t                                    (make-product arg1 arg2))))

(defun make-simplified-power (base exponent)
  "Given simplified polynomials BASE and EXPONENT, construct a simplified power with base BASE and exponent EXPONENT."
  (cond
   ((and (constant-p exponent) (= exponent 1))   base)
   ((and (constant-p exponent) (zerop exponent)) (make-constant 1))
   (t                                            (make-power base exponent))))