; 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))))))))