uni/inf2810/hw3.a/oppgave.scm

(load "prekode3a.scm")

;;;;;;;
;; 1 ;;
;;;;;;;

;; A

(define (list-to-stream lst)
  (if (null? lst)
      '()
      (cons-stream (car lst) (list-to-stream (cdr lst)))))

(define (stream-to-list stream . n)
  (cond ((stream-null? stream)
         the-empty-stream)
        ((null? n)
         (cons (stream-car stream) (stream-to-list (stream-cdr stream))))
        ((= (car n) 0)
         the-empty-stream)
        (else (cons (stream-car stream)
                    (stream-to-list (stream-cdr stream) (- (car n) 1))))))

;; B

(define (stream-map proc . argstreams)
  (define (streams-done? streams)
    (cond ((null? streams) #f)
          ((stream-null? (car streams)) #t)
          (else (streams-done? (cdr streams)))))

  (if (streams-done? argstreams)
      the-empty-stream
      (cons-stream
        (apply proc
               (map stream-car argstreams))
        (apply stream-map
               (cons proc (map stream-cdr argstreams))))))

;; C

;; En stream kan være uendelig lang. Hvis vi for eksempel prøver å fjerne
;; duplikater fra nats-strømmen, strømmen med alle naturlige tall, vil vi
;; aldri bli ferdige med å sjekke om det første elementet forekommer flere
;; steder i strømmen.

;; D

;; (stream-ref x 5):
;; 0
;; 1
;; 2
;; 3
;; 4
;; 5
;; 5
;; Det viser alle tallene fra 0 til 5 med show (fordi strømmen er laget med
;; (stream-map show ...)), og så viser det siste tallet (5) fordi det er det
;; uttrykket returnerer (fordi 5 er verdien til posisjon 5 i strømmen).

;; (stream-ref x 7):
;; 6
;; 7
;; 7
;; Strømen x har allerede gått igjennom tallene 0 til 5, så den viser bare 6 og 7.
;; Det siste tallet er igjen her to ganger fordi uttrykket returnerer 7.

;;;;;;;
;; 2 ;;
;;;;;;;

;; Make table (implemented as a binary tree).
;; Arguments:
;;     eq: Predicate for equality.
;;     lt: Predicate for less than.
(define (make-table eq lt)

  ;; Node for the binary tree table.
  ;; Arguments:
  ;;     k: Key
  ;;     v: Value
  ;;     l: Left child
  ;;     r: Right child
  (define (make-node k v l r)
    (list k v l r))
  
  (define (node-k n) (car n))
  (define (node-v n) (cadr n))
  (define (node-l n) (caddr n))
  (define (node-r n) (cadddr n))
  
  (define (node-k! n key) (set-car! n key))
  (define (node-v! n val) (set-car! (cdr n) val))
  (define (node-l! n left) (set-car! (cddr n) left))
  (define (node-r! n right) (set-car! (cdddr n) right))
  
  (define (node-lookup n k)
    (cond ((null? n) #f)
          ((null? (node-k n)) #f)
          ((eq k (node-k n)) (node-v n))
          ((lt k (node-k n)) (node-lookup (node-l n) k))
          (else (node-lookup (node-r n) k))))
  
  (define (node-insert! n k v)
    (cond ((null? (node-k n))
           (node-k! n k)
           (node-v! n v))
  
          ((eq k (node-k n))
           (node-v! n v))
  
          ((lt k (node-k n))
           (if (null? (node-l n))
               (node-l! n (make-node k v '() '()))
               (node-insert! (node-l n) k v)))
  
          (else
           (if (null? (node-r n))
               (node-r! n (make-node k v '() '()))
               (node-insert! (node-r n) k v)))))

  (define (node-iter n proc)
    (if (not (null? (node-v n)))
        (proc (node-k n) (node-v n)))
    (if (not (null? (node-l n)))
        (node-iter (node-l n) proc))
    (if (not (null? (node-r n)))
        (node-iter (node-r n) proc)))

  ;; I would've used (make-node) here, but would've had to complicate
  ;; everything, as you can't use the function to define a variable in
  ;; the same function body.
  (define root (list '() '() '() '()))

  (define (lookup k)
    (node-lookup root k))

  (define (insert! k v)
    (node-insert! root k v))

  (define (iter proc)
    (node-iter root proc))

  (lambda (symbol . args)
    (cond ((eq? symbol 'lookup) (apply lookup args))
          ((eq? symbol 'insert!) (apply insert! args))
          ((eq? symbol 'iter) (apply iter args))
          (else (error "Invalid symbol")))))

(define (table-lookup tbl k)
  (tbl 'lookup k))
(define (table-insert! tbl k v)
  (tbl 'insert! k v))
(define (table-iter tbl proc)
  (tbl 'iter proc))

(define (make-string-table) (make-table string=? string<?))

;; A

(define (make-lm)
  (define tbl (make-string-table))
  (define total 0)

  (define (lookup s1 s2)
    (let ((sub (table-lookup tbl s1)))
      (if (eq? sub #f)
          0
          (let ((freq (table-lookup sub s2)))
            (if (null? freq)
                0
                freq)))))

  (define (record-create-sub! s1 s2)
    (let ((sub (make-string-table)))
      (table-insert! sub s2 1)
      (table-insert! tbl s1 sub)
      (set! total (+ total 1))))

  (define (record! s1 s2)
    (if (eq? (table-lookup tbl s1) #f)
        (record-create-sub! s1 s2)
        (let ((sub (table-lookup tbl s1)))
          (if (table-lookup sub s2)
              (table-insert! sub s2 (+ (table-lookup sub s2) 1))
              (table-insert! sub s2 1))
          (set! total (+ total 1)))))

  (define (count s1)
    (let ((sub (table-lookup tbl s1)))
      (define count 0)
      (define (iter key val)
        (set! count (+ count val)))
      (if (eq? sub #f)
          0
          (begin
            (table-iter sub iter)
            count))))

  (lambda (symbol . args)
    (cond ((eq? symbol 'lookup) (apply lookup args))
          ((eq? symbol 'record!) (apply record! args))
          ((eq? symbol 'total) total)
          ((eq? symbol 'count) (apply count args))
          (else (error "Invalid symbol")))))

(define (lm-lookup-bigram lm s1 s2)
  (lm 'lookup s1 s2))
(define (lm-record-bigram! lm s1 s2)
  (lm 'record! s1 s2))

;; For C
(define (lm-total lm)
  (lm 'total))
(define (lm-count lm s1)
  (lm 'count s1))

;; B

(define (lm-train! lm sentences)
  (define (learn-sentence! lm sentence)
    (cond ((null? sentence)
           '())
          ((string=? (car sentence) "</s>")
           '())
          (else
           (lm-record-bigram! lm (car sentence) (cadr sentence))
           (learn-sentence! lm (cdr sentence)))))

  (cond ((null? sentences)
         '())
        (else
         (learn-sentence! lm (car sentences))
         (lm-train! lm (cdr sentences)))))

;; C

;; Det å gjøre at lm holder styr på antall par gjør denne delen unødvendig...
;; Jeg trenger bare en funksjon som regner ut sannsynligheten til et par
;; basert på frekvensen og antall par.

(define (lm-prob lm s1 s2)
  (let ((total (lm-total lm))
        (count (lm-count lm s1))
        (freq (lm-lookup-bigram lm s1 s2)))
    (cond ((eq? freq #f) (/ 1 total))
          ((= freq 0) (/ 1 total))
          (else (/ freq count)))))

;; D

(define (lm-score lm sentence)
  (if (string=? (car sentence) "</s>") 1
      (* (lm-prob lm (car sentence) (cadr sentence))
         (lm-score lm (cdr sentence)))))

;; Find most likely sentence
(let ((lm (make-lm)))
  (lm-train! lm (read-corpus "brown.txt"))
  (define pairs (map (lambda (sentence)
                       (cons sentence (lm-score lm sentence)))
                     (read-corpus "test.txt")))
  (define most-likely (car pairs))
  (define (iter pairs)
    (cond ((null? pairs) '())
          (else
            (if (> (cdr (car pairs)) (cdr most-likely))
                (set! most-likely (car pairs)))
            (iter (cdr pairs)))))

  (iter (cdr pairs))
  (display "Most likely sentence, according to brown.txt:")
  (newline)
  (display (car most-likely))
  (newline))

;; Den mest sannsynlige setningen, ifølge brown.txt:
;; It dismissed unfair, fundamentally illegal evidence, as the court approached the case.

;; E

;; Alle setningene er veldig usannsynlige, fordi sannsynligheten til alle
;; parene ganges sammen, og fordi for eksempel "As the" og "as the" telles som
;; forskjellige par (noe som er meningen ifølge piazza).
;; Vi ser likevel at en del av setningene blir mer annsynlige etter å ha lest
;; inn brown.txt.

(let ((lm (make-lm)))

  ;; Only wsj
  (lm-train! lm (read-corpus "wsj.txt"))
  (display "Only wsj:")
  (newline)
  (define (iter lm sentences)
    (cond ((null? sentences) '())
          (else
            (display (car sentences))
            (display ": ")
            (display (lm-score lm (car sentences)))
            (newline)
            (iter lm (cdr sentences)))))
  (iter lm (read-corpus "test.txt"))

  ;; wsj + brown
  (lm-train! lm (read-corpus "brown.txt"))
  (display "wsj + brown:")
  (newline)
  (define (iter2 lm sentences)
    (cond ((null? sentences) '())
          (else
            (display (car sentences))
            (display ": ")
            (display (lm-score lm (car sentences)))
            (newline)
            (iter2 lm (cdr sentences)))))
  (iter2 lm (read-corpus "test.txt")))