Haskell coding challenge

As the final part of this blogging series I will put myself to the test using a coding challenge. I am really glad that I have been prepared to do this challenge.

Give me six hours to chop down a tree and I will spend the first four sharpening the axe. Abraham Lincoln

Create tic-tac-toe in Haskell with a board size of 3.

I think this challenge is great to do because of the user input that needs to be processed into the game, which has been a challenge to do with Haskell.

The first thing we need to do in order to achieve this challenge is defining some types:

data Move        = O | X
                     deriving (Eq, Show, Enum, Ord)
type Position    = (Char, Int)
data BoardMove   = BoardMove
                   { bMove :: Maybe Move, bPos :: Position }
                     deriving (Eq, Show)
type Board       = [BoardMove]
type InvalidMove = String

To start the game we will make a main method like this:

main :: IO ()
main = do
  putStrLn "Starting game..."
  putStrLn "Type quit to exit the game."
  let newBoard = empty 3
    in do (putStrLn . (\s->"\n"++s++"\n") . printBoard) newBoard
          gameExecution Nothing newBoard

After that we code the game to make it work:

coord = (['A'..], [1..])

empty :: Int -> Board
empty size = do
  x <- take size (fst coord)
  y <- take size (snd coord)
  return $ BoardMove Nothing (x,y)

printBoard :: Board -> String
printBoard b = intercalate "\n" $
                 map (\row-> [(fst . bPos) (row !! 0)] ++ "]   | " ++
                             (intercalate " | "
                                $ map (\bm-> maybe " " show $ bMove bm) row)
                             ++ " |")
                 (cut 3 b)

cut :: Int -> [a] -> [[a]]
cut n [] =  []
cut n xs =  take n xs : cut n (drop n xs)

gameExecution prevMove board = do
  let currPlayer = maybe X (\(BoardMove mv _) ->
                               case mv of
                                 Just X -> O
                                 Just O -> X) prevMove
  putStr $ "Player '" ++ (show currPlayer) ++ "': "
  hFlush stdout
  playerMove <- getLine
  case (playerMove, (map toUpper playerMove) `elem` allCoord) of
    ("quit", _) ->
        putStrLn "Thanks for playing, come again!"
    (_, False)  -> do
        putStrLn $ "Possible options: " ++ intercalate ", " allCoord
        gameExecution prevMove board
    otherwise   -> do
        let pos = (toUpper $ playerMove !! 0,
                   read [(playerMove !! 1)] :: Int)
            currMove = BoardMove (Just currPlayer) pos
            currBoard = move currMove board
        either putStrLn (putStrLn . (\s->"\n"++s++"\n") . printBoard) currBoard
        case currBoard of
          Right r  -> if win currMove r
                        then do putStrLn $ "Player '"
                                           ++ (show currPlayer) ++"' wins!"
                                main
                        else if draw currMove r
                                then do putStrLn $ "It's a draw!"
                                        main
                                else gameExecution (Just currMove) r
          Left err -> gameExecution prevMove board
  where allCoord = [[x] ++ show y | x <- take 3 (fst coord),
                                    y <- take 3 (snd coord)]

move :: BoardMove -> Board -> Either InvalidMove Board
move (BoardMove _ (c,r)) [] =
  Left $ "Could not make the move to given position " ++ [c] ++ (show r)
move bm@(BoardMove nmov npos) (x:xs)
  | findMove x = Right $ bm:xs
  | otherwise  =
    case move bm xs of
      Right r -> Right $ x:r
      err     -> err
  where findMove (BoardMove m p) =
          p == npos && isNothing m && nmov /= Nothing

draw :: BoardMove -> Board -> Bool
draw bm b = not (any (isNothing . bMove) b)
         && not (win bm b)

win :: BoardMove -> Board -> Bool
win (BoardMove Nothing _) _ = False
win (BoardMove m (c,r)) b = row || col || diag' cb || diag' (reverse cb)
 where row = length
             (filter (\(BoardMove m2 (_,r2)) ->
                       m2 == m && r2 == r) b) == 3
       col = length
             (filter (\(BoardMove m2 (c2,_)) ->
                       m2 == m && c2 == c) b) == 3
       diag' xss = all (\(BoardMove m2 _) ->
                         m2 == m) $ diag xss
       cb = cut 3 b

diag :: [[a]] -> [a]
diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]

And now we will look at the results. Getting a draw:

*Main> main
Starting game...
Type quit to exit the game.

A]   |   |   |   |
B]   |   |   |   |
C]   |   |   |   |

Player 'X': A1

A]   | X |   |   |
B]   |   |   |   |
C]   |   |   |   |

Player 'O': A2

A]   | X | O |   |
B]   |   |   |   |
C]   |   |   |   |

Player 'X': C3

A]   | X | O |   |
B]   |   |   |   |
C]   |   |   | X |

Player 'O': B2

A]   | X | O |   |
B]   |   | O |   |
C]   |   |   | X |

Player 'X': C2

A]   | X | O |   |
B]   |   | O |   |
C]   |   | X | X |

Player 'O': C1

A]   | X | O |   |
B]   |   | O |   |
C]   | O | X | X |

Player 'X': A3

A]   | X | O | X |
B]   |   | O |   |
C]   | O | X | X |

Player 'O': B3

A]   | X | O | X |
B]   |   | O | O |
C]   | O | X | X |

Player 'X': B1

A]   | X | O | X |
B]   | X | O | O |
C]   | O | X | X |

It's a draw!

Winning:

Starting game...
Type quit to exit the game.

A]   |   |   |   |
B]   |   |   |   |
C]   |   |   |   |

Player 'X': C3

A]   |   |   |   |
B]   |   |   |   |
C]   |   |   | X |

Player 'O': A1

A]   | O |   |   |
B]   |   |   |   |
C]   |   |   | X |

Player 'X': C1

A]   | O |   |   |
B]   |   |   |   |
C]   | X |   | X |

Player 'O': C2

A]   | O |   |   |
B]   |   |   |   |
C]   | X | O | X |

Player 'X': A3

A]   | O |   | X |
B]   |   |   |   |
C]   | X | O | X |

Player 'O': B2

A]   | O |   | X |
B]   |   | O |   |
C]   | X | O | X |

Player 'X': B3

A]   | O |   | X |
B]   |   | O | X |
C]   | X | O | X |

Player 'X' wins!

Wrapping up learning the language

I feel like Haskell is a really hard language to learn if you only know Java (and C#), PHP and just a little more than the basics of Javascript. With a lot of help from the internet and the seven languages in seven weeks book I managed to make something out of learning this language, but I am sure I have still a lot to learn about it. It was a fun time to do programming with Haskell, because of the functional paradigm and the logical outputs. (once you get to know what the functions are supposed to do)

I will definitely keep on learning this language deeper to fully understand it and I will start to learn the other languages that are available in this book.