More progress. Got up to 2.65

.gitignore

@@ -1,2 +1,3 @@
 \#*
 *~
+*.fasl

ex-2-40.rkt

@@ -133,6 +133,7 @@
   (make-vect (* (vect-xcoor v) n)
              (* (vect-ycoor v) n)))
 ;; 2.47
+;; a list-of-three representation
 (define (make-frame1 origin edge1 edge2)
   (list origin edge1 edge2))
 (define (frame-origin1 f)
@@ -142,8 +143,61 @@
 (define (frame-edge2-1 f)
   (list-ref f 2))
 
+; two cons representation
 (define (make-frame2 origin edge1 edge2)
   (cons origin (cons edge1 edge2)))
 (define frame-origin2 car)
 (define frame-edge1-2 cadr)
 (define frame-edge2-2 cddr)
+
+; choose one impl
+(define origin-frame frame-origin2)
+(define edge1-frame frame-edge1-2)
+(define edge2-frame frame-edge2-2)
+
+;; 2.48
+;; decided to stop using define-struct for this, as it kinda
+;; screws with the naming conventions
+(define make-segment cons)
+
+(define start-segment car)
+(define end-segment cdr)
+
+;; 2.49
+(define (draw-line x y) #f)
+(define (frame-coord-map frame)
+  (lambda (v)
+    (add-vect
+     (origin-frame frame)
+     (add-vect (scale-vect (xcoor-vect v) (edge1-frame frame))
+               (scale-vect (ycoor-vect v) (edge2-frame frame))))))
+(define (segments->painter segment-list)
+  (lambda (frame)
+    (for-each
+     (lambda (segment)
+       (draw-line
+        ((frame-coord-map frame)
+         (start-segment segment))
+        ((frame-coord-map frame)
+         (end-segment segment))))
+     segment-list)))
+
+; I really should have thought of making a better
+; notation for these things, it would have been super easy too.
+; but I've already written it, so it stays, I guess.
+(define outline-painter
+  (segments->painter
+   (list (make-segment (make-vect 0 0) (make-vect 0 1))
+         (make-segment (make-vect 0 0) (make-vect 1 0))
+         (make-segment (make-vect 1 0) (make-vect 1 1))
+         (make-segment (make-vect 0 1) (make-vect 1 1)))))
+(define x-painter
+  (segments->painter
+   (list (make-segment (make-vect 0 0) (make-vect 1 1))
+         (make-segment (make-vect 1 0) (make-vect 0 1)))))
+(define diamond
+  (segments->painter
+   (list (make-segment (make-vect 0.5 0) (make-vect 0 0.5))
+         (make-segment (make-vect 0.5 0) (make-vect 1 0.5))
+         (make-segment (make-vect 0 0.5) (make-vect 0.5 1))
+         (make-segment (make-vect 1 0.5) (make-vect 0.5 1)))))

ex-2-53.lisp

@@ -0,0 +1,212 @@
+;; 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))

ex-2-59.lisp

@@ -0,0 +1,112 @@
+
+;; not gonna bother copy-pasting the rest of the implementation.
+;; ex 2.59
+(defun adjoin-set (s i)
+  (if (element-of-set? s i)
+      s
+      (cons i s)))
+(defun union-set (s1 s2)
+  (labels ((rec (s1 s2)
+	     (if (null s1)
+		 s2
+		 (rec (cdr s1) (adjoin-set s2 (car s1))))))
+    (rec s1 s2)))
+
+;; ex 2.60
+;; element-of-set? doesn't change I'm pretty sure.
+(defun element-of-set? (s e)
+  (if (null s)
+      nil
+      (element-of-set? (cdr s) e)))
+;; adjoin becomes more efficient, as it is now an O(1) operation
+(defun adjoin-set-duppy (s e)
+  (cons e s))
+;; union-set becomes a linear-time algorithm as it relies on adjoin-set.
+;; doesn't really change in logic otherwise, though.x
+(defun union-set-duppy (s1 s2)
+  (labels ((rec (s1 s2)
+	     (if (null s1)
+		 s2
+		 (rec (cdr s1) (adjoin-set s2 (car s1))))))
+    (rec s1 s2)))
+
+;; ex 2.61
+;; Note: NOT tail recursive. not gonna work for too long lists.
+;; though the book's given intersection-list is also not tail
+;; recursive, so this is probably intended.
+(defun adjoin-set-ordered (s1 i)
+  (cond
+    ((null s1) (cons i nil))
+    ((= i (car s1)) s1)
+    ((< i (car s1))
+     (cons i s1))
+    (t (cons (car s1) (adjoin-set-ordered (cdr s1) i)))))
+
+;; ex 2.62
+;; same with 2.61, not tail recursive
+;; both could be translated fairly easily though
+(defun union-set-ordered (s1 s2)
+  (cond
+    ((null s1) s2)
+    ((null s2) s1)
+    ((= (car s1) (car s2))
+     (cons (car s1)
+	   (union-set-ordered (cdr s1) (cdr s2))))
+    ((> (car s1) (car s2))
+     (cons (car s2)
+	   (union-set-ordered s1 (cdr s2))))
+    ((< (car s1) (car s2))
+     (cons (car s1)
+	   (union-set-ordered (cdr s1) s2)))
+    (t (error "asd"))))
+
+;; ex 2.63
+;; a) it looks like the result should be the same.
+;; tried the code, couldn't get them to give different results.
+;; on the figure 2.16 trees, they all give the same results.
+;; b) At first glance they might look equivalent. However,
+;; the first algorithm has a hidden cost in the append operation.
+;; because the fastest way to append two linked lists is an O(N)
+;; operation: so eventually it becomes O(N/2 + 2N/4 + 4N/8 + ... + logN)
+;; or something like that, which is O(N + logn) or O(N).
+;; the second algorithm doesn't waste time with that, and is therefore
+;; a flat O(logN). The second one takes less time.
+
+;; damn, raw lisp code can be hard to read. might be a skill issue.
+;; ex 2.64
+;; "short" paragraph. yeah.
+;; Okay, so...
+;; partial-tree takes a list of elements and n.
+;; in the base case, i.e. n = 0, the result is trivially just (cons nil elts)
+;; otherwise, the function calculates the length of the left half of the tree,
+;; recursively calls itself with that "left half". As partial-tree returns
+;; the rest of the elements, we take the "right half" from this rest of the elements
+;; (of course making sure to save and exclude the center element, as that is
+;; the root of the tree).
+;; This way, we create a tree by recursively creating the left subtree, then the right
+;; subtree, then we simply combine these to create the final tree.
+;; b) O(N) each element is visited exactly once.
+
+;; ex 2.65
+;; assuming the union and intersection don't have to maintain
+;; balance (or that's handled by something else)
+(defstruct btree elt left right)
+(defun adjoin-set-tree (s i)
+  (cond
+    ((null s) (make-btree :elt i :left nil :right nil))
+    ((= (btree-elt s) i) s)
+    ((< (btree-elt s) i)
+     (make-btree :elt (btree-elt s)
+		 :left (btree-left s)
+		 :right (adjoin-set-tree (btree-right s) i)))
+    ((> (btree-elt s) i)
+     (make-btree :elt (btree-elt s)
+		 :left (adjoin-set-tree (btree-left s) i)
+		 :right (btree-right s)))))
+(defun union-set-tree (s1 s2)
+  (cond
+    ((null s1) s2)
+    ((null s2) s1)
+    (t (union-set-tree (union-set-tree (btree-left s1) (btree-right s2))
+		       (adjoin-set-tree s2 (btree-elt s1))))))
+;; yeah, okay. this looks good enough, didn't test it at all, but whatevs.