Mastermind solver (CIS194 Week 2)

cis194-week2.hs

import Data.List

data Peg = Red | Green | Blue | Yellow | Orange | Purple deriving (Show, Eq, Ord)
type Code = [Peg]
data Move = Move Code Int Int deriving (Show, Eq)

colors :: [Peg]
colors = [Red, Green, Blue, Yellow, Orange, Purple]

exactMatches :: (Eq a) => [a] -> [a] -> Int
exactMatches = (length .) . (filter (== True) .) . zipWith (==)

countColors :: Code -> [Int]
countColors ps = map countColor colors
  where countColor color = length $ filter (== color) ps

matches :: Code -> Code -> Int
matches = (length .) . intersect

getMove :: Code -> Code -> Move
getMove secret guess = Move guess exact non
  where
    exact = exactMatches secret guess
    non = matches secret guess - exact

isConsistent :: Move -> Code -> Bool
isConsistent (Move guess exact nonExact) code = (exact, nonExact) == extractResult simulate
  where
    simulate = getMove code guess
    extractResult (Move _ x y) = (x, y)

filterCodes :: Move -> [Code] -> [Code]
filterCodes = filter . isConsistent

allCodes :: Int -> [Code]
allCodes 0 = []
allCodes 1 = map (:[]) colors
allCodes n = concatMap (\c -> map (c:) $ allCodes (n - 1)) colors

solve :: Code -> [Move]
solve [] = []
solve secret = makeMove (head initialPossibilities) : solver (filterer initialPossibilities)
  where
    len = length secret
    initialPossibilities = allCodes len
    makeMove = getMove secret
    universe moveSeed = filter (isConsistent moveSeed)
    filterer [] = []
    filterer (x:xs) = universe (makeMove x) (x:xs)
    solver [_] = []
    solver u = makeMove (head newUniverse) : solver newUniverse
      where newUniverse = filterer u