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

;  0----+----1----+----2----+----3
;  |
;  2    +----+
;  |    |    |
;  4    |    O         YOU xxx!!!
;  |    |   \|/
;  6    |   / \
;  |    |
;  8    +-------
;  |
; 10    _ _ _ _ _ _ _ _ _ _ _ _ _
;  |
; 12    abcdefghijklmnopqrstuvwxyz
;  |    Play again (y/n)? X

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

(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 (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 (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 (insert answer c word)
  (let loop ((word word) (answer answer) (new (list)))
    (if (null? word) (reverse new)
      (loop (cdr word) (cdr answer)
            (cons (if (char=? c (car answer))
                      (char-upcase c) (car word)) new)))))

(define (hangman)
  (rand (time-second (current-time)))
  (let ((words (read-words "/usr/share/dict/words")))
    (let play ((answer (fortune words)))
      (display-gibbet)
      (let loop ((man 0) (word (make-list (length answer) #\_))
                 (alphabet (string->list "abcdefghijklmnopqrstuvwxyz")))
        (display-man man) (display-word word) (display-alphabet alphabet)
        (cond ((not (member #\_ word))
                (when (display-message #t answer) (play (fortune words))))
              ((= 6 man)
                (when (display-message #f answer) (play (fortune words))))
              (else (let ((c (get-letter alphabet)))
                      (if (member c answer)
                          (loop man (insert answer c word) (remove c alphabet))
                          (loop (+ man 1) word (remove c alphabet))))))))))