|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316 |
- (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")))
|