; petals around the rose

(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 (roll)
  (let loop ((n 5) (xs (list)))
    (if (zero? n) xs
      (loop (- n 1) (cons (randint 1 7) xs)))))

(define (score xs)
  (let loop ((xs xs) (s 0))
    (cond ((null? xs) s)
          ((odd? (car xs))
            (loop (cdr xs) (+ s (car xs) -1)))
          (else (loop (cdr xs) s)))))

(define (petals-around-the-rose)
  (display "Let's play 'Petals Around The Rose.'") (newline)
  (display "The name of the game is significant.") (newline)
  (display "At each turn I will roll five dice,") (newline)
  (display "then ask you for the score, which") (newline)
  (display "will always be zero or an even number.") (newline)
  (display "After you guess the score, I will tell") (newline)
  (display "you if you are right, or tell you the") (newline)
  (display "correct score if you are wrong. The game") (newline)
  (display "ends when you prove that you know the") (newline)
  (display "secret by guessing the score correctly") (newline)
  (display "six times in a row.") (newline)
  (let loop ((xs (roll)) (streak 0))
    (cond ((= streak 6) (newline)
            (display "Congratulations! You are now a member") (newline)
            (display "of the Fraternity of the Petals Around") (newline)
            (display "The Rose. You must pledge never to") (newline)
            (display "reveal the secret to anyone.") (newline))
    (else (newline) (display "The five dice are:")
          (for-each (lambda (x) (display " ") (display x)) xs)
          (display ".") (newline) (display "What is the score? ")
          (cond ((equal? (read) (score xs))
                  (display "Correct") (newline)
                  (loop (roll) (+ streak 1)))
          (else (display "The correct score is ")
                (display (score xs)) (display ".") (newline)
                (loop (roll) 0)))))))