[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/tHXIIIfF    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Nov 2:
; mastermind solver

(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 (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(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 sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(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 (max-score pool probe)
  (apply max (map cdr
    (uniq-c string=? (sort string<?
      (map (lambda (p) (score p probe)) pool))))))

(define (minimax pool)
  (let loop ((min-probe '()) (min-size #e1e10) (ps probes))
    (if (null? ps) min-probe
      (let ((size (max-score pool (car ps))))
        (if (or (< size min-size)
                (and (= size min-size)
                     (member (car ps) pool)
                     (not (member min-probe pool))))
            (loop (car ps) size (cdr ps))
            (loop min-probe min-size (cdr ps)))))))

(define (apply-probe pool probe result)
  (filter (lambda (p) (string=? (score p probe) result)) pool))

(define (solver . args)
  (let ((code (if (pair? args) (car args) (fortune probes))))
    (let loop ((n 1) (pool probes))
      (let* ((probe (minimax pool))
             (result (score code probe)))
        (display probe) (display " ")
        (display result) (newline)
        (if (string=? (make-string num-pegs #\B) result) n
          (loop (+ n 1) (apply-probe pool probe result)))))))


Output:
No errors or program output.


Create a new paste based on this one


Comments: