[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Sep 19:
; green eyes

(define (sum xs) (apply + xs))

(define-syntax for
  (syntax-rules ()
    ((for (var first past step) body ...)
      (let ((ge? (if (< first past) >= <=)))
        (do ((var first (+ var step)))
            ((ge? var past))
          body ...)))
    ((for (var first past) body ...)
      (let* ((f first) (p past) (s (if (< first past) 1 -1)))
        (for (var f p s) body ...)))
    ((for (var past) body ...)
      (let* ((p past)) (for (var 0 p) body ...)))))

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define rand
  (let* ((a 3141592653) (c 2718281829)
         (m (expt 2 35)) (x 5772156649)
         (next (lambda ()
                 (let ((x-prime (modulo (+ (* a x) c) m)))
                   (set! x x-prime) x-prime)))
         (k 103)
         (v (list->vector (reverse
              (let loop ((i k) (vs (list x)))
                (if (= i 1) vs
                  (loop (- i 1) (cons (next) vs)))))))
         (y (next))
         (init (lambda (s)
                 (set! x s) (vector-set! v 0 x)
                 (do ((i 1 (+ i 1))) ((= i k))
                   (vector-set! v i (next))))))
    (lambda seed
      (cond ((null? seed)
              (let* ((j (quotient (* k y) m))
                     (q (vector-ref v j)))
                (set! y q)
                (vector-set! v j (next)) (/ y m)))
            ((eq? (car seed) 'get) (list a c m x y k v))
            ((eq? (car seed) 'set)
              (let ((state (cadr seed)))
                (set! a (list-ref state 0))
                (set! c (list-ref state 1))
                (set! m (list-ref state 2))
                (set! x (list-ref state 3))
                (set! y (list-ref state 4))
                (set! k (list-ref state 5))
                (set! v (list-ref state 6))))
            (else (init (modulo (numerator
                    (inexact->exact (car seed))) m))
                  (rand))))))

(define (choose n r)
  (let loop ((n n) (r r) (c 1))
    (if (zero? r) c
      (loop (- n 1) (- r 1) (* c n (/ r))))))

(display (* (/ (choose 24 2) (choose 27 3)) 3))
(newline)

(define eyes (make-vector 27 'blue))
(for (i 0 3) (vector-set! eyes i 'green))
(for (i 3 16) (vector-set! eyes i 'brown))

(define (green x)
  (if (eq? (vector-ref eyes x) 'green) 1 0))

(display
  (length
    (list-of (list a b c)
      (a range 0 27)
      (b range (+ a 1) 27)
      (c range (+ b 1) 27)
      (= (+ (green a) (green b) (green c)) 1))))
(newline)

(define (sample n m)
  (let loop ((s m) (r n) (x 0) (xs '()))
    (cond ((= x n) xs)
          ((< (rand) (/ s r))
            (loop (- s 1) (- r 1) (+ x 1) (cons x xs)))
          (else (loop s (- r 1) (+ x 1) xs)))))

(define (sim n)
  (define (s?)
    (= (sum (map green (sample 27 3))) 1))
  (let loop ((n n) (g 0))
    (if (zero? n) g
      (loop (- n 1) (+ g (if (s?) 1 0))))))

(display (sim 2925))
(newline)


Output:
1
2
3
92/325
828
827


Create a new paste based on this one


Comments: