fork(1) download
copy 
  1. ; bridge hands
  2.  
  3. (define (take n xs)
  4.   (let loop ((n n) (xs xs) (ys '()))
  5.     (if (or (zero? n) (null? xs))
  6.         (reverse ys)
  7.         (loop (- n 1) (cdr xs)
  8.               (cons (car xs) ys)))))
  9.  
  10. (define (drop n xs)
  11.   (let loop ((n n) (xs xs))
  12.     (if (or (zero? n) (null? xs)) xs
  13.       (loop (- n 1) (cdr xs)))))
  14.  
  15. (define (range . args)
  16.   (case (length args)
  17.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  18.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  19.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  20.            (let loop ((x(car args)) (xs '()))
  21.              (if (le? (cadr args) x)
  22.                  (reverse xs)
  23.                  (loop (+ x (caddr args)) (cons x xs))))))
  24.     (else (error 'range "unrecognized arguments"))))
  25.  
  26. (define (string-join sep ss)
  27.   (define (f s ss)
  28.     (string-append s (string sep) ss))
  29.   (define (join ss)
  30.     (if (null? (cdr ss)) (car ss)
  31.       (f (car ss) (join (cdr ss)))))
  32.   (if (null? ss) "" (join ss)))
  33.  
  34. (define rand #f)
  35. (define randint #f)
  36. (let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  37.   (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  38.   ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  39.   (define (flip-cycle)
  40.     (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
  41.       (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
  42.     (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
  43.       (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
  44.     (set! fptr 54) (vector-ref a 55))
  45.   (define (init-rand seed)
  46.     (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
  47.       (vector-set! a 55 prev)
  48.       (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
  49.         (vector-set! a i next) (set! next (mod-diff prev next))
  50.         (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
  51.         (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
  52.       (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  53.   (define (next-rand)
  54.     (if (negative? (vector-ref a fptr)) (flip-cycle)
  55.       (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  56.   (define (unif-rand m)
  57.     (let ((t (- two31 (modulo two31 m))))
  58.       (let loop ((r (next-rand)))
  59.         (if (<= t r) (loop (next-rand)) (modulo r m)))))
  60.   (init-rand 19380110) ; happy birthday donald e knuth
  61.   (set! rand (lambda seed
  62.     (cond ((null? seed) (/ (next-rand) two31))
  63.           ((eq? (car seed) 'get) (cons fptr (vector->list a)))
  64.           ((eq? (car seed) 'set) (set! fptr (caadr seed))
  65.                                  (set! a (list->vector (cdadr seed))))
  66.           (else (/ (init-rand (modulo (numerator
  67.                   (inexact->exact (car seed))) two31)) two31)))))
  68.   (set! randint (lambda args
  69.     (cond ((null? (cdr args))
  70.             (if (< (car args) two31) (unif-rand (car args))
  71.               (floor (* (next-rand) (car args)))))
  72.           ((< (car args) (cadr args))
  73.             (let ((span (- (cadr args) (car args))))
  74.               (+ (car args)
  75.                  (if (< span two31) (unif-rand span)
  76.                    (floor (* (next-rand) span))))))
  77.           (else (let ((span (- (car args) (cadr args))))
  78.                   (- (car args)
  79.                      (if (< span two31) (unif-rand span)
  80.                        (floor (* (next-rand) span))))))))))
  81.  
  82. (define (shuffle x)
  83.   (do ((v (list->vector x)) (n (length x) (- n 1)))
  84.       ((zero? n) (vector->list v))
  85.     (let* ((r (randint n)) (t (vector-ref v r)))
  86.       (vector-set! v r (vector-ref v (- n 1)))
  87.       (vector-set! v (- n 1) t))))
  88.  
  89. (define (hands)
  90.   (let loop ((deck (shuffle (range 52)))
  91.              (hands (list)))
  92.     (if (null? deck) hands
  93.       (loop (drop 13 deck)
  94.             (cons (sort (take 13 deck) >) hands)))))
  95.  
  96. (define (print-hands hands)
  97.   (define (blanks n) (display (make-string n #\space)))
  98.  
  99.   (blanks 20) (display "NORTH") (newline)
  100.   (blanks 20) (display (cards "S" (car hands))) (newline)
  101.   (blanks 20) (display (cards "H" (car hands))) (newline)
  102.   (blanks 20) (display (cards "D" (car hands))) (newline)
  103.   (blanks 20) (display (cards "C" (car hands))) (newline)
  104.  
  105.   (set! hands (cdr hands))
  106.  
  107.   (display "WEST") (blanks 36) (display "EAST") (newline)
  108.   (display (cards "S" (car hands)))
  109.     (blanks (- 40 (string-length (cards "S" (car hands)))))
  110.     (display (cards "S" (cadr hands))) (newline)
  111.   (display (cards "H" (car hands)))
  112.     (blanks (- 40 (string-length (cards "H" (car hands)))))
  113.     (display (cards "H" (cadr hands))) (newline)
  114.   (display (cards "D" (car hands)))
  115.     (blanks (- 40 (string-length (cards "D" (car hands)))))
  116.     (display (cards "D" (cadr hands))) (newline)
  117.   (display (cards "C" (car hands)))
  118.     (blanks (- 40 (string-length (cards "C" (car hands)))))
  119.     (display (cards "C" (cadr hands))) (newline)
  120.  
  121.   (set! hands (cddr hands))
  122.  
  123.   (blanks 20) (display "SOUTH") (newline)
  124.   (blanks 20) (display (cards "S" (car hands))) (newline)
  125.   (blanks 20) (display (cards "H" (car hands))) (newline)
  126.   (blanks 20) (display (cards "D" (car hands))) (newline)
  127.   (blanks 20) (display (cards "C" (car hands))) (newline))
  128.  
  129. (define (cards suit hand)
  130.   (define (between lo hi) (lambda (x) (<= lo x hi)))
  131.   (cond ((string=? suit "S")
  132.           (string-join #\space (cons "S:"
  133.             (map face (filter (between 39 51) hand)))))
  134.         ((string=? suit "H")
  135.           (string-join #\space (cons "H:"
  136.             (map face (filter (between 26 38) hand)))))
  137.         ((string=? suit "D")
  138.           (string-join #\space (cons "D:"
  139.             (map face (filter (between 13 25) hand)))))
  140.         ((string=? suit "C")
  141.           (string-join #\space (cons "C:"
  142.             (map face (filter (between  0 12) hand)))))))
  143.  
  144. (define (face card)
  145.   (case (modulo card 13)
  146.     ((12) "A")
  147.     ((11) "K")
  148.     ((10) "Q")
  149.     ((9)  "J")
  150.     (else (number->string (+ (modulo card 13) 2)))))
  151.  
  152. (print-hands (hands))
Success #stdin #stdout 0.12s 8952KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
                    NORTH
                    S: K 9 5
                    H: 9 6 3
                    D: Q 8 7 5 3 2
                    C: 6
WEST                                    EAST
S: Q 6 3 2                              S: A J 8 7
H: K J 5 2                              H: A Q
D: A 10                                 D: J 9
C: J 5 2                                C: K Q 9 8 3
                    SOUTH
                    S: 10 4
                    H: 10 8 7 4
                    D: K 6 4
                    C: A 10 7 4
https://ideone.com/IcpYvT
language:
Scheme (guile 2.2.4)
created:
8 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!