; mastermind setter
(define (range . args)
(case (length args)
((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
((3) (let ((le? (if (negative? (caddr args)) >= <=)))
(let loop ((x(car args)) (xs '()))
(if (le? (cadr args) x)
(reverse xs)
(loop (+ x (caddr args)) (cons x xs))))))
(else (error 'range "unrecognized arguments"))))
(define (fold-right op base xs)
(if (null? xs)
base
(op (car xs) (fold-right op base (cdr xs)))))
(define (make-list n x)
(let loop ((n n) (xs '()))
(if (zero? n) xs
(loop (- n 1) (cons x xs)))))
(define (sum xs) (apply + xs))
(define (uniq-c eql? xs)
(if (null? xs) xs
(let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
(cond ((null? xs) (reverse (cons (cons prev k) result)))
((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
(else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))
(define (cross . xss)
(define (f xs yss)
(define (g x zss)
(define (h ys uss)
(cons (cons x ys) uss))
(fold-right h zss yss))
(fold-right g '() xs))
(fold-right f (list '()) xss))
(define num-colors 6)
(define num-pegs 4)
(define probes
(apply cross (make-list num-pegs (range 1 (+ num-colors 1)))))
(define (black code probe)
(define (f x y) (if (= x y) 1 0))
(sum (map f code probe)))
(define (b+w code probe)
(define (count x xs)
(define (f y) (if (= x y) 1 0))
(sum (map f xs)))
(define (f x)
(min (count x code) (count x probe)))
(sum (map f (range 1 (+ num-colors 1)))))
(define (score code probe)
(let* ((black (black code probe))
(white (- (b+w code probe) black)))
(string-append
(make-string black #\B)
(make-string white #\W)
(make-string (- num-pegs black white) #\.))))
(define (fortune xs)
(let loop ((n 1) (x #f) (xs xs))
(cond ((null? xs) x)
((< (rand) (/ n))
(loop (+ n 1) (car xs) (cdr xs)))
(else (loop (+ n 1) x (cdr xs))))))
(define (setter . args)
(let ((code (if (pair? args) (car args) (fortune probes))))
(display "Enter your guess as a list: ")
(let loop ((probe (read)))
(let ((s (score code probe)))
(if (string=? (make-string num-pegs #\B) s)
(begin (display "You win!") (newline))
(begin (display s) (newline)
(display "Try again: ") (loop (read))))))))