src/advent20/advent20.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE BangPatterns #-}
   4
   5
   6 -- import Debug.Trace
   7
   8 -- import Prelude hiding ((++))
   9 import Data.Text (Text)
  10 import qualified Data.Text as T
  11 import qualified Data.Text.IO as TIO
  12
  13 import Data.Void (Void)
  14 import Text.Megaparsec hiding (State)
  15 import Text.Megaparsec.Char
  16 import qualified Text.Megaparsec.Char.Lexer as L
  17 import qualified Control.Applicative as CA
  18
  19 import Data.List (nub)
  20
  21 import qualified Data.Map.Strict as M
  22 import Data.Map.Strict ((!))
  23 import qualified Data.Set as S
  24
  25 import Linear (V2(..))
  26
  27 -- import Control.Monad.State.Lazy
  28 import Control.Monad.State.Strict
  29 import Control.Monad.Extra (concatMapM)
  30 -- import Control.Monad.Trans.List
  31
  32 type Coord = V2 Integer -- x, y, with north and east incresing values (origin a bottom left)
  33 data Door = Door Coord Coord deriving (Show, Eq, Ord)
  34 type Doors = S.Set Door
  35
  36 data MazeSection = Path [Coord] | Junction [Maze] deriving (Show, Eq)
  37 type Maze = [MazeSection]
  38
  39 type Mapper = State Doors [Coord]
  40
  41 type Distances = M.Map Coord Integer
  42
  43
  44 makeDoor :: Coord -> Coord -> Door
  45 makeDoor !a !b
  46     | a < b = Door a b
  47     | otherwise = Door b a
  48
  49 main :: IO ()
  50 main = do
  51         text <- TIO.readFile "data/advent20.txt"
  52         let maze = successfulParse text
  53         print $ T.length text
  54         print $ length $ show maze
  55         let start = V2 0 0
  56         let doors = execState (mapMaze [start] maze) emptyMap
  57         print $ length doors
  58         let distances = dijkstra (S.singleton start) (M.singleton start 0) doors
  59         print $ part1 distances
  60         print $ part2 distances
  61
  62
  63 emptyMap = S.empty
  64
  65 part1 distances = maximum $ M.elems distances
  66 part2 distances = M.size $ M.filter (>= 1000) distances
  67
  68
  69 mapMaze :: [Coord] -> Maze -> Mapper
  70 mapMaze !starts !sections =
  71     foldM (\heres section -> mapMazeSection heres section) starts sections
  72
  73 mapMazeSection :: [Coord] -> MazeSection -> Mapper
  74 mapMazeSection !starts (Junction mazes) =
  75     do finishes <- concatMapM (\maze -> mapMaze starts maze) mazes
  76        return $! nub finishes
  77 mapMazeSection !starts (Path steps) =
  78     mapM mapPath starts
  79     where mapPath start = foldM (\here step -> includeDoor here step) start steps
  80
  81 includeDoor :: Coord -> Coord -> State Doors Coord
  82 includeDoor !here !step =
  83     do let there = (here + step)
  84        let door = there `seq` makeDoor here there
  85        modify' (door `seq` S.insert door)
  86        return there
  87
  88 dijkstra :: S.Set Coord -> Distances -> Doors -> Distances
  89 dijkstra boundary distances doors
  90     | S.null boundary = distances
  91     | otherwise = dijkstra boundary' distances' doors
  92     where (hereSet, others) = S.splitAt 1 boundary
  93           here = S.findMin hereSet
  94           nbrs = neighbours here doors
  95           distance = distances!here
  96           distance' = distance + 1
  97           unseenNbrs = S.filter (\n -> M.notMember n distances) nbrs
  98           boundary' = S.union others unseenNbrs
  99           distances' = S.foldl (\d n -> M.insert n distance' d) distances unseenNbrs
 100
 101 possibleNeighbours :: Coord -> S.Set Coord
 102 possibleNeighbours here = S.fromList $ map (+ here) [V2 0 1, V2 0 (-1), V2 1 0, V2 (-1) 0]
 103
 104 neighbours :: Coord -> Doors -> S.Set Coord
 105 neighbours here doors = S.filter doorExists nbrs
 106     where nbrs = possibleNeighbours here
 107           doorExists there = S.member (makeDoor here there) doors
 108
 109
 110
 111 -- S.intersection doors $ possibleDoors
 112 --    where possibleDoors = S.map (makeDoor here there) $ possibleNeighbours here
 113
 114
 115 type Parser = Parsec Void Text
 116
 117 sc :: Parser ()
 118 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 119
 120 -- lexeme  = L.lexeme sc
 121 symb = L.symbol sc
 122 branchSepP = symb "|"
 123 openBranchP = symb "("
 124 closeBranchP = symb ")"
 125 startP = symb "^"
 126 endP = symb "$"
 127
 128 doorP :: Parser Coord
 129 doorP = nP <|> sP <|> eP <|> wP
 130 nP = (symb "N" *> pure (V2  0  1))
 131 sP = (symb "S" *> pure (V2  0 -1))
 132 eP = (symb "E" *> pure (V2  1  0))
 133 wP = (symb "W" *> pure (V2 -1  0))
 134
 135 pathP = Path <$> some doorP
 136
 137 junctionP = Junction <$> (openBranchP `between` closeBranchP) manyMazesP
 138
 139 manyMazesP = mazeP `sepBy` branchSepP
 140
 141 mazeSectionP = pathP <|> junctionP
 142
 143 mazeP = many mazeSectionP
 144
 145 wholeMazeP = (startP `between` endP) mazeP
 146
 147
 148 successfulParse :: Text -> Maze
 149 successfulParse input =
 150         case parse wholeMazeP "input" input of
 151                 Left  _error -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 152                 Right maze   -> maze