[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Apr 8:
(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 (sort lt? xs)
  (define (merge x1 x2)
    (cond ((null? x1) x2)
          ((null? x2) x1)
          ((lt? (car x2) (car x1))
            (cons (car x2) (merge x1 (cdr x2))))
          (else (cons (car x1) (merge (cdr x1) x2)))))
  (define (merge-pairs xs k)
    (if (or (null? (cdr xs)) (odd? k)) xs
        (merge-pairs
          (cons (merge (car xs) (cadr xs)) (cddr xs))
          (quotient k 2))))
  (define (next-run run xs)
    (if (or (null? xs) (lt? (car xs) (car run)))
        (values (reverse run) xs)
        (next-run (cons (car xs) run) (cdr xs))))
  (define (sorting xs ys k)
    (if (null? xs)
        (car (merge-pairs ys 0))
        (call-with-values
          (lambda () (next-run (list (car xs)) (cdr xs)))
          (lambda (run tail)
            (sorting tail (merge-pairs (cons run ys) (+ k 1)) (+ k 1))))))
  (if (null? xs) xs (sorting xs '() 0)))

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (sign word) (list->string (sort char<? (string->list word))))

(define anagrams (make-hash string-hash string=? '() 99991))

(with-input-from-file "/usr/dict/words"
  (lambda ()
    (do ((word (read-line) (read-line))) ((eof-object? word))
      (let ((key (sign word)))
        (anagrams 'update key (lambda (k v) (cons word v)) (list word))))))

(define (anagram word) (anagrams 'lookup (sign word)))

(display (anagram "post")) (newline)

(define (by-class-size-desc a b)
  (let ((a-size (length (cddr a)))
        (b-size (length (cddr b))))
    (> a-size b-size)))

(display (cdar (sort by-class-size-desc (anagrams 'enlist)))) (newline)


Output:
1
with-input-from-file: cannot open input file: "/usr/dict/words" (No such file or directory; errno=2)


Create a new paste based on this one


Comments: