uni/inf2810/hw2.a/oppgave.scm

;; 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