fork download
copy 
  1. ; lost boarding pass
  2.  
  3. (define range
  4.   (case-lambda
  5.     ((stop) (range 0 stop (if (negative? stop) -1 1)))
  6.     ((start stop) (range start stop (if (< start stop) 1 -1)))
  7.     ((start stop step)
  8.       (let ((le? (if (negative? step) >= <=)))
  9.         (let loop ((x start) (xs (list)))
  10.           (if (le? stop x) (reverse xs)
  11.             (loop (+ x step) (cons x xs))))))
  12.     (else (error 'range "too many arguments"))))
  13.  
  14. (define rand ; knuth random number generator with shuffle box
  15.   (let* ((a 69069) (c 1234567) (m 4294967296) (k 32)
  16.          (seed 19380110) ; Happy Birthday DEK!
  17.          (next (lambda ()
  18.            (set! seed (modulo (+ (* a seed) c) m)) seed))
  19.          (init (lambda (seed) (let ((box (make-vector k)))
  20.            (do ((j 0 (+ j 1))) ((= j k) box)
  21.              (vector-set! box j (next))))))
  22.          (box (init seed)))
  23.     (lambda args
  24.       (when (pair? args)
  25.         (set! seed (modulo (car args) m)) (set! box (init seed)))
  26.       (let* ((j (quotient (* k seed) m)) (n (vector-ref box j)))
  27.         (set! seed (next)) (vector-set! box j seed) (/ n m)))))
  28.  
  29. (define (fortune xs)
  30.   (let loop ((n 1) (x #f) (xs xs))
  31.     (cond ((null? xs) x)
  32.           ((< (rand) (/ n))
  33.             (loop (+ n 1) (car xs) (cdr xs)))
  34.           (else (loop (+ n 1) x (cdr xs))))))
  35.  
  36. (define (board n)
  37.   (let loop ((pax 0) (free (range n)) (seated (list)))
  38.     (cond ((= pax n) seated) ; return in reverse order
  39.           ((or (= pax 0) (not (member pax free)))
  40.             (let ((seat (fortune free)))
  41.               (loop (+ pax 1) (remove seat free) (cons seat seated))))
  42.           (else (loop (+ pax 1) (remove pax free) (cons pax seated))))))
  43.  
  44. (define (sim n)
  45.   (let loop ((n n) (own-seat 0))
  46.     (if (zero? n) own-seat
  47.       (if (= (car (board 100)) 99)
  48.           (loop (- n 1) (+ own-seat 1))
  49.           (loop (- n 1) own-seat)))))
  50.  
  51. (display (board 10)) (newline)
  52. (display (board 10)) (newline)
  53. (display (board 10)) (newline)
  54. (display (board 10)) (newline)
  55. (display (sim  100)) (newline)
Runtime error #stdin #stdout #stderr 0.01s 7860KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
stderr
copy 
Error: call of non-procedure: 9

	Call history:

	<eval>	  (vector-ref box j)
	<eval>	  (next)
	<eval>	  [next] (modulo (+ (* a seed) c) m)
	<eval>	  [next] (+ (* a seed) c)
	<eval>	  [next] (* a seed)
	<eval>	  (vector-set! box j seed)
	<eval>	  (/ n m)
	<eval>	  [fortune] (/ n)
	<eval>	  [fortune] (loop (+ n 1) (car xs) (cdr xs))
	<eval>	  [fortune] (+ n 1)
	<eval>	  [fortune] (car xs)
	<eval>	  [fortune] (cdr xs)
	<eval>	  [fortune] (null? xs)
	<eval>	  [board] (loop (+ pax 1) (remove seat free) (cons seat seated))
	<eval>	  [board] (+ pax 1)
	<eval>	  [board] (remove seat free)	<--
https://ideone.com/uJGGx3
language:
Scheme (chicken 4.13)
created:
4 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!