fork download
  1. ; mind-boggling card trick
  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 seed (current-time))
  16.  
  17. (define random
  18. (let* ((a 69069) (c 1234567) (m 4294967296))
  19. (lambda () (set! seed (modulo (+ (* a seed) c) m)) (/ seed m))))
  20.  
  21. (define (randint n) (floor (* n (random))))
  22.  
  23. (define (shuffle x)
  24. (do ((v (list->vector x)) (n (length x) (- n 1)))
  25. ((zero? n) (vector->list v))
  26. (let* ((r (randint n)) (t (vector-ref v r)))
  27. (vector-set! v r (vector-ref v (- n 1)))
  28. (vector-set! v (- n 1) t))))
  29.  
  30. (define (trick)
  31. (let ((pack (shuffle (append (make-list 26 'B) (make-list 26 'R)))))
  32. (display "Pack: ") (display pack) (newline)
  33. (let loop ((pack pack) (blacks (list)) (reds (list)) (discards (list)))
  34. (if (pair? pack)
  35. (if (eq? (car pack) 'B)
  36. (loop (cddr pack) (cons (cadr pack) blacks) reds (cons (car pack) discards))
  37. (loop (cddr pack) blacks (cons (cadr pack) reds) (cons (car pack) discards)))
  38. (begin
  39. (display "Blacks: ") (display blacks) (newline)
  40. (display "Reds: ") (display reds) (newline)
  41. (display "Discards: ") (display discards) (newline)
  42. (let ((swap (randint (min (length blacks) (length reds)))))
  43. (display "Swap size is ") (display swap) (newline)
  44. (let* ((blacks (shuffle blacks)) (reds (shuffle reds))
  45. (bs (append (take swap reds) (drop swap blacks)))
  46. (rs (append (take swap blacks) (drop swap reds))))
  47. (display "Blacks: ") (display bs) (newline)
  48. (display "Reds: ") (display rs) (newline)
  49. (let ((black-count (length (filter (lambda (x) (eq? x 'B)) bs)))
  50. (red-count (length (filter (lambda (x) (eq? x 'R)) rs))))
  51. (display "Black count is ") (display black-count) (display "; ")
  52. (display "red count is ") (display red-count) (display ".") (newline)
  53. (if (= black-count red-count)
  54. (display "Black count equals red count.")
  55. (display "Black count does not equal red count."))))))))))
  56.  
  57. (trick)
Success #stdin #stdout 0.03s 50632KB
stdin
Standard input is empty
stdout
Pack: (R B R R R R R R B R B R R R B B B B B B B B B B R B R R B B R B R B R R R R R B B R B B R R B B R B R B)
Blacks: (B B R B B B B B B R R)
Reds: (B B R B R R B B R B R R R R B)
Discards: (R R B R B B R R R R R B R R B B B B B R B B R R R R)
Swap size is 0
Blacks: (B B R B B B B B R R B)
Reds: (B B B B R R R B R R R B R R B)
Black count is 8; red count is 8.
Black count equals red count.