fixup

3 files changed, 167 insertions, 17 deletions

diff --git a/coding-exercises/2/67.rkt b/coding-exercises/2/67.rkt
index d6021b1..fec1388 100644
--- a/coding-exercises/2/67.rkt
+++ b/coding-exercises/2/67.rkt
@@ -56,8 +56,7 @@
 
 (define (adjoin-set x mset)
   (cond ((null? mset) (list x))
-        ((< (weight x) (weight (car mset))
-            (cons x mset)))
+        ((< (weight x) (weight (car mset))) (cons x mset))
         (else (cons (car mset)
                     (adjoin-set x (cdr mset))))))
 
@@ -67,7 +66,7 @@
     (let ((pair (car pairs)))
       (adjoin-set (make-leaf (car pair)
                              (cadr pair))
-                  (make-leaf-set (cdr pairs))))))
+               (make-leaf-set (cdr pairs))))))
 
 ;; 67
 (define sample-tree
@@ -88,18 +87,93 @@
     (append (encode-symbol (car message) tree)
             (encode (cdr message) tree))))
 
+
+;; just use id as key
+(define (key x)
+  x)
+
+;; scan for symbol
+(define (list-lookup given-key set-of-records)
+  (cond ((null? set-of-records) false)
+        ((equal? given-key (key (car set-of-records)))
+         (car set-of-records))
+        (else (list-lookup given-key (cdr set-of-records)))))
+
+;; without using symbol list, for some reason
+;; This is probably not the best way to do it because we cannot short circuit the search using the symbol list that is available at each node.
+;; (define (encode-symbol s tree)
+;;   (define (bits result subtree)
+;;     (cond ((and (leaf? subtree) 
+;;                 (equal? s (car (symbol-set subtree))))
+;;            result)
+;;       ((leaf? subtree) '())
+;;       (else
+;;         (let ((left (bits 
+;;                       (cons 0 result) 
+;;                       (left-branch subtree))))
+;;           (if (null? left)
+;;             (bits (cons 1 result) (right-branch subtree))
+;;             left)))))
+;;   (reverse (bits '() tree)))
+
 (define (encode-symbol s tree)
-  (define (bits result subtree)
-    (cond ((and (leaf? subtree) 
-                (equal? s (car (symbol-set subtree))))
-           result)
-      ((leaf? subtree) '())
-      (else
-        (let ((left (bits 
-                      (cons 0 result) 
-                      (left-branch subtree))))
-          (if (null? left)
-            (bits (cons 1 result) (right-branch subtree))
-            left)))))
-  (reverse (bits '() tree)))
+  (cond ((leaf? tree) '())
+        ((list-lookup s (symbol-set (left-branch tree)))
+         (cons 0 (encode-symbol s (left-branch tree))))
+        ((list-lookup s (symbol-set (right-branch tree)))
+         (cons 1 (encode-symbol s (right-branch tree))))
+        (else (error "Symbol not in tree -- ENCODE-SYMBOL" s tree))))
 (encode (decode sample-message sample-tree) sample-tree)
+(encode '(E) sample-tree)
+
+;; 69
+(define (generate-huffman-tree pairs)
+  (successive-merge (make-leaf-set pairs)))
+
+(define (successive-merge weighted-leafs)
+  (define (merge lightest leafs)
+    (if (null? leafs)
+      lightest
+      (let ((leafs-with-node
+              (adjoin-set (make-code-tree
+                            lightest
+                            (car leafs))
+                          (cdr leafs))))
+        (merge (car leafs-with-node)
+               (cdr leafs-with-node)))))
+  (merge (car weighted-leafs)
+         (cdr weighted-leafs)))
+(generate-huffman-tree '((A 4) (B 2) (C 1) (D 1)))
+
+;; 70
+(define rock-songs-leafs '((A 2) (BOOM 1)
+                           (GET 2) (JOB 2)
+                           (NA 16) (SHA 3)
+                           (YIP 9) (WAH 1)))
+(define rock-songs-tree
+  (generate-huffman-tree rock-songs-leafs))
+
+(define rock-songs-bits
+  (encode '(GET A JOB
+            SHA NA NA NA NA NA NA NA NA
+            GET A JOB
+            SHA NA NA NA NA NA NA NA NA
+            WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP
+            SHA BOOM)
+          rock-songs-tree))
+;; variable length codes with huffman tree
+(length rock-songs-bits)
+;; fixed length codes with 8 symbols
+(expt 2 (length rock-songs-leafs))
+
+;; 71
+;; Most frequent is always a leaf from the root, so only one bit
+;; Least frequent requires d bits where d is the depth of the tree,
+;; in this case the tree is unbalanced so the depth is linear or n-1.
+;; (= (+ 2**(i-2) 2**(i-1)) (- 2**i 1))
+
+;; 72
+;; You can do best worst case scenario's for searches and positions in the tree
+;; and you can argue average time complexities for different known weight distributions that result in balanced or unbalanced trees.
+;; I did them on paper and I'm a messy louise reasoner.
+;; Maybe I'll come back someday and write it up.
diff --git a/coding-exercises/2/73.rkt b/coding-exercises/2/73.rkt
new file mode 100644
index 0000000..edb8e44
--- /dev/null
+++ b/coding-exercises/2/73.rkt
@@ -0,0 +1,70 @@
+#lang racket
+(require "../../shared/lists.rkt")
+
+;; a. Number and variable are primitives that return a boolean.
+;;      But what you want is a type assertion that has the same signature as the rest.
+
+;;      The operator procedure for example returns the symbol that indicates whether the expression is a sum or product.
+;;      Get fetches a procedure from the dispatch table that defines how to take the derivative of the expression. But that is not a problem because you can define 
+;;      the derivatives of a number or variable as procedures. This is one step that needs to be done first.
+;;
+;;      The get and put procedures on the dispatch table just need to support the type-tag of the expression, which is not supported for booleans. (i think?)
+;;      So you might type tag variables and expressions. But this changes the underlying representation of the expression. Which we are not interested in right now.
+
+;; b.
+(define (variable? x) (symbol? x))
+(define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y)))
+
+(define dispatch-table '())
+(define (attach-tag type-tag contents)
+  (cons type-tag contents))
+(define (type-tag datum)
+  (if (pair? datum)
+    (car datum)
+    (error "Bad tagged datum -- TYPE-TAG" datum)))
+(define (contents datum)
+  (if (pair? datum)
+    (cdr datum)
+    (error "Bad tagged datum -- CONTENTS" datum)))
+(define (make-eq-type? type)
+  (lambda (d)
+    (eq? (type-tag d) type)))
+
+(define (get op type)
+  (let ((op-entry (find-first (make-eq-type? op)
+                              dispatch-table)))
+    (if (pair? op-entry)
+      (let ((installed-types (cdr op-entry)))
+        (let ((dispatch-proc-entry (find-first (make-eq-type? type)
+                                               installed-types)))
+          (if (pair? dispatch-proc-entry)
+            (cdr dispatch-proc-entry)
+            (error "Bad op or op not defined for type -- GET" op type dispatch-proc-entry))))
+      (error "Not found or bad entry -- GET" op type op-entry))))
+(define (put op type item)
+  (if (find-first (make-eq-type? op) dispatch-table)
+    (set! dispatch-table (map (lambda (op-entry) ;;just copy the table for now, don't want to mutate yet
+                                (if (not (eq? (type-tag op-entry) op))
+                                  op-entry
+                                  (cons (attach-tag op
+                                                    (let ((installed-types (cdr op-entry)))
+                                                       (map (lambda (type-entry)
+                                                              (if (not (eq? (type-tag type-entry) type))
+                                                                type-entry
+                                                                (attach-tag type item)))
+                                                          installed-types))))))
+                              dispatch-table))
+    (set! dispatch-table (cons (attach-tag op (list (attach-tag type item)))
+                               dispatch-table))))
+
+;; prefix combination notation of expression? (+ a b)
+(define (operator ex)
+  (car ex))
+
+(define (operands ex)
+  (cdr ex))
+
+(define (deriv ex var)
+  (cond ((number? ex) 0)
+        ((variable? ex) (if (same-variable? ex var) 1 0))
+        (else ((get 'deriv (operator ex)) (operands ex) var))))
diff --git a/shared/lists.rkt b/shared/lists.rkt
index 8437fcb..ac501fd 100644
--- a/shared/lists.rkt
+++ b/shared/lists.rkt
@@ -5,7 +5,8 @@
          fold-left
          flatmap
          enumerate-interval
-         enumerate-windows)
+         enumerate-windows
+         find-first)
 
 (define (append list1 list2)
   (if (null? list1)
@@ -94,3 +95,8 @@
 (enumerate-windows
   (enumerate-interval 1 4)
   2)
+
+(define (find-first pred? seq)
+  (cond ((null? seq) false)
+        ((pred? (car seq)) (car seq))
+        (else (find-first pred? (cdr seq)))))