December 2021: simulate Galton boards and compute scores

202112/galton.scm

@@ -0,0 +1,61 @@
+(import srfi-1 srfi-13)
+
+(define (permute sigma k)
+  (list-ref sigma k))
+
+(define (score sigma dist)
+  (define n (length dist))
+  (define m (apply + dist))
+  (let lp ((acc 0.0) (k 0))
+    (if (= n k)
+	acc
+	(let ((a (list-ref dist (permute sigma k))))
+	  (lp (+ acc (expt (/ (* n a) m) (add1 k))) (add1 k))))))
+
+(define (string->symbol-list s)
+  (map string->symbol (map string (string->list s))))
+
+(define (string->pins s)
+  (let lp ((pins '())
+	   (k 1)
+	   (s s))
+    (if (string-null? s)
+	(reverse pins)
+	(lp (cons (string->symbol-list (string-take s k)) pins)
+	    (+ 1 k)
+	    (string-drop s k)))))
+
+(define (pin-ref pins stage pos)
+  (list-ref (list-ref pins stage) pos))
+
+(define (pin-set! pins stage pos v)
+  (set! (list-ref (list-ref pins stage) pos) v))
+
+(define (drop-ball! pins)
+  (let lp ((stage 0) (pos 0))
+    (if (= stage (length pins))
+	pos
+	(let ((pin (pin-ref pins stage pos)))
+	  (cond
+	   ((eq? pin 'L) (begin
+			   (pin-set! pins stage pos 'R)
+			   (lp (+ 1 stage) pos)))
+	   ((eq? pin 'R) (begin
+			   (pin-set! pins stage pos 'L)
+			   (lp (+ 1 stage) (+ 1 pos))))
+	   ((eq? pin '<) (lp (+ 1 stage) pos))
+	   ((eq? pin '>) (lp (+ 1 stage) (+ 1 pos))))))))
+
+(define (drop-balls! pins n)
+  (define dist (make-list (+ 1 (length (last pins))) 0))
+  (let lp ((n n))
+    (if (= n 0)
+	dist
+	(let* ((pos (drop-ball! pins))
+	       (prev-count (list-ref dist pos)))
+	  (set! (list-ref dist pos) (+ 1 prev-count))
+	  (lp (- n 1))))))
+
+(let ((pins (string->pins "RRRRRLLRLR"))
+      (sigma '(0 1 4 3 2)))
+  (score sigma (drop-balls! pins 15)))