suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

First step in implementing updated probability model ---

Browse Source 
modification to P(error)

svn: r14368
This commit is contained in:
Kathy Gray 2009-03-30 22:44:06 +00:00
parent 2969412c87
commit 72e2049f96
4 changed files with 96 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/combinator-parser/private-combinator/combinator-parser.scm
View File

@ -181,7 +181,7 @@
[else out])))) [else out]))))
) )
(define-unit rank-defaults@ #;(define-unit rank-defaults@
(import) (import)
(export ranking-parameters^) (export ranking-parameters^)
(define (rank-choice choices) (apply max choices)) (define (rank-choice choices) (apply max choices))
@ -189,6 +189,15 @@
(rank-misspell rank-caps rank-class rank-wrong rank-end) (rank-misspell rank-caps rank-class rank-wrong rank-end)
(values 4/5 9/10 2/5 1/5 2/5))) (values 4/5 9/10 2/5 1/5 2/5)))
(define-unit rank-defaults@
(import)
(export ranking-parameters^)
(define (rank-choice choices) (apply max choices))
(define-values
(rank-misspell rank-caps rank-class rank-wrong rank-end rank-repeat)
(values 16/71 18/71 8/71 4/71 8/71 17/71)))
(define-unit out-struct@ (define-unit out-struct@
(import) (import)
(export out^) (export out^)

94
collects/combinator-parser/private-combinator/combinator.scm
View File

@ -15,6 +15,7 @@
(export combinator-parser-forms^) (export combinator-parser-forms^)
(define return-name "dummy") (define return-name "dummy")
(define terminal-occurs "unique-eq")
(define (make-weak-map) (make-weak-hasheq)) (define (make-weak-map) (make-weak-hasheq))
   
@ -34,7 +35,8 @@
;terminal: ('a -> bool 'a -> 'b string) -> ( (list 'a) -> res ) ;terminal: ('a -> bool 'a -> 'b string) -> ( (list 'a) -> res )
(define terminal (define terminal
(opt-lambda (pred build name [spell? #f] [case? #f] [class? #f]) (opt-lambda (pred build name [spell? #f] [case? #f] [class? #f])
(let* ([fail-str (string-append "failed " name)] (let* ([memo-table (make-weak-map)]
[fail-str (string-append "failed " name)]
[t-name (if src? (lambda (t) (token-name (position-token-token t))) token-name)] [t-name (if src? (lambda (t) (token-name (position-token-token t))) token-name)]
[t-val (if src? (lambda (t) (token-value (position-token-token t))) token-value)] [t-val (if src? (lambda (t) (token-value (position-token-token t))) token-value)]
[spell? (or spell? [spell? (or spell?
@ -62,49 +64,53 @@
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
#;(printf "terminal ~a~n" name) #;(printf "terminal ~a~n" name)
#;(cond #;(cond
[(eq? input return-name) [(eq? input return-name) (printf "name requested~n")]
(printf "dummy given~n")] [(null? input) (printf "null input~n")]
[(null? input) (printf "null given~n")]
[else [else
(let ([token (position-token-token (car input))]) (let ([token (position-token-token (car input))])
(printf "Look at token ~a~n" token) (printf "Token given ~a, match? ~a~n" token (pred token)))])
(printf "calling pred: ~a~n" (pred token)))])
(cond (cond
[(eq? input return-name) name] [(eq? input return-name) name]
[(null? input) [(eq? input terminal-occurs) (list (make-occurs name 1))]
(fail-res null (make-terminal-fail rank-end last-src name 0 0 'end #f))] [(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
[else [else
(let* ([curr-input (car input)] (let ([result
[token (if src? (position-token-token curr-input) curr-input)]) (cond
(cond [(null? input)
[(pred token) (fail-res null (make-terminal-fail rank-end last-src name 0 0 'end #f))]
(make-res (list (builder curr-input)) [else
(cdr input) name (let* ([curr-input (car input)]
(value curr-input) 1 #f curr-input)] [token (if src? (position-token-token curr-input) curr-input)])
[else (cond
#;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a ~n" name [(pred token)
(cond (make-res (list (builder curr-input))
[(token-value token) (cdr input) name
(token-value token)] (value curr-input) 1 #f curr-input)]
[else (token-name token)]) [else
(case? curr-input) #;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a ~n" name
(spell? curr-input)) (cond
(fail-res (cdr input) [(token-value token) (token-value token)]
(let-values ([(chance kind may-use) [else (token-name token)])
(cond (case? curr-input)
[(case? curr-input) (values rank-caps 'misscase 1)] (spell? curr-input))
[(> (spell? curr-input) 3/5) (fail-res (cdr input)
(values (* rank-misspell (let-values ([(chance kind may-use)
(spell? curr-input)) 'misspell 1)] (cond
[(class? curr-input) (values rank-class 'missclass 1)] [(case? curr-input) (values rank-caps 'misscase 1)]
[else (values rank-wrong 'wrong 0)])]) [(> (spell? curr-input) 3/5)
(make-fail chance name kind curr-input may-use)))]))]))))) (values (* rank-misspell
(spell? curr-input)) 'misspell 1)]
[(class? curr-input) (values rank-class 'missclass 1)]
[else (values rank-wrong 'wrong 0)])])
(make-fail chance name kind curr-input may-use)))]))])])
(weak-map-put! memo-table input result))])))))
;seq: ( (list ((list 'a) -> res)) ((list 'b) -> 'c) string -> ((list 'a) -> result) ;seq: ( (list ((list 'a) -> res)) ((list 'b) -> 'c) string -> ((list 'a) -> result)
(define seq (define seq
(opt-lambda (sub-list build name [id-position 0]) (opt-lambda (sub-list build name [id-position 0])
(let* ([sequence-length (length sub-list)] (let* ([sequence-length (length sub-list)]
[memo-table (make-weak-map)] [memo-table (make-weak-map)]
[terminal-counts #f]
[prev (lambda (x) [prev (lambda (x)
(cond [(eq? x return-name) "default previous"] (cond [(eq? x return-name) "default previous"]
[else (fail-res null null)]))] [else (fail-res null null)]))]
@ -131,6 +137,13 @@
#;(unless (eq? input return-name) (printf "seq ~a~n" name)) #;(unless (eq? input return-name) (printf "seq ~a~n" name))
(cond (cond
[(eq? input return-name) name] [(eq? input return-name) name]
[(eq? input terminal-occurs)
(or terminal-counts
(begin
(set! terminal-counts 'counting)
(set! terminal-counts
(consolidate-count (map (lambda (symbol) (symbol terminal-occurs)) sub-list)))
terminal-counts))]
[(weak-map-get memo-table input #f) [(weak-map-get memo-table input #f)
(weak-map-get memo-table input)] (weak-map-get memo-table input)]
[(null? sub-list) [(null? sub-list)
@ -659,6 +672,7 @@
(opt-lambda (input [start-src (list 1 0 1 0)] [alts 1]) (opt-lambda (input [start-src (list 1 0 1 0)] [alts 1])
(cond (cond
[(eq? input return-name) (repeat-name)] [(eq? input return-name) (repeat-name)]
[(eq? input terminal-occurs) (sub terminal-occurs)]
[(weak-map-get memo-table input #f)(weak-map-get memo-table input)] [(weak-map-get memo-table input #f)(weak-map-get memo-table input)]
[else [else
(let ([ans (let ([ans
@ -739,6 +753,7 @@
;choice: [list [[list 'a ] -> result]] name -> result ;choice: [list [[list 'a ] -> result]] name -> result
(define (choice opt-list name) (define (choice opt-list name)
(let ([memo-table (make-weak-map)] (let ([memo-table (make-weak-map)]
[terminal-counts #f]
[num-choices (length opt-list)] [num-choices (length opt-list)]
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
@ -746,8 +761,15 @@
#;(printf "possible options are ~a~n" (choice-names)) #;(printf "possible options are ~a~n" (choice-names))
(let ([sub-opts (sub1 (+ alts num-choices))]) (let ([sub-opts (sub1 (+ alts num-choices))])
(cond (cond
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
[(eq? input return-name) name] [(eq? input return-name) name]
[(eq? input terminal-occurs)
(or terminal-counts
(begin
(set! terminal-counts 'counting)
(set! terminal-counts
(consolidate-count (map (lambda (symbol) (symbol terminal-occurs)) opt-list)))
terminal-counts))]
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
[else [else
#;(printf "choice ~a~n" name) #;(printf "choice ~a~n" name)
#;(printf "possible options are ~a~n" (choice-names)) #;(printf "possible options are ~a~n" (choice-names))

2
collects/combinator-parser/private-combinator/parser-sigs.ss
View File

@ -186,7 +186,7 @@
(src? input-type show-options max-depth max-choice-depth)) (src? input-type show-options max-depth max-choice-depth))
(define-signature ranking-parameters^ (define-signature ranking-parameters^
(rank-misspell rank-caps rank-class rank-wrong rank-end rank-choice)) (rank-misspell rank-caps rank-class rank-wrong rank-end rank-choice rank-repeat))
(define-signature updating-rank^ (define-signature updating-rank^
(blamed-terminal failed-last-parse)) (blamed-terminal failed-last-parse))

27
collects/combinator-parser/private-combinator/structs.scm
View File

@ -37,6 +37,33 @@
(define-struct lazy-opts ((matches #:mutable) errors (thunks #:mutable)) #:transparent) (define-struct lazy-opts ((matches #:mutable) errors (thunks #:mutable)) #:transparent)
;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string) ;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string)
(define-struct (lazy-choice lazy-opts) (name) #:transparent) (define-struct (lazy-choice lazy-opts) (name) #:transparent)
;(make-count string int)
(define-struct occurs (terminal count))
(define (consolidate-count cts)
(cond
[(null? cts) cts]
[(eq? 'counting (car cts)) (consolidate-count cts)]
[(pair? (car cts)) (consolidate-count (append (car cts) (cdr cts)))]
[else
(let-values ([(front back) (augment-count (car cts) (cdr cts))])
(cons front (consolidate-count back)))]))
(define (augment-count count rst)
(cond
[(null? rst) (values count rst)]
[(eq? 'counting (car rst)) (augment-count count (cdr rst))]
[(pair? (car rst)) (augment-count count (append (car rst) (cdr rst)))]
[else
(let-values ([(current back) (augment-count count (cdr rst))])
(cond
[(equal? (occurs-terminal count) (occurs-terminal (car rst)))
(values (make-occurs (occurs-terminal count) (+ (occurs-count count)
(occurs-count current)
(occurs-count (car rst))))
back)]
[else (values current (cons (car rst) back))]))]))
;parse-build = answer | none ;parse-build = answer | none
;(make-answer 'b) ;(make-answer 'b)