[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Dec 21:
; cheating hangman

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (all? pred? xs)
  (cond ((null? xs) #t)
        ((pred? (car xs))
          (all? pred? (cdr xs)))
        (else #f)))

(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 rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define (fortune xs)
  (let loop ((n 1) (x #f) (xs xs))
    (cond ((null? xs) x)
          ((< (rand) (/ n))
            (loop (+ n 1) (car xs) (cdr xs)))
          (else (loop (+ n 1) x (cdr xs))))))

(define esc (integer->char 27))
(define (cls) (for-each display `(,esc #\[ #\2 #\J)))
(define (goto r c) (for-each display `(,esc #\[ ,r #\; ,c #\H)))
(define (erase-eol) (for-each display `(,esc #\[ #\K)))

(define (display-gibbet)
  (cls)
  (goto 2 5) (display "+----+")
  (goto 3 5) (display "|    |")
  (goto 4 5) (display "|")
  (goto 5 5) (display "|")
  (goto 6 5) (display "|")
  (goto 7 5) (display "|")
  (goto 8 5) (display "+-------"))

(define (display-man n)
  (case n
  ;(0) do nothing
  ((1) (goto 4 10) (display "O"))
  ((2) (goto 5 10) (display "|"))
  ((3) (goto 5 9) (display "\\|"))
  ((4) (goto 5 11) (display "/"))
  ((5) (goto 6 9) (display "/"))
  ((6) (goto 6 11) (display "\\"))))

(define (display-word word)
  (goto 10 4) (erase-eol)
  (for-each (lambda (c) (display #\space) (display c)) word))

(define (display-alphabet alphabet)
  (goto 12 5) (erase-eol)
  (for-each display alphabet))

(define (display-answer answer)
  (goto 5 19) (erase-eol)
  (for-each (lambda (c) (display (char-upcase c))) answer))

(define (display-message win? answer)
  (goto 4 19)
  (if win? (display "YOU WIN!!!")
    (begin (display "YOU DIE!!!")
           (display-answer answer)))
  (goto 13 5) (display "Play again (y/n)? ")
  (let loop ((c (get-key)))
    (cond ((char=? c #\y) #t)
          ((char=? c #\n) #f)
          (else (goto 13 24) (erase-eol)
                (loop (get-key))))))

(define (read-words filename)
  (with-input-from-file filename (lambda ()
    (let loop ((word (read-line)) (words (list)))
      (if (eof-object? word) (reverse words)
        (let ((word (map char-downcase (string->list word))))
          (if (all? char-alphabetic? word)
              (loop (read-line) (cons word words))
              (loop (read-line) words))))))))

(define (get-key) (char-downcase (read-char)))

(define (get-letter alphabet)
  (goto 4 19) (erase-eol)
  (let loop ((c (get-key)))
    (cond ((member c alphabet) c)
          (else (goto 4 19) (erase-eol) (loop (get-key))))))

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

(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))))))

(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))))

(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)))))))))))


Create a new paste based on this one


Comments: