Programming Praxis

We reuse many of the functions from the prior exercise: esc, cls, goto, erase-eol, display-gibbet, display-man, display-word, display-alphabet, display-answer, display-message, read-words, get-key, and get-letter. And much of the game logic is the same; here’s the top-level hangman function:

(define (hangman)
  (rand (time-second (current-time)))
  (let ((words (read-words "/usr/share/dict/words")))
    (let play ((answers (keep-len (randint 4 13) words)))
      (display-gibbet)
      (let loop ((man 0) (word (make-list (length (car answers)) #\_))
                 (answers answers)
                 (alphabet (string->list "abcdefghijklmnopqrstuvwxyz")))
        (display-man man) (display-word word) (display-alphabet alphabet)
        (cond ((not (member #\_ word))
                (when (display-message #t (car answers))
                  (play (keep-len (randint 4 13) words))))
              ((= 6 man)
                (when (display-message #f (fortune answers))
                   (play (keep-len (randint 4 13) words))))
              (else (let ((c (get-letter alphabet)))
                      (call-with-values
                        (lambda () (cheat word answers c))
                        (lambda (ok? word answers)
                          (loop (if ok? man (+ man 1))
                                word answers
                                (remove c alphabet)))))))))))

In the previous exercise, play chose an answer word with (fortune words). In this exercise, answers is a list of possible words and is chosen with (keep-len (randint 4 13) words). The rest of the change is at the end, where the function-call (cheat word words c) takes the current status of the player’s guessed word, the remaining list of possible words, and the player’s current input character and returns three values: ok?, which is #t if the player’s guess is accepted into the current word and #f otherwise, the new status of the word, and the remaining list of possible answers. Here is cheat:

(define (cheat word words c)
  (let ((xs (car (sort (lambda (x y) (> (length x) (length y)))
              (group (sort (lambda (x y) (lt? (car x) (car y)))
                (map (lambda (w) (cons (places c w) (list w)))
                  words)))))))
    (values (pair? (car xs))
            (let loop ((word word) (ks (car xs)) (k 0) (zs (list)))
              (cond ((null? word) (reverse zs))
                    ((and (pair? ks) (= k (car ks)))
                      (loop (cdr word) (cdr ks) (+ k 1) (cons c zs)))
                    (else (loop (cdr word) ks (+ k 1)
                                (cons (car word) zs)))))
            (cdr xs))))

The values clause accumulates the response; the cheating occurs in the binding of xs. The map calls a function places that turns each word in the current answer-list into a two-element list of lists that has a list of the places where the player’s input letter occurs followed by the list of letters in the word; for instance, with the word “hello” and input character “l”, places returns the list ((2 3) (#\h #\e #\l \#l #\o)). Then sort brings together words with like place-lists, group groups them, the groups are sorted by descending length, and car picks the longest, which gives the cheating referee the most possibilities for cheating at the next letter. Here are the three helping functions places, lt?, and group:

(define (places c word) ; places where c appears in word
  (let loop ((word word) (p 0) (ps (list)))
    (cond ((null? word) (reverse ps))
          ((char=? (car word) c)
            (loop (cdr word) (+ p 1) (cons p ps)))
          (else (loop (cdr word) (+ p 1) ps)))))

(define (lt? xs ys) ; compare two lists
  (cond ((and (null? xs) (null? ys)) #f)
        ((null? xs) #t) ((null? ys) #f)
        ((= (car xs) (car ys))
          (lt? (cdr xs) (cdr ys)))
        (else (< (car xs) (car ys)))))

(define (group xs)
  (let loop ((xs (cdr xs)) (k (caar xs))
             (v (list (cadar xs))) (zs (list)))
    (cond ((null? xs) (reverse (cons (cons k v) zs)))
          ((equal? (caar xs) k)
            (loop (cdr xs) k (cons (cadar xs) v) zs))
          (else (loop (cdr xs) (caar xs) (list (cadar xs))
                  (cons (cons k v) zs))))))

All that’s left is keep-len, which is used in the initialization of the list of answers:

(define (keep-len n words)
  (filter (lambda (w) (= (length w) n)) words))

The complete code is assembled at http://programmingpraxis.codepad.org/i2SJ4FcT, including filter, all?, read-line, rand, randint, and fortune from the Standard Prelude.

Pages: 1 2