[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/ciNSny8H    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Dec 22:
; a statisticle speling korrecter

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

(define (string-hash str)
  (let loop ((cs (string->list str)) (s 0))
    (if (null? cs) s
      (loop (cdr cs) (+ (* s 31)
        (char->integer (car cs)))))))

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define (string-downcase str)
  (list->string
    (map char-downcase
      (string->list str))))

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (read-word)
  (let loop ((in-word? #f) (c (read-char)) (word '()))
    (cond ((eof-object? c) (if in-word? (list->string (reverse word)) c))
          ((char-alphabetic? c) (loop #t (read-char) (cons (char-downcase c) word)))
          (in-word? (list->string (reverse word)))
          (else (loop #f (read-char) word)))))

(define nwords (make-hash string-hash string=? #f 24989))

(with-input-from-file "big.txt"
  (lambda ()
    (do ((word (read-word) (read-word))) ((eof-object? word))
      (nwords 'update (string-downcase word) (lambda (k v) (+ v 1)) 1))))

(define (set xs)
  (unique string=?
    (sort string<? xs)))

(define-syntax set-of
  (syntax-rules ()
    ((_ arg ...)
      (fold-of
        (lambda (d a) (if (memv a d) d (cons a d)))
        '() arg ...))))

(define alfa (string->list "abcdefghijklmnopqrstuvwxyz"))

(define (edits1 word)
  (let* ((word (string->list word))
         (s (list-of (list (take i word) (drop i word))
              (i range (add1 (length word))))))
    (set (map list->string (append
      (set-of (append (car xs) (cdadr xs))
        (xs in s) (pair? (cadr xs)))
      (set-of (append (car xs) (list (cadadr xs))
                       (list (caadr xs)) (drop 2 (cadr xs)))
        (xs in s) (pair? (cadr xs)) (pair? (cdadr xs)))
      (set-of (append (car xs) (list c) (cdadr xs))
        (xs in s) (pair? (cadr xs)) (c in alfa))
      (set-of (append (car xs) (list c) (cadr xs))
        (xs in s) (c in alfa)))))))

(define (known-edits2 word)
  (set (set-of e2
         (e1 in (edits1 word))
         (e2 in (edits1 e1))
         (nwords 'lookup e2))))

(define (known words)
  (filter (lambda (w) (nwords 'lookup w)) words))

(define (max-word words)
  (let loop ((count 0) (maxword "") (words words))
    (if (null? words) maxword
      (let ((c (nwords 'lookup (car words))))
        (if (< count c)
            (loop c (car words) (cdr words))
            (loop count maxword (cdr words)))))))

(define (correct word)
  (if (nwords 'lookup word) word
    (let ((w1 (known (edits1 word))))
      (if (pair? w1) (max-word w1)
        (let ((w2 (known-edits2 word)))
          (if (pair? w2) (max-word w2) word))))))


Create a new paste based on this one


Comments: