Created
January 16, 2009 16:44
-
-
Save blinks/47991 to your computer and use it in GitHub Desktop.
A Mastermind Solver in Haskell.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- Master: Mastermind Solver | |
-- Adam Blinkinsop <[email protected]> | |
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 [] |
hey friend could tell me which receives the main? please
Creo que ni el sabe que ingresar, es un código espantoso, ilegible e ineficiente
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
podrias decirme que se debe ingresar? por favor!