1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

-- Master: Mastermind Solver
-- Adam Blinkinsop <blinks@google.com>
import Data.Ord
import Data.List

-- Types for pegs and codes, mainly for display.
data Peg = Red | Green | Blue | White | Yellow | Orange
  deriving (Eq, Ord, Show)
data Code = Code [Peg] deriving Show
data Response = Respond (Int, Int) deriving Eq

-- Whites uses an intersection that must not remove duplicates.  The one that
-- comes with Haskell's Data.List library is documented to work the way I
-- wanted, but it breaks with the following input:
--    [2,2,3] `intersect` [1,5,2] => [2,2] for Data.List's intersect.
-- This is clearly incorrect by my semantics, because the lists only share
-- a single two.  The following implements my semantics.
intersect x y = intersect' (sort x) (sort y)
intersect' [] _ = []
intersect' _ [] = []
intersect' (x:xs) (y:ys)
  | (x == y) = x : (intersect' xs ys)
  | (x < y) = intersect' xs (y:ys)
  | (x > y) = intersect' ys (x:xs)

-- The scoring function, to partition the solution space by pivoting on the
-- responses to any one code.
diff (Code x) (Code y) = Respond (reds, whites)
        -- Reds gives the number of slots that match between two codes.
  where reds = length [t | t <- zip x y, fst t == snd t]
        -- Whites gives the number of remaining colors in wrong slots.
        whites = (length $ Main.intersect x y) - reds

-- The initial solution space.
code_space = [Code [a,b,c,d] | a <- ps, b <- ps, c <- ps, d <- ps]
  where ps = [Red, Green, Blue, White, Yellow, Orange]

-- Reduce the solution space to match the clues given.
space `when` [] = space
space `when` ((code, response):rest) =
  [c | c <- space, diff c code == response] `when` rest

-- Partition the solution space by responses to an arbitrary code.
space `pivot_on` code =
  [space `when` [(code, response)] | response <- all_responses]
  where all_responses = [Respond (r, w) | r <- [0..4], w <- [0..4]]

-- Choose the best guess from a solution space.
choose_from space =
  fst $ minimumBy (comparing snd)
  [(code, maximum $ map (length) (space `pivot_on` code)) | code <- space]

-- Talk to the user, solving for an arbitrary code.
solve_with clues = do
  putStrLn ("It looks like there are "
        ++ (show $ length code_space') ++ " possible codes left, "
        ++ "after " ++ (show $ length clues) ++ " clues.  Hmm.")
  putStrLn ("I'll guess " ++ (show best_guess) ++ ".")
  putStrLn "How many colors are in the correct location?"
  reds <- getLine
  if (read reds) == 4 then putStrLn "Woohoo!"
    else do
      putStrLn "How many colors are in incorrect locations?"
      whites <- getLine
      solve_with ((best_guess, Respond (read reds, read whites)):clues)
  where code_space' = code_space `when` clues
        best_guess = choose_from code_space'

-- Make it run when compiled.
main = solve_with []