src/task3/task3.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 import Data.List (foldl')        -- import the strict fold
   4
   5 import qualified Data.Map.Strict as M
   6
   7 import Data.Text (Text)
   8 import qualified Data.Text as T
   9 import qualified Data.Text.IO as TIO
  10
  11 import Data.Void (Void)
  12
  13 import Text.Megaparsec -- hiding (State)
  14 import Text.Megaparsec.Char
  15 import qualified Text.Megaparsec.Char.Lexer as L
  16 import qualified Control.Applicative as CA
  17
  18
  19 -- number of steps
  20 type Distance = Int
  21
  22 -- easting, northing
  23 type Position = (Int, Int)
  24
  25 -- the directions. See below for functions for turning
  26 data Direction = North | East | South | West
  27     deriving (Enum, Show, Bounded, Eq)
  28
  29 type Grass = M.Map Position Bool
  30
  31
  32 -- The currenct state of a World
  33 data World = World { direction :: Direction
  34                    , position :: Position
  35                    , pen :: Bool
  36                    , grass :: Grass
  37                    } deriving (Show, Eq)
  38
  39 -- one instruction for the World
  40 data Instruction =   Forward Distance
  41                    | Clockwise
  42                    | Anticlockwise
  43                    | Up
  44                    | Down
  45     deriving (Show, Eq)
  46
  47
  48 main :: IO ()
  49 main = do
  50         instruction_text <- TIO.readFile "data/03-graffiti.txt"
  51         let instructions = successfulParse instruction_text
  52         let mownWorld = foldl' execute initialWorld instructions
  53         print $ part1 mownWorld
  54         TIO.putStr $ part2 mownWorld
  55
  56
  57 part1 :: World -> Int
  58 part1 = M.size . grass
  59
  60 part2 = showWorld
  61
  62 initialWorld = World { direction = North
  63                      , position = (0, 0)
  64                      , pen = False
  65                      , grass = M.empty
  66                      }
  67
  68
  69 -- Make one move
  70 execute :: World -> Instruction -> World
  71 execute w (Forward s)    = iterate forward w !! s
  72 execute w  Clockwise     = w {direction = turnCW (direction w)}
  73 execute w  Anticlockwise = w {direction = turnACW (direction w)}
  74 execute w  Up            = w {pen = False}
  75 execute w  Down          = mow $ w {pen = True}
  76
  77
  78 mow :: World -> World
  79 mow w | pen w     = w {grass = M.insert (position w) True (grass w)}
  80       | otherwise = w
  81
  82
  83 forward :: World -> World
  84 forward w = mow $ w {position = newPosition (direction w) (position w)}
  85
  86 -- Move in the current direction
  87 newPosition :: Direction -> Position -> Position
  88 newPosition North (e, n) = (e, n+1)
  89 newPosition South (e, n) = (e, n-1)
  90 newPosition West  (e, n) = (e-1, n)
  91 newPosition East  (e, n) = (e+1, n)
  92
  93
  94 -- | a `succ` that wraps
  95 turnCW :: (Bounded a, Enum a, Eq a) => a -> a
  96 turnCW dir | dir == maxBound = minBound
  97            | otherwise       = succ dir
  98
  99 -- | a `pred` that wraps
 100 turnACW :: (Bounded a, Enum a, Eq a) => a -> a
 101 turnACW dir | dir == minBound = maxBound
 102             | otherwise       = pred dir
 103
 104
 105
 106 showWorld :: World -> Text
 107 showWorld w = showGrass mine maxn minn mine maxn maxe g
 108     where
 109       g = grass w
 110       mine = minimum(map fst $ M.keys g)
 111       maxe = maximum(map fst $ M.keys g)
 112       minn = minimum(map snd $ M.keys g)
 113       maxn = maximum(map snd $ M.keys g)
 114
 115 showGrass :: Int -> Int -> Int -> Int -> Int -> Int -> Grass -> Text
 116 showGrass e n minn mine maxn maxe g
 117   | n == minn && e == maxe = T.singleton '\n'
 118   | e == maxe              = T.cons '\n' $ showGrass mine  (n-1) minn mine maxn maxe g
 119   | otherwise              = T.cons cell $ showGrass (e+1) n     minn mine maxn maxe g
 120       where cell = if M.member (e, n) g then '⌷' else ' '
 121
 122 -- Parse the input file
 123
 124 type Parser = Parsec Void Text
 125
 126 -- treat comment lines as whitespace
 127 sc :: Parser ()
 128 sc = L.space space1 lineComment CA.empty
 129     where lineComment = L.skipLineComment "#"
 130
 131 lexeme  = L.lexeme sc
 132 integer = lexeme L.decimal
 133 symb = L.symbol sc
 134
 135 -- instructions is some optional space followed by many instructions
 136 instrsP = optional sc *> many instrP
 137
 138 -- an instruction is either F, C, or A
 139 instrP = forwardP <|> cwP <|> acwP <|> upP <|> downP
 140
 141 -- parse each instruction
 142 forwardP = Forward <$> (symb "F" *> integer)
 143 cwP = Clockwise <$ symb "C"
 144 acwP = Anticlockwise <$ symb "A"
 145 upP = Up <$ symb "U"
 146 downP = Down <$ symb "D"
 147
 148 successfulParse :: Text -> [Instruction]
 149 successfulParse input =
 150         case parse instrsP "input" input of
 151                 Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 152                 Right instrs  -> instrs