|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229 |
- ;; Jeg har med huffman.scm i leveringen, men ingenting der er endret.
-
- ;; Beklager blandingen av norsk og engelsk. Svar på oppgaver er skrevet
- ;; på norsk, kodekommentarer er skrevet på engelsk.
-
- (load "huffman.scm")
-
- ;;;;;;;
- ;; 1 ;;
- ;;;;;;;
-
- ;; A
-
- (define (p-cons x y)
- (lambda (proc) (proc x y)))
-
- (define (p-car p)
- (p (lambda (x y) x)))
-
- (define (p-cdr p)
- (p (lambda (x y) y)))
-
- ;; B
-
- (define foo 42)
-
- ;; let (evaluerer til 'different):
- (let ((foo 5)
- (x foo))
- (if (= x foo)
- 'same
- 'different))
-
- ;; med lambda:
- ((lambda (foo x)
- (if (= x foo)
- 'same
- 'different))
- 5 foo)
-
- ;; let (evaluerer til ('towel (42 'towel)))
- (let ((bar foo)
- (baz 'towel))
- (let ((bar (list bar baz))
- (foo baz))
- (list foo bar)))
-
- ;; med lambda:
- ((lambda (bar baz)
- ((lambda (bar foo)
- (list foo bar))
- (list bar baz) baz))
- foo 'towel)
-
- ;; C
-
- (define (infix-eval exp)
- (let ((opr1 (car exp))
- (operator (cadr exp))
- (opr2 (caddr exp)))
- (operator opr1 opr2)))
-
- ;; D
-
- ;; Resultatet blir en "not a procedure"-feil. Dette er fordi at når vi bruker
- ;; quote er / et symbol, ikke en prosedyre. '(/) er dermed en liste som
- ;; inneholder symbolet /, mens (list /) blir en liste som inneholder prosedyren
- ;; med navn /.
-
- ;;;;;;;
- ;; 2 ;;
- ;;;;;;;
-
- ;; A
-
- (define (member? eq-pred el items)
- (cond ((null? items) #f)
- ((eq-pred el (car items)) #t)
- (else (member? eq-pred el (cdr items)))))
-
- ;; B
-
- ;; Det er nødvendig med en intern prosedyre fordi vi trenger tilgang
- ;; til roten av treet. Siden vi har en decode-1 prosedyre inne i decode,
- ;; har decode-1 tilgang til både variablen tree, som er roten av treet,
- ;; og current-branch, som er sub-treet den holder på med.
-
- ;; C
-
- (define (decode bits tree)
- (define (decode-1 bits current-branch acc)
- (if (null? bits)
- (reverse acc)
- (let ((next-branch
- (choose-branch (car bits) current-branch)))
- (cond ((leaf? next-branch)
- (decode-1 (cdr bits) tree (cons (symbol-leaf next-branch) acc)))
- (else (decode-1 (cdr bits) next-branch acc))))))
- (decode-1 bits tree '()))
-
- ;; D
-
- (decode sample-code sample-tree)
- ;; -> (ninjas fight ninjas by night)
-
- ;; E
-
- ;; This procedure isn't inside the encode function, as it's
- ;; useful later
- (define (encode-symbol sym tree)
- (cond ((leaf? tree) '())
- ((member? eq? sym (symbols (left-branch tree)))
- (cons 0 (encode-symbol sym (left-branch tree))))
- (else
- (cons 1 (encode-symbol sym (right-branch tree))))))
-
- (define (encode syms tree)
- (if (null? syms)
- '()
- (append (encode-symbol (car syms) tree)
- (encode (cdr syms) tree))))
-
- ;; F
-
- (define (grow-huffman-tree freqs)
- (define (get-biggest freqs)
- (define (get-biggest-1 freqs biggest)
- (cond ((null? freqs) biggest)
- ((> (cadr(car freqs)) (cadr biggest))
- (get-biggest-1 (cdr freqs) (car freqs)))
- (else (get-biggest-1 (cdr freqs) biggest))))
- (get-biggest-1 freqs (car freqs)))
-
- ;; Returns a new list with the element removed.
- ;; The list is reversed because we don't care about the order.
- (define (remove-from-list items elem)
- (define (remove-1 items elem acc)
- (cond ((null? items) acc)
- ((eq? elem (car items)) (remove-1 (cdr items) elem acc))
- (else (remove-1 (cdr items) elem (cons (car items) acc)))))
- (remove-1 items elem '()))
-
- ;; Inner function because I don't want to define get-biggest
- ;; and remove-from-list for every single iteration.
- ;; Maybe scheme optimizes that away, but it felt weird.
- (define (grow-tree-1 freqs)
- (if (null? (cdr freqs))
- (make-leaf (caar freqs) (cadar freqs))
- (let ((biggest (get-biggest freqs)))
- (make-code-tree (make-leaf (car biggest) (cadr biggest))
- (grow-tree-1 (remove-from-list freqs biggest))))))
- (grow-tree-1 freqs))
-
- ;; G
-
- (define g-freqs
- '((samurais 57) (ninjas 20) (fight 45) (night 12) (hide 3) (in 2)
- (ambush 2) (defeat 1) (the 5) (sword 4) (by 12) (assassin 1)
- (river 2) (forest 1) (wait 1) (poison 1)))
-
- (define g-tree (grow-huffman-tree g-freqs))
-
- (define g-msg '(ninjas fight
- ninjas fight ninjas
- ninjas fight samurais
- samurais fight
- samurais fight ninjas
- ninjas fight by night))
-
- (encode g-msg g-tree)
- ;; -> (1 1 0 1 0 1 1 0 1 0 1 1 0 1 1 0 1 0 0 0 1
- ;; 0 0 1 0 1 1 0 1 1 0 1 0 1 1 1 0 1 1 1 1 0)
-
- ;; - 42 bits.
- ;; - Den gjennomsnittlige lengden av hvert ord er rundt 2.47 bits (42 / 17).
- ;; - Den minste mengden bits vi kan få med en fixed-length code er 51.
- ;; Dette er fordi vi har forskjellige 5 symboler, og den minste antall bits
- ;; som har minst 5 forskjellige verdier er 3. Meldingen er 17 symboler lang,
- ;; og 17 * 3 = 51.
-
- ;; H
-
- (define (huffman-leaves tree)
- (define (sym s)
- (list (list (symbol-leaf s) (weight-leaf s))))
-
- (if (leaf? tree)
- (sym tree)
- (append (huffman-leaves (left-branch tree))
- (huffman-leaves (right-branch tree)))))
-
- (huffman-leaves sample-tree)
- ;; -> ((ninjas 8) (fight 5) (night 1) (by 1))
-
- ;; I
-
- ;; This is kind of big and ugly. I found out that you apparently can't
- ;; first define a procedure, then define a variable whose definition
- ;; uses that procedure. As a result, I have to define code-length-1 within
- ;; a let, even though it seems kind of unnecessary.
- (define (expected-code-length tree)
- (define syms (huffman-leaves tree))
-
- ;; Function to count the total frequencies
- (define (total-freqs-1 syms acc)
- (cond ((null? syms) acc)
- (else (total-freqs-1 (cdr syms) (+ acc (cadar syms))))))
-
- (let ((total-freqs (total-freqs-1 syms 0)))
-
- ;; Get the number of bits for a symbol
- (define (c sym)
- (length (encode-symbol (car sym) tree)))
-
- ;; Get the relative frequency of a symbol
- (define (p sym)
- (/ (cadr sym)
- total-freqs))
-
- (define (code-length-1 syms)
- (if (null? syms)
- 0
- (+ (* (p (car syms))
- (c (car syms)))
- (code-length-1 (cdr syms)))))
- (code-length-1 syms)))
-
- (expected-code-length sample-tree)
- ;; -> 8/5
|