[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Feb 19:
(define (range first past . step)
  (let* ((xs '()) (f first) (p past)
         (s (cond ((pair? step) (car step))
                  ((< f p) 1) (else -1)))
         (le? (if (< 0 s) <= >=)))
    (do ((x f (+ x s))) ((le? p x) (reverse xs))
      (set! xs (cons x xs)))))

(define (sum xs)
  (let loop ((xs xs) (s 0))
    (if (null? xs) s
        (loop (cdr xs) (+ s (car xs))))))

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

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

(define rand
  (let ((a 69069) (c 5)
        (m (expt 2 32))
        (seed 17070415))
    (lambda s
      (set! seed (modulo
        (if (pair? s)
            (numerator (inexact->exact (car s)))
            (+ (* a seed) c)) m))
      (/ seed m))))

(define (randint . args)
  (cond ((null? args) (* (rand) (expt 2 32)))
        ((null? (cdr args))
          (inexact->exact (floor (* (rand) (car args)))))
        ((< (car args) (cadr args))
          (+ (inexact->exact (floor
               (* (rand) (- (cadr args) (car args)))))
             (car args)))
        (else (+ (inexact->exact (ceiling
                   (* (rand) (- (cadr args) (car args)))))
                 (car args)))))

(define (shuffle x)
  (do ((v (list->vector x)) (n (length x) (- n 1)))
      ((zero? n) (vector->list v))
    (let* ((r (randint n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

(define (card)
  (list->vector (append
    (take 5 (shuffle (range  1 16)))
    (take 5 (shuffle (range 16 31)))
    (take 4 (shuffle (range 31 46)))
    (take 5 (shuffle (range 46 61)))
    (take 5 (shuffle (range 61 76))))))

(define (bingo? card)
  (define (test . xs)
    (zero? (sum (map (lambda (x) (vector-ref card x)) xs))))
  (or (test  0  1  2  3  4)   ; B-column
      (test  5  6  7  8  9)   ; I-column
      (test 10 11    12 13)   ; N-column
      (test 14 15 16 17 18)   ; G-column
      (test 19 20 21 22 23)   ; O-column
      (test  0  5 10 14 19)   ; top row
      (test  1  6 11 15 20)   ; second row
      (test  2  7    16 21)   ; middle row
      (test  3  8 12 17 22)   ; fourth row
      (test  4  9 13 18 23)   ; bottom row
      (test  0  6    17 23)   ; nw-to-se diagonal
      (test  4  8    15 19))) ; ne-to-sw diagonal

(define (play n)
  (let ((cards (map (lambda (x) (card)) (range 0 n))))
    (let loop ((k 0) (cage (shuffle (range 1 76))))
      (if (any? bingo? cards)
          (let loop ((i 0) (cards cards))
            (if (bingo? (car cards))
                (cons k i) ; number of calls, winner
                (loop (+ i 1) (cdr cards))))
          (let ((call (car cage)))
            (map (lambda (card)
                   (do ((i 0 (+ i 1))) ((= i 24))
                     (if (= (vector-ref card i) call)
                         (vector-set! card i 0))))
                 cards)
            (loop (+ k 1) (cdr cage)))))))

(display (sum (map (lambda (x) (car (play 1))) (range 0 1000))))


Output:
1
41895


Create a new paste based on this one


Comments: