sicp-exercises/ex-2-53.lisp

;; I'm using common lisp from this point on,
;; I honestly kind of got bored with scheme.
;; CL is pretty good though. using scheme now.

;; well, this means we gotta reimplement
;; a lot of the things in the book, because we can't
;; just copy&paste them. but that's fine.

;; as an aside, I probably could get pretty close
;; to being able to copy-paste with this macro:
(defun rest-symbol (param-list)
  (cond
    ((null param-list)
     nil)
    ((consp param-list)
     (cons (car param-list) (rest-symbol (cdr param-list))))
    ((symbolp param-list)
     (list '&rest param-list))
    (t (error "non-symbol as tail element of parameter list."))))
(defmacro define (name &body body)
  (cond
    ((symbolp name) `(defparameter ,name ,@body))
    ((listp name) `(defun ,(first name)
		       ,(rest-symbol (rest name))
		     ,@body))
    (t (error "Whoops, cannot expand define"))))
;; This essentially allows us to use scheme-style
;; define syntax for defining variables and
;; procedures.
;; I won't be using this for every single exercise though,
;; cuz that's kinda boring.


(defun memq (item l)
  "This definition doesn't have many differences from the book."
  (cond
    ((null l) nil)
    ((eq item (car l)) l)
    (t (memq item (cdr l)))))

(memq 'apple '(pear banana prune)) ;; => NIL
(memq 'apple '(x (apple sauce) y apple pear)) ;; = (APPLE PEAR)

;; EX 2.54
(defun my-equal? (a b)
  "fun fact: when I first began common lisp, I used to be kind of annoyed/afraid
of defining functions recursively like this. I thought this would be less efficient
than using a loop like in C.

Now I know better of course. On SBCL, this is fully tail call optimised,
and therefore can be used on lists of any length with no fear for
stack overflow. It generates an iterative process, despite being \"recursive\"
so this is actually as efficient as can be."
  (cond
    ((eq a b)  t)
    ((and (listp a) (listp b))
     (if (my-equal? (car a) (car b))
	 (my-equal? (cdr a) (cdr b))
	 nil))
    (t nil)))


;; Wooooo! symbolic derivation.
;; ex 2.56 is inside here somewhere

(defun var= (v1 v2)
  (and (symbolp v1) (symbolp v2) (eq v1 v2)))

(defun var!= (v1 v2)
  (and (symbolp v1) (symbolp v2) (not (eq v1 v2))))

(defun sump (e)
  (and (listp e) (eq '+ (car e))))

(defun addend (e)
  (second e))
(defun augend (e)
  ;; 2.57
  (if (> (length e) 3)
      `(+ ,@(cddr e))
      (third e)))

(defun productp (e)
  (and (listp e) (eq '* (car e))))
(defun multiplier (e)
  (second e))
(defun multiplicand (e)
  ;; 2.57
  (if (> (length e) 3)
      `(* ,@(cddr e))
      (third e)))

(defun number= (a b)
  (and (numberp a) (numberp b) (= a b)))

(defun make-sum (a b)
  (cond
    ((and (numberp a) (numberp b)) (+ a b))
    ((number= a 0) b)
    ((number= b 0) a)
    (t `(+ ,a ,b))))

(defun make-product (a b)
  (cond
    ((and (numberp a) (numberp b)) (* a b))
    ((number= a 0) 0)
    ((number= a 1) b)
    ((number= b 0) 0)
    ((number= b 1) a)
    (t (append (list '*)
	       (if (productp a) (cdr a) (list a))
	       (if (productp b) (cdr b) (list b))))))

(defun expt-p (e)
  (and (listp e) (eq '** (car e))))
(defun base (e)
  (second e))
(defun exponent (e)
  (third e))

(defun make-expt (b e)
  (cond
    ((number= b 0) 0)
    ((number= b 1) 1)
    ((number= e 0) 1)
    ((number= e 1) b)
    (t `(** ,b ,e))))

(defun deriv (expr var)
  (cond
    ((numberp expr) 0)	;; c/dx = 0
    ((var= expr var) 1)	;; dx/dx = 1
    ((and (symbolp expr) (var!= expr var)) 0)
    ((sump expr)
     (make-sum (deriv (addend expr) var)
	       (deriv (augend expr) var)))
    ((productp expr)
     (make-sum (make-product (multiplier expr) (deriv (multiplicand expr) var))
	       (make-product (multiplicand expr) (deriv (multiplier expr) var))))
    ;; EX 2.56 - exponentiaton derived.
    ((expt-p expr)
     (make-product (exponent expr)
		   (make-product (make-expt (base expr) (make-sum -1 (exponent expr)))
				 (deriv (base expr) var))))
    (t (error "unknown"))))

;; 2.58 - okay, so we *could* modify the selectors and stuff
;; above to make this work, but I kinda wanna keep those.
;; instead, I'll just make a function that transforms the new
;; input into the old input format (this is trivial for the
;; case with fully parenthesized input)
(defun transform-input (expr)
  (if (listp expr)
      (list (second expr) (transform-input (first expr)) (transform-input (third expr)))
      expr))
(defun deriv-infix (e v)
  (deriv (transform-input e) v))

;; ... and also kind of doable for the more general case.
;; requires more work though, but I guess that's the point.
(defparameter op-precedence (make-hash-table))
(loop for i in '((+ 1) (* 3) (** 5))
      do (setf (gethash (car i)  op-precedence) (second i)))

(defun prec (op)
  (gethash op op-precedence))
(defun collapse (ops items)
  (if (null ops)
      (car items)
      (collapse (cdr ops)
		(cons (list (first ops) (second items) (first items))
		      (cddr items)))))

;; (3 + 5 * 6 + 2)
;; (helper 0 expr nil)
;; (helper 1 '(5 * 6 + 2) '(+) '(3))
;; (helper 3 '(6 + 2) '(* +) '(5 3))
;; (helper 1 '(2) '() '(+ (* 6 5) 3))
;; (+ 3 (* 5 6) 2)
;; Fuckkkkkkk
;; this took way longer than it needed to.
;; not a good-looking implementation at all, really ugly.
;; but it works! correctly transforms infix notation
;; to prefix. (output can be directly used by deriv)
(defun transform-infix (expr)
  (cond
    ((null expr) nil)
    ((or (numberp expr) (symbolp expr)) expr)
    (t (labels ((helper (expr ops items)
		  (format t "~a ~a ~a~%" expr ops items)
		  (cond
		    ((null expr) items)
		    ((null (cdr expr))
		     (collapse ops (cons (transform-infix
					  (car expr))
					 items)))
		    ((>= (prec (second expr)) (or (prec (car ops)) 0))
		     (helper (cddr expr)
			     (cons (second expr) ops)
			     (cons (transform-infix (first expr))
				   items)))
		    (t
		     (helper (cddr expr)
			     (cons (second expr) nil)
			     (list (collapse ops
					 (cons (transform-infix
						(first expr))
					       items))))))))
	 (helper expr '() '())))))

(defun deriv-real-infix (e v)
  (deriv (transform-infix e) v))