[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Mar 7:
(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 (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 (string-downcase str)
  (list->string
    (map char-downcase
      (string->list str))))

(define (add-word word)
  (define (adjoin key value)
    (words 'insert key (cons value (words 'lookup key))))
  (let ((len (string-length word)))
    (do ((i 0 (+ i 1))) ((= i len))
      (let ((star-word
             (string-append
               (substring word 0 i)
               (string #\*)
               (substring word (+ i 1) len))))
        (adjoin word star-word)
        (adjoin star-word word)))))

(define (build-words word-file)
  (with-input-from-file word-file
    (lambda ()
      (do ((word (read-line) (read-line)))
          ((eof-object? word))
        (add-word (string-downcase word))))))

; (define words (make-hash string-hash string=? '() 999983))
(define words (make-hash string-hash string=? '() 17))

; (build-words "/usr/dict/words")
(add-word "cat") (add-word "cot") (add-word "dog") (add-word "dot")

(define (adjacent-to word)
  (define (remove ws)
    (cond ((null? ws) ws)
          ((string=? (car ws) word) (cdr ws))
          (else (cons (car ws) (remove (cdr ws))))))
  (apply append
    (map (lambda (w)
           (remove (words 'lookup w)))
         (words 'lookup word))))

(define (ladder source target)
  (let loop1 ((front (list (list source)))
              (back '()) (visited (list source)))
    (for-each display `("loop1 " ,front " " ,back " " ,visited #\newline))
    (cond ((null? front)
            (if (null? back) '()
              (loop1 (reverse back) '() visited)))
          ((string=? (caar front) target)
            (reverse (car front)))
          (else (let loop2 ((words (adjacent-to (caar front)))
                            (back back) (visited visited))
                  (cond ((null? words)
                          (loop1 (cdr front) back visited))
                        ((member (car words) visited)
                          (loop2 (cdr words) back visited))
                        (else (loop2 (cdr words)
                                     (cons (cons (car words) (car front)) back)
                                     (cons (car words) visited)))))))))

(for-each (lambda (w) (display "words ") (display w) (newline)) (words 'enlist))

(display (ladder "cat" "dog"))


Output:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
words (*at cat)
words (c*t cot cat)
words (do* dot dog)
words (ca* cat)
words (*og dog)
words (cot co* c*t *ot)
words (d*g dog)
words (*ot dot cot)
words (dog do* d*g *og)
words (d*t dot)
words (co* cot)
words (dot do* d*t *ot)
words (cat ca* c*t *at)
loop1 ((cat)) () (cat)
loop1 () ((cot cat)) (cot cat)
loop1 ((cot cat)) () (cot cat)
loop1 () ((dot cot cat)) (dot cot cat)
loop1 ((dot cot cat)) () (dot cot cat)
loop1 () ((dog dot cot cat)) (dog dot cot cat)
loop1 ((dog dot cot cat)) () (dog dot cot cat)
(cat cot dot dog)


Create a new paste based on this one


Comments: