fork(1) 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
comments (?)
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.
https://ideone.com/QCHUms
language:
Scheme (guile 2.2.4)
created:
6 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!