master.ss

#lang scheme

;;; Helpers

;;; Utility to sum a list
(define (sum l) (foldl + 0 l))

;;; given a hash and a boolean binary function returns the pair which
;;; value is the most 'fun
(define (most-hash h fun)
  (let ((most-key null) (most-value null))
    (hash-for-each h (lambda (k v) 
		       (when (or (null? most-value) 
                                 (fun v most-value))
			 (begin 
			   (set! most-key k)
			   (set! most-value v)))))
    (cons most-key most-value)))

(define max 6)

;;; Master

;;; generates a random solution
(define (solution num max)
  (define (sol num max l)
    (cond ((zero? num) l)
          (else (sol (- num 1) max (cons (random max) l)))))
  (sol num max '()))

(define sol (solution 4 6))


;;; returns how many blacks
(define (blacks l1 l2)			
  (define (my-blacks l1 l2 res)
    (cond ((null? l1) res)
          ((= (car l1) (car l2)) (my-blacks (cdr l1)
                                            (cdr l2)
                                            (+ res 1)))
          (else (my-blacks (cdr l1) (cdr l2) res))))
  (my-blacks l1 l2 0))

;; counts how many whites should go,
;; without looking @ positions, so
;; counting blacks as whites too
(define (whites l1 l2)
  (define (minim x l1 l2)
    (min (length (filter (lambda (y) (= y x)) l1))
         (length (filter (lambda (y) (= y x)) l2))))
  (define (my-whites l1 l2 res)
    (sum (map (lambda (x) (minim x l1 l2)) 
              (build-list max values))))
  (my-whites l1 l2 0))


;;; given 2 lists returns an string with the pegs relating one to
;;; other
(define (check-sols my-sol l2)
  (let* ((black (blacks my-sol l2))
	 (white (- (whites my-sol l2) black)))
    (string-append
     (make-string black #\B)
     (make-string white #\W)
     (make-string (- (length l2) black white) #\. ))))

(define (check-real l)
  (check-sols l sol))

;;; Solver

(define sol-table (make-hash))
(define (inc-or-add h str) 
  (hash-update! h str (lambda (x) (+ x 1)) 0))

(inc-or-add sol-table (check-sols '(1 2) '(1 3)) )

(define (solve max len)
  
  (define (prune l wanted choice)
    (filter (lambda (x) (equal? (check-sols x choice) wanted)) l))

  (define (solve-rec possible-sols remaining)
    (cond 
     ((= 0 (length remaining)) (print "hola"))
     ((> 2 (length remaining)) (print (car remaining)))
     (else  
      (print (length remaining))
      (let ((choice (guess possible-sols remaining)))
	(solve-rec possible-sols
		   (prune remaining
			  (check-sols sol choice) choice)))))) 
  (let ((possible-sols (generate-possible-sols
                        (build-list max
                                    values) len)))
    (solve-rec possible-sols possible-sols)))

(define (generate-possible-sols lst len)
  (cond ((= 0 len) '(()))
	(else (append-map (lambda (x)
			    (map (lambda (y) (cons y x )) lst))
			  (generate-possible-sols lst (- len 1))))))

;;; makes a guess with a list of remaining possible solutions and a
;;; list of all solutions.  Uses a half assed minimax
(define (guess list remaining)
  (let ((a (make-hash)))
    (map (lambda (x) 
	   (let ((h (make-hash)))
	     (map (lambda (y) (inc-or-add h (check-sols x y)))
		  remaining)
	     (hash-set! a x (cdr (most-hash h >)))))
	 list)
    (print (most-hash a <))
					;    (print (hash-ref a '(1 1 2 2)))
    (car (most-hash a <))))