From 6c841469511fafa9c6108244023536b1a124ff24 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Thu, 21 Dec 2017 22:34:57 +0000 Subject: [PATCH] Added type annotations and a more parallel version --- advent-of-code.cabal | 10 ++ src/advent21/advent21.hs | 49 ++++++-- src/advent21/advent21parallel.hs | 200 +++++++++++++++++++++++++++++++ 3 files changed, 247 insertions(+), 12 deletions(-) create mode 100644 src/advent21/advent21parallel.hs diff --git a/advent-of-code.cabal b/advent-of-code.cabal index f9fafce..f2d723c 100644 --- a/advent-of-code.cabal +++ b/advent-of-code.cabal @@ -228,3 +228,13 @@ executable advent21 , containers , text , megaparsec + +executable advent21parallel + hs-source-dirs: src/advent21 + main-is: advent21parallel.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , containers + , text + , megaparsec + , parallel diff --git a/src/advent21/advent21.hs b/src/advent21/advent21.hs index 62b5b5c..a4a092b 100644 --- a/src/advent21/advent21.hs +++ b/src/advent21/advent21.hs @@ -42,21 +42,34 @@ main = do print $ countLit $ nthApplication rules 18 +-- Read the rules, and expand them to all equivalent left hand sides readRules :: Text -> [Rule] readRules = expandRules . successfulParse + +expandRules :: [Rule] -> [Rule] expandRules = concatMap expandRule + +expandRule :: Rule -> [Rule] expandRule rule = [Rule l (rulePost rule) | l <- allArrangements (rulePre rule)] + +reflectH :: Grid -> Grid reflectH g = M.fromList [((r, c) , M.findWithDefault False (rm - r, c) g) | r <- [0..rm], c <- [0..cm] ] where (rm, cm) = bounds g +reflectV :: Grid -> Grid reflectV g = M.fromList [((r, c) , M.findWithDefault False (r, cm - c) g) | r <- [0..rm], c <- [0..cm] ] where (rm, cm) = bounds g +-- awkward naming to avoid clashing with Prelude +transposeG :: Grid -> Grid transposeG g = M.fromList [((c, r) , M.findWithDefault False (r, c) g) | r <- [0..rm], c <- [0..cm] ] where (rm, cm) = bounds g + +-- Find all the arrangments of a grid, including reflection and rotation. +allArrangements :: Grid -> [Grid] allArrangements grid = map (\f -> f grid) [ id , reflectH , reflectV @@ -69,32 +82,32 @@ allArrangements grid = map (\f -> f grid) [ id - +-- Count number of lit pixels +countLit :: Grid -> Int countLit = M.size . M.filter id - -applyOnce rules g = contractExploded $ M.map (apply rules) $ explodeGrid g - +-- apply the rules _n_ times +nthApplication :: [Rule] -> Int -> Grid nthApplication rules n = (!! n) $ iterate (applyOnce rules) initialGrid +-- Apply one step of the expansion +applyOnce :: [Rule] -> Grid -> Grid +applyOnce rules g = contractExploded $ M.map (apply rules) $ explodeGrid g - +-- find the appropriate rule and apply it to a grid +apply :: [Rule] -> Grid -> Grid apply rules grid = rulePost thisRule where ri = head $ findIndices (\r -> rulePre r == grid) rules thisRule = rules!!ri +-- create the appropriate subgrids of a grid explodeGrid :: Grid -> ExplodedGrid explodeGrid g = if (rm + 1) `rem` 2 == 0 then explodeGrid' 2 g else explodeGrid' 3 g where (rm, cm) = bounds g -contractExploded :: ExplodedGrid -> Grid -contractExploded gs = foldl1 (>|<) $ map (foldl1 (>-<)) rows - where rows = explodedRows gs - - explodeGrid' :: Int -> Grid -> ExplodedGrid explodeGrid' n g = M.fromList [((bigR, bigC), subGrid n g bigR bigC) | bigR <- [0..bigRm], bigC <- [0..bigCm]] where (rm, cm) = bounds g @@ -110,14 +123,24 @@ subGrid n g bigR bigC = M.fromList [ ((r, c), where rStep = bigR * n cStep = bigC * n +-- merge a set of subgrids into one +contractExploded :: ExplodedGrid -> Grid +contractExploded gs = foldl1 (>|<) $ map (foldl1 (>-<)) rows + where rows = explodedRows gs +-- find the rows of an exploded grid +explodedRows :: ExplodedGrid -> [ExplodedGrid] explodedRows eg = [M.filterWithKey (\(r, _) _ -> r == row) eg | row <- [0..rowMax] ] where (rowMax, _) = bounds eg +-- merge two grids horizontally +(>-<) :: Grid -> Grid -> Grid (>-<) g1 g2 = M.union g1 g2' where (_, cm) = bounds g1 g2' = M.mapKeys (\(r, c) -> (r, c + cm + 1)) g2 +-- merge two grids vertically +(>|<) :: Grid -> Grid -> Grid (>|<) g1 g2 = M.union g1 g2' where (rm, _) = bounds g1 g2' = M.mapKeys (\(r, c) -> (r + rm + 1, c)) g2 @@ -125,11 +148,11 @@ explodedRows eg = [M.filterWithKey (\(r, _) _ -> r == row) eg | row <- [0..rowMa - bounds :: M.Map (Int, Int) a -> (Int, Int) bounds grid = (maximum $ map fst $ M.keys grid, maximum $ map snd $ M.keys grid) +showGrid :: Grid -> String showGrid g = unlines [[showGChar $ M.findWithDefault False (r, c) g | c <- [0..cm] ] | r <- [0..rm] ] where (rm, cm) = bounds g @@ -137,6 +160,8 @@ showGrid g = unlines [[showGChar $ M.findWithDefault False (r, c) g | showGChar False = '.' + +-- really persuade Megaparsec not to include newlines in how it consume spaces. onlySpace = (char ' ') <|> (char '\t') sc :: Parser () @@ -152,7 +177,7 @@ present = id True <$ symbol "#" absent = id False <$ symbol "." rulesP = ruleP `sepBy` space -ruleP = Rule <$> gridP <*> (ruleJoin *> gridP) +ruleP = Rule <$> gridP <* ruleJoin <*> gridP gridP = gridify <$> rowP `sepBy` rowSep where gridify g = M.fromList $ concat diff --git a/src/advent21/advent21parallel.hs b/src/advent21/advent21parallel.hs new file mode 100644 index 0000000..cd0b898 --- /dev/null +++ b/src/advent21/advent21parallel.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Text.Megaparsec hiding (State) +import qualified Text.Megaparsec.Lexer as L +import Text.Megaparsec.Text (Parser) +import qualified Control.Applicative as CA +-- import qualified Data.Functor as F + +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) + +import Data.List + +import Control.Parallel.Strategies (parMap, rpar) + + +type Grid = M.Map (Int, Int) Bool +type ExplodedGrid = M.Map (Int, Int) Grid + +data Rule = Rule Grid Grid deriving (Eq, Show) + +rulePre (Rule g _) = g +rulePost (Rule _ g) = g + + +initialGrid = case parse gridP "" ".#./..#/###" of + Left _ -> M.empty + Right g -> g + + +main :: IO () +main = do + text <- TIO.readFile "data/advent21.txt" + let rules = readRules text + print $ countLit $ nthApplication rules 5 + print $ countLit $ nthApplication rules 18 + + +-- Read the rules, and expand them to all equivalent left hand sides +readRules :: Text -> [Rule] +readRules = expandRules . successfulParse + + +expandRules :: [Rule] -> [Rule] +expandRules = concatMap expandRule + +expandRule :: Rule -> [Rule] +expandRule rule = [Rule l (rulePost rule) | l <- allArrangements (rulePre rule)] + + +reflectH :: Grid -> Grid +reflectH g = M.fromList [((r, c) , M.findWithDefault False (rm - r, c) g) | r <- [0..rm], c <- [0..cm] ] + where (rm, cm) = bounds g + +reflectV :: Grid -> Grid +reflectV g = M.fromList [((r, c) , M.findWithDefault False (r, cm - c) g) | r <- [0..rm], c <- [0..cm] ] + where (rm, cm) = bounds g + +-- awkward naming to avoid clashing with Prelude +transposeG :: Grid -> Grid +transposeG g = M.fromList [((c, r) , M.findWithDefault False (r, c) g) | r <- [0..rm], c <- [0..cm] ] + where (rm, cm) = bounds g + + +-- Find all the arrangments of a grid, including reflection and rotation. +allArrangements :: Grid -> [Grid] +allArrangements grid = map (\f -> f grid) [ id + , reflectH + , reflectV + , transposeG + , reflectH . transposeG + , reflectV . transposeG + , reflectH . reflectV . transposeG + , reflectV . reflectH + ] + + + +-- Count number of lit pixels +countLit :: Grid -> Int +countLit = M.size . M.filter id + +-- apply the rules _n_ times +nthApplication :: [Rule] -> Int -> Grid +nthApplication rules n = (!! n) $ iterate (applyOnce rules) initialGrid + +-- Apply one step of the expansion +applyOnce :: [Rule] -> Grid -> Grid +-- applyOnce rules g = contractExploded $ M.map (apply rules) $ explodeGrid g +applyOnce rules g = contractExploded $ M.unions $ parMap rpar (M.map (apply rules)) $ M.splitRoot $ explodeGrid g + + +-- find the appropriate rule and apply it to a grid +apply :: [Rule] -> Grid -> Grid +apply rules grid = rulePost thisRule + where ri = head $ findIndices (\r -> rulePre r == grid) rules + thisRule = rules!!ri + + +-- create the appropriate subgrids of a grid +explodeGrid :: Grid -> ExplodedGrid +explodeGrid g = if (rm + 1) `rem` 2 == 0 + then explodeGrid' 2 g + else explodeGrid' 3 g + where (rm, cm) = bounds g + +explodeGrid' :: Int -> Grid -> ExplodedGrid +explodeGrid' n g = M.fromList [((bigR, bigC), subGrid n g bigR bigC) | bigR <- [0..bigRm], bigC <- [0..bigCm]] + where (rm, cm) = bounds g + bigRm = (rm + 1) `div` n - 1 + bigCm = (cm + 1) `div` n - 1 + + +subGrid :: Int -> Grid -> Int -> Int -> Grid +subGrid n g bigR bigC = M.fromList [ ((r, c), + M.findWithDefault False (r + rStep, c + cStep) g) + | r <- [0..(n - 1)], c <- [0..(n - 1)] + ] + where rStep = bigR * n + cStep = bigC * n + +-- merge a set of subgrids into one +contractExploded :: ExplodedGrid -> Grid +-- contractExploded gs = foldl1 (>|<) $ map (foldl1 (>-<)) rows +contractExploded gs = foldl1 (>|<) $ parMap rpar (foldl1 (>-<)) rows + where rows = explodedRows gs + +-- find the rows of an exploded grid +explodedRows :: ExplodedGrid -> [ExplodedGrid] +explodedRows eg = [M.filterWithKey (\(r, _) _ -> r == row) eg | row <- [0..rowMax] ] + where (rowMax, _) = bounds eg + +-- merge two grids horizontally +(>-<) :: Grid -> Grid -> Grid +(>-<) g1 g2 = M.union g1 g2' + where (_, cm) = bounds g1 + g2' = M.mapKeys (\(r, c) -> (r, c + cm + 1)) g2 + +-- merge two grids vertically +(>|<) :: Grid -> Grid -> Grid +(>|<) g1 g2 = M.union g1 g2' + where (rm, _) = bounds g1 + g2' = M.mapKeys (\(r, c) -> (r + rm + 1, c)) g2 + + + + +bounds :: M.Map (Int, Int) a -> (Int, Int) +bounds grid = (maximum $ map fst $ M.keys grid, maximum $ map snd $ M.keys grid) + + +showGrid :: Grid -> String +showGrid g = unlines [[showGChar $ M.findWithDefault False (r, c) g | + c <- [0..cm] ] | r <- [0..rm] ] + where (rm, cm) = bounds g + showGChar True = '#' + showGChar False = '.' + + + +-- really persuade Megaparsec not to include newlines in how it consume spaces. +onlySpace = (char ' ') <|> (char '\t') + +sc :: Parser () +sc = L.space (skipSome onlySpace) CA.empty CA.empty + +lexeme = L.lexeme sc + +symbol = L.symbol sc +rowSep = symbol "/" +ruleJoin = symbol "=>" + +present = id True <$ symbol "#" +absent = id False <$ symbol "." + +rulesP = ruleP `sepBy` space +ruleP = Rule <$> gridP <* ruleJoin <*> gridP + +gridP = gridify <$> rowP `sepBy` rowSep + where gridify g = M.fromList $ concat + [map (\(c, v) -> ((r, c), v)) nr | + (r, nr) <- zip [0..] + [zip [0..] r | r <- g]] + + +rowP = some (present <|> absent) + +successfulParse :: Text -> [Rule] +successfulParse input = + case parse rulesP "input" input of + Left _error -> [] + Right instructions -> instructions \ No newline at end of file -- 2.34.1