1 files changed, 218 insertions, 0 deletions
diff --git a/users/wpcarro/assessments/dotted-squares/Main.hs b/users/wpcarro/assessments/dotted-squares/Main.hs
new file mode 100644
index 000000000000..44f91e2b2311
--- /dev/null
+++ b/users/wpcarro/assessments/dotted-squares/Main.hs
@@ -0,0 +1,218 @@
+{-# LANGUAGE DeriveGeneric #-}
+--------------------------------------------------------------------------------
+module Main where
+--------------------------------------------------------------------------------
+import Data.Hashable
+import Data.Function ((&))
+import GHC.Generics
+import Text.ParserCombinators.ReadP
+import Control.Applicative
+
+import qualified Data.HashSet as HS
+--------------------------------------------------------------------------------
+
+data Direction
+  = DirLeft
+  | DirRight
+  | DirUp
+  | DirDown
+  deriving (Eq, Show)
+
+data Point = Point Int Int
+  deriving (Eq, Show, Ord, Generic)
+instance Hashable Point
+
+data Orientation
+  = Horizontal
+  | Vertical
+  deriving (Eq, Show)
+
+data Anchor
+  = Beg
+  | End
+  deriving (Eq, Show)
+
+data Rotation
+  = CW
+  | CCW
+  deriving (Eq, Show)
+
+data Line = Line Point Point
+  deriving (Show, Generic)
+instance Hashable Line
+
+instance Eq Line where
+  Line begA endA == Line begB endB =
+    (begA == begB && endA == endB) ||
+    (begA == endB && endA == begB)
+
+data Game = Game (HS.HashSet Line) [Line]
+  deriving (Eq, Show)
+
+data Scoreboard = Scoreboard Int Int
+  deriving (Eq)
+
+instance Semigroup Scoreboard where
+  (Scoreboard a b) <> (Scoreboard x y) =
+    Scoreboard (a + x) (b + y)
+
+instance Monoid Scoreboard where
+  mempty = Scoreboard 0 0
+
+data Turn
+  = Player1
+  | Player2
+  deriving (Eq, Show)
+
+next :: Turn -> Turn
+next Player1 = Player2
+next Player2 = Player1
+
+instance Show Scoreboard where
+  show (Scoreboard p1 p2) =
+    "Player 1: " ++ show (p1) ++ " Player 2: " ++ show (p2)
+
+digit :: ReadP Char
+digit = satisfy (\c -> c >= '0' && c <= '9')
+
+int :: ReadP Int
+int = read <$> many1 digit
+
+inputLine :: ReadP String
+inputLine = manyTill get (char '\n')
+
+direction :: ReadP Direction
+direction = do
+  c <- char 'L' <|> char 'R' <|> char 'U' <|> char 'D'
+  case c of
+    'L' -> pure DirLeft
+    'R' -> pure DirRight
+    'U' -> pure DirUp
+    'D' -> pure DirDown
+    _   -> fail $ "Unexpected direction: " ++ show c
+
+validMove :: Int -> Int -> ReadP Line
+validMove w h = do
+  x <- int
+  skipSpaces
+  y <- int
+  skipSpaces
+  dir <- direction
+  _ <- char '\n'
+  if x >= 0 && x <= w &&  y >= 0 && y <= h then do
+    let beg = Point x y
+    pure $ mkLine beg (shiftPoint dir beg)
+  else
+    fail "Expected a move on the game board"
+
+game :: ReadP Game
+game = do
+  w <- read <$> inputLine
+  h <- read <$> inputLine
+  locs <- read <$> inputLine
+  moves <- count locs (validMove w h)
+  eof
+  pure $ Game mempty moves
+
+parseInput :: String -> Maybe Game
+parseInput x = do
+  case readP_to_S game x of
+    [(res, "")] -> Just res
+    _ -> Nothing
+
+-- | Smart constructor to ensure that beg is always < end.
+mkLine :: Point -> Point -> Line
+mkLine beg end =
+  if beg < end then Line beg end else Line end beg
+
+mkLineDir :: Int -> Int -> Direction -> Line
+mkLineDir x y dir =
+  let beg = Point x y
+  in mkLine beg (shiftPoint dir beg)
+
+mkLineDir' :: Point -> Direction -> Line
+mkLineDir' (Point x y) dir = mkLineDir x y dir
+
+shiftPoint :: Direction -> Point -> Point
+shiftPoint DirLeft  (Point x y) = Point (x - 1) y
+shiftPoint DirRight (Point x y) = Point (x + 1) y
+shiftPoint DirUp    (Point x y) = Point x (y + 1)
+shiftPoint DirDown  (Point x y) = Point x (y - 1)
+
+shiftLine :: Direction -> Line -> Line
+shiftLine dir (Line beg end) =
+  mkLine (shiftPoint dir beg) (shiftPoint dir end)
+
+rotateLine :: Anchor -> Rotation -> Line -> Line
+rotateLine anchor rotation line =
+  doRotateLine (classifyOrientation line) anchor rotation line
+
+doRotateLine :: Orientation -> Anchor -> Rotation -> Line -> Line
+doRotateLine Horizontal Beg CW  (Line beg _) = mkLineDir' beg DirDown
+doRotateLine Horizontal Beg CCW (Line beg _) = mkLineDir' beg DirUp
+doRotateLine Horizontal End CW  (Line _ end) = mkLineDir' end DirUp
+doRotateLine Horizontal End CCW (Line _ end) = mkLineDir' end DirDown
+doRotateLine Vertical   Beg CW  (Line beg _) = mkLineDir' beg DirRight
+doRotateLine Vertical   Beg CCW (Line beg _) = mkLineDir' beg DirLeft
+doRotateLine Vertical   End CW  (Line _ end) = mkLineDir' end DirLeft
+doRotateLine Vertical   End CCW (Line _ end) = mkLineDir' end DirRight
+
+classifyOrientation :: Line -> Orientation
+classifyOrientation (Line (Point _ y1) (Point _ y2)) =
+  if y1 == y2 then Horizontal else Vertical
+
+closesAnySquare :: HS.HashSet Line -> Line -> Bool
+closesAnySquare allMoves line = do
+  let alreadyDrawn x = HS.member x allMoves
+  case classifyOrientation line of
+    Horizontal ->
+      all alreadyDrawn
+        [ shiftLine DirUp line
+        , rotateLine Beg CCW line
+        , rotateLine End CW line
+        ] ||
+      all alreadyDrawn
+        [ shiftLine DirDown line
+        , rotateLine Beg CW line
+        , rotateLine End CCW line
+        ]
+    Vertical ->
+      all alreadyDrawn
+        [ shiftLine DirLeft line
+        , rotateLine Beg CCW line
+        , rotateLine End CW line
+        ] ||
+      all alreadyDrawn
+        [ shiftLine DirRight line
+        , rotateLine Beg CW line
+        , rotateLine End CCW line
+        ]
+
+incScoreboard :: Turn -> Scoreboard -> Scoreboard
+incScoreboard Player1 score = score <> Scoreboard 1 0
+incScoreboard Player2 score = score <> Scoreboard 0 1
+
+scoreGame :: Turn -> Game -> Scoreboard -> Maybe Scoreboard
+scoreGame _ (Game _ []) score = Just $ score
+scoreGame player (Game allMoves (line:rest)) score =
+  if HS.member line allMoves then
+    Nothing
+  else do
+    let allMoves' = HS.insert line allMoves
+        score' = if closesAnySquare allMoves line then
+                   incScoreboard player score
+                 else score
+    scoreGame (next player) (Game allMoves' rest) score'
+
+(|>) :: a -> (a -> b) -> b
+(|>) = (&)
+
+main :: IO ()
+main = do
+  input <- readFile "game.txt"
+  case parseInput input of
+    Nothing -> putStrLn "invalid"
+    Just parsedGame ->
+      case scoreGame Player1 parsedGame mempty of
+        Nothing -> putStrLn "invalid"
+        Just score -> print score