[ create a new paste ] login | about

Link: http://codepad.org/BN3OknEY    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Oct 16:
; blackjack

(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 (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define (split-while pred? xs)
  (let loop ((xs xs) (ys '()))
    (if (or (null? xs) (not (pred? (car xs))))
        (values (reverse ys) xs)
        (loop (cdr xs) (cons (car xs) ys)))))

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(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 (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 (pips n)
  (let ((rank (+ (modulo n 13) 1)))
    (if (= rank 1) 11
      (min rank 10))))

(define (count cards)
  (call-with-values
    (lambda () (split-while (lambda (n) (< n 11)) (sort < cards)))
    (lambda (numbers aces)
      (let ((sum (+ (apply + numbers) (length aces))))
        (if (< 21 sum) sum
          (let loop ((sum sum) (n (length aces)))
            (if (or (zero? n) (< 21 (+ sum 10))) sum
              (loop (+ sum 10) (- n 1)))))))))

(define (play) ; 1 player, 0 tie, -1 dealer
  (let* ((deck (map pips (shuffle (range 52))))
         (pcards (take 2 deck)) (deck (drop 2 deck))
         (dcards (take 2 deck)) (deck (drop 2 deck)))
    ;(display "deal: ")
    ;(display pcards) (display " ")
    ;(display dcards) (display " ")
    ;(display deck) (display " ")
    ;(display (count pcards)) (display " ")
    ;(display (count dcards)) (newline)
    (if (= (count pcards) 21) (if (= (count dcards) 21) 0 1)
      (let player ((pcards pcards) (deck deck))
        ;(display "player: ")
        ;(display pcards) (display " ")
        ;(display deck) (display " ")
        ;(display (count pcards)) (newline)
        (if (< 21 (count pcards)) -1
          (if (< (count pcards) 17)
              (player (cons (car deck) pcards) (cdr deck))
              (let dealer ((dcards dcards) (deck deck))
                ;(display "dealer: ")
                ;(display dcards) (display " ")
                ;(display deck) (display " ")
                ;(display (count dcards)) (newline)
                (if (< 21 (count dcards)) 1
                  (if (< (count dcards) 17)
                      (dealer (cons (car deck) dcards) (cdr deck))
                      (if (< (count pcards) (count dcards)) -1
                      (if (< (count dcards) (count pcards)) 1 0)))))))))))

(define (simulate n)
  (let loop ((n n) (sum 0))
    (if (zero? n) sum
      (loop (- n 1) (+ sum (play))))))

(display (simulate 10000))


Output:
1
-1027


Create a new paste based on this one


Comments: