Every so often I get the urge to dive into Haskell programming. It doesn’t happen often and the periods in between the dives are long enough that I have to start from the beginning each time because I forgot everything I learned last time. It also never lasts that long either, the urge goes away right about when Monads appear. Maybe this urge is similar to the life cycle of cicadas, so I will call the little projects coming from this current urge “Haskell cicadas”. If enough material comes out, maybe I can collect it into a little booklet with a nice cover Most likely this current urge will fizzle out before enough material accumulates. I do like the cover though. It is an image from Bill Nino on Unsplash. :
It would match well with the tiger and lion from the two favorite books I use in my dives:
This book introduces fundamental techniques for reasoning mathematically about functional programs. Ideal for a first- or second-year undergraduate course.
Ideal for learning or reference, this book explains the five main principles of algorithm design and their implementation in Haskell.
The third book I use
This extensively updated and expanded version of the best-selling first edition now covers recent and more advanced features of Haskell.
is one of the best programming books I ever read.
So please be warned: don’t expect to learn Haskell from these cicada posts. Instead treat them as entertainment: watching somebody that doesn’t use Haskell in their professional life struggle to use function combinations and compositions instead of loops to express little algorithm snippets.
With the motivation and disclaimer out of the way, let’s look at today’s cicada This was given to me as an interview question some time ago. Haskell was not the implementation language I chose in the interview. :
Write a function that solves the board game Mastermind. You are allowed to do as much processing as you like but you only have a finite number of submissions of guesses for evaluation. Duplicate colors are allowed in the code, blanks are not allowed.
Let’s first define the types of the values we want to manipulate and some constants. The code pegs on the Mastermind board have colors, so it makes sense to define:
data Color = White | Pink | Yellow | Green | Red | Blue deriving (Eq, Show, Ord)
colors = [White, Pink, Yellow, Green, Red, Blue]
The code to be guessed and guesses can be lists of Color items (the position in the list corresponds to the position of a peg). A useful function to have is the evaluation function that returns how well a guess matches with the code goal. It will return a tuple of integers: the first number in the tuple is the number pegs that match color and position. The second number is the number of pegs that match color but are out of position.
type Score = (Int, Int)
eval :: [Color] -> [Color] -> Score
Given a code and a guess, it makes sense to collect the mismatches. This will allow us to calculate the first number in the Score tuple: we subtract the length of the mismatches list from the length of a code. The list of mismatches will also serve as input into the computation of the second number in the Score tuple. So let’s define the mismatches function. We will express the result as a list of tuples of Colors. We will zip up the code and the guess into a list of Color tuples and munch through that list using foldr (following this advice).
mismatchMuncher :: (Color, Color) -> [(Color, Color)] -> [(Color, Color)]
mismatchMuncher (c1, c2) ms = if c1 /= c2 then (c1, c2):ms else ms
mismatches :: [Color] -> [Color] -> [(Color, Color)]
mismatches code guess = foldr mismatchMuncher [] (zip code guess)
To process the mismatches further, let’s define a function that given two lists of Colors, counts how many Colors match irrespective of position (the stronger matches of position and colors have already been accounted for). Since position does not matter we can require that the input lists are sorted and then move through the lists, incrementing a counter on matches.
countColorMatches :: [Color] -> [Color] -> Int
countColorMatches _ [] = 0
countColorMatches [] _ = 0
countColorMatches (x:xs) (y:ys) | x < y = countColorMatches xs (y:ys)
| x > y = countColorMatches (x:xs) ys
| otherwise = 1 + (countColorMatches xs ys)
We are now ready to implement eval:
eval :: [Color] -> [Color] -> Score
eval code guess = (correctPositions, correctColors)
where
ms = mismatches code guess
correctPositions = length code - length ms
(codeColors, guessColors) = unzip ms
correctColors = countColorMatches (sort codeColors) (sort guessColors)
I stated earlier that the eval function is useful to have for our solution but I haven’t explained why. The explanation has to do with the following observation: if we submit a guess g and get back a Score s, then the eventual solution c will have the same Score s when evaluated against g. This gives us a powerful filter to reduce the space of guesses: any guess h that has a different Score from s when evaluated against g can be discarded.
Our strategy becomes: make a first guess, submit it for evaluation and use the Score to filter out guesses. Pick the next guess from the remaining guesses and submit it. Use the Score again to filter down the remaining guesses even more. With a little bit of luck, we don’t run out of allowed submissions before we filtered the set of guesses down to one.
The filtering function is simply:
filterGuesses :: [[Color]] -> [Color] -> Score -> [[Color]]
filterGuesses gs guess score = filter (\guess' -> (eval guess guess') == score) gs
We now want to put together a function that plays through this strategy. First let’s define one round:
type Round = (
[Color] -- code
, [[Color]] -- guesses
, Score -- evaluation of (head guesses) against code
)
We define a play function that executes one round. It does know about the code and when presented with a guess, it evaluates it and returns the score and the remaining guesses as another round. Because input and output types are the same, we can use iterate to play multiple rounds.
play :: Round -> Round
play (code, guesses, _) = (code, remainingGuesses, score)
where
guess = head guesses
score = eval code guess
remainingGuesses = filterGuesses (tail guesses) guess score
We’re ready for our solve function:
solve :: [Color] -> [[Color]]
solve code = map (\(_, gs, _) -> (head gs)) solution
where
guesses = [[c1, c2, c3, c4] | c1 <- colors, c2 <- colors, c3 <- colors, c4 <- colors]
rounds = iterate play (code, guesses, (0, 0))
solution = takeWhile (\(_, gs, _) -> gs /= []) rounds
Given a code it iterates through rounds of play until the remaining guesses are empty.
This looks good except for the assumption that code words are length four when generating the list of guesses. We need a function that given a code length generates all possible code words.
Our code word alphabet are the colors, so for each code word position there are (c = length colors) choices, which means there c^n total code words of length n. Each code word corresponds to an integer in the range [0..c^n) if you interpret the code word characters as integer digits in base c. This gives us a one-to-one mapping that we can use to generate all possible code words: we iterate through the integers [0..c^n) and compute their digit representation in base c which gives us the code word.
Let’s define the necessary functions. First the function digits which given an integer and a base, returns the list of digits:
digits :: Int -> Int -> [Int]
digits x base = digitMuncher x []
where
digitMuncher :: Int -> [Int] -> [Int]
digitMuncher 0 ds = ds
digitMuncher y ds = digitMuncher (div y base) ((mod y base):ds)
Next we need to left-pad the digit list with zeroes when the code word length is not met:
leftPad :: a -> Int -> [a] -> [a]
leftPad _ 0 xs = xs
leftPad x n xs = x:leftPad x (n-1) xs
ensureLength :: a -> Int -> [a] -> [a]
ensureLength x n xs = if l < n then leftPad x (n - l) xs else xs
where
l = length xs
And now we can turn an integer into a [Color]:
colorDigits :: Int -> Int -> [Color]
colorDigits m n = map (colors !!) ds
where
base = length colors
ds = ensureLength 0 m (digits n base)
Finally we’re ready to generate all possible guesses:
allPossibleGuesses :: Int -> [[Color]]
allPossibleGuesses n = [ colorDigits n y | y <- [0..e]]
where
e = (length colors)^n - 1
and use this function in our solve instead of the hard-coded list comprehension:
solve :: [Color] -> [[Color]]
solve code = map (\(_, gs, _) -> (head gs)) solution
where
guesses = allPossibleGuesses (length code)
rounds = iterate play (code, guesses, (0, 0))
solution = takeWhile (\(_, gs, _) -> gs /= []) rounds
We are done. Let’s try it in ghci:
ghci> solve [Red, Red, Green, Blue]
[[White,White,White,White],[Pink,Pink,Pink,Pink],
[Yellow,Yellow,Yellow,Yellow],
[Green,Green,Green,Green],[Green,Red,Red,Red],
[Red,Green,Red,Blue],[Red,Green,Blue,Red],[Red,Red,Green,Blue]]
ghci>
It took 8 rounds :-).
Here’s the full Module:
module Mastermind (
Color
, Score
, colors
, eval
, filterGuesses
, Round
, play
, solve
) where
import Data.List ( sort )
data Color = White | Pink | Yellow | Green | Red | Blue deriving (Eq, Show, Ord)
colors :: [Color]
colors = [White, Pink, Yellow, Green, Red, Blue]
type Score = (Int, Int)
mismatchMuncher :: (Color, Color) -> [(Color, Color)] -> [(Color, Color)]
mismatchMuncher (c1, c2) ms = if c1 /= c2 then (c1, c2):ms else ms
mismatches :: [Color] -> [Color] -> [(Color, Color)]
mismatches code guess = foldr mismatchMuncher [] (zip code guess)
countColorMatches :: [Color] -> [Color] -> Int
countColorMatches _ [] = 0
countColorMatches [] _ = 0
countColorMatches (x:xs) (y:ys) | x < y = countColorMatches xs (y:ys)
| x > y = countColorMatches (x:xs) ys
| otherwise = 1 + (countColorMatches xs ys)
eval :: [Color] -> [Color] -> Score
eval code guess = (correctPositions, correctColors)
where
ms = mismatches code guess
correctPositions = length code - length ms
(codeColors, guessColors) = unzip ms
correctColors = countColorMatches (sort codeColors) (sort guessColors)
filterGuesses :: [[Color]] -> [Color] -> Score -> [[Color]]
filterGuesses gs guess score = filter (\guess' -> (eval guess guess') == score) gs
type Round = (
[Color] -- code
, [[Color]] -- guesses
, Score -- evaluation of (head guesses) against code
)
play :: Round -> Round
play (code, guesses, _) = (code, remainingGuesses, score)
where
guess = head guesses
score = eval code guess
remainingGuesses = filterGuesses (tail guesses) guess score
leftPad :: a -> Int -> [a] -> [a]
leftPad _ 0 xs = xs
leftPad x n xs = x:leftPad x (n-1) xs
digits :: Int -> Int -> [Int]
digits x base = digitMuncher x []
where
digitMuncher :: Int -> [Int] -> [Int]
digitMuncher 0 ds = ds
digitMuncher y ds = digitMuncher (div y base) ((mod y base):ds)
ensureLength :: a -> Int -> [a] -> [a]
ensureLength x n xs = if l < n then leftPad x (n - l) xs else xs
where
l = length xs
colorDigits :: Int -> Int -> [Color]
colorDigits m n = map (colors !!) ds
where
base = length colors
ds = ensureLength 0 m (digits n base)
allPossibleGuesses :: Int -> [[Color]]
allPossibleGuesses n = [ colorDigits n y | y <- [0..e]]
where
e = (length colors)^n - 1
solve :: [Color] -> [[Color]]
solve code = map (\(_, gs, _) -> (head gs)) solution
where
guesses = allPossibleGuesses (length code)
rounds = iterate play (code, guesses, (0, 0))
solution = takeWhile (\(_, gs, _) -> gs /= []) rounds
Possible optimization I can think of: it probably is not necessary to materialize the guesses list. One could instead lazily generate and filter guesses as needed. Left as an exercise to the reader.