From 4f1914027c89295e803393da045dac242fb49f37 Mon Sep 17 00:00:00 2001 From: Mike Vink <> Date: Sat, 1 Apr 2023 10:25:15 +0200 Subject: fixup --- coding-exercises/2/67.rkt | 106 +++++++++++++++++++++++++++++++++++++++------- coding-exercises/2/73.rkt | 70 ++++++++++++++++++++++++++++++ shared/lists.rkt | 8 +++- 3 files changed, 167 insertions(+), 17 deletions(-) create mode 100644 coding-exercises/2/73.rkt 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))))) -- cgit v1.2.3