initial commit

1 files changed, 306 insertions, 0 deletions

diff --git a/2020/20b.hs b/2020/20b.hs
new file mode 100644
index 0000000..7bce210
--- /dev/null
+++ b/2020/20b.hs
@@ -0,0 +1,306 @@
+{-# LANGUAGE TupleSections #-}
+
+module Day20B where
+
+import Data.Maybe (isNothing, isJust)
+import Data.List (transpose, sortOn, nub)
+import Data.List.Split (splitOn)
+import System.Environment (getArgs)
+import qualified Data.Map.Strict as M
+import Text.Printf (printf)
+import Debug.Trace (trace)
+
+-- Types
+
+-- (y, x)
+type Tile = [[Bool]];
+type TileWithId = (Int, Tile);
+type Coord = (Int, Int);
+type Grid = M.Map Coord TileWithId;
+
+-- Flip Vertical, Rotations (0-3)
+data Orientation = Transform Bool Int;
+
+orients :: [Orientation]
+orients = [Transform f r | f <- [True, False], r <- [0..3]]
+
+-- top, left, right, bottom
+data Side = T | L | R | B
+        deriving (Show, Eq);
+
+sides :: [Side]
+sides = [T, L, R, B]
+
+complement :: Side -> Side
+complement T = B
+complement B = T
+complement L = R
+complement R = L
+
+-- Tile manipulation
+rotate :: Tile -> Tile
+rotate = transpose . reverse
+
+rotateN :: Int -> Tile -> Tile
+rotateN 0 t = t
+rotateN n t = rotateN (n - 1) (rotate t)
+
+reorient :: Orientation -> Tile -> Tile
+reorient (Transform False n) = rotateN n
+reorient (Transform True n) = rotateN n . reverse
+
+permutations :: Tile -> [Tile]
+permutations t = [reorient o t | o <- orients]
+
+--- Side / Edge manipulation
+-- Get the border on the given side of the tile
+border :: Side -> Tile -> [Bool]
+border T t = head t
+border B t = last t
+border L t = map head t
+border R t = map last t
+
+-- Get all borders of a given tile
+borders :: Tile -> [[Bool]]
+borders t = map (`border` t) sides
+
+-- Get the coord at the given side of that coord
+getSideCoord :: Coord -> Side -> Coord
+getSideCoord (x, y) T = (x, y - 1)
+getSideCoord (x, y) B = (x, y + 1)
+getSideCoord (x, y) L = (x - 1, y)
+getSideCoord (x, y) R = (x + 1, y)
+
+-- Return true if y is on the s of x
+checkBorder :: Tile -> Tile -> Side -> Bool
+checkBorder x y s = border (complement s) y == border s x
+
+-- y is on the s of x (if it exists)
+attemptCheckBorder :: Tile -> Maybe Tile -> Side -> Bool
+attemptCheckBorder _ Nothing _ = True
+attemptCheckBorder x (Just y) s = checkBorder x y s
+
+--- Grid manipulations
+
+-- Get the bounds of the grid
+-- Returns (low, high)
+squareBounds :: M.Map Coord a -> (Coord, Coord)
+squareBounds g = (M.foldrWithKey (compCoord min) (0, 0) g,
+                     M.foldrWithKey (compCoord max) (0, 0) g)
+    where compCoord f (x', y') _ (x, y) = (f x' x, f y' y)
+
+-- Get the corners of the grid
+getCorners :: Grid -> [Coord]
+getCorners g = [(lx, ly), (lx, hy), (hx, ly), (hx, hy)]
+            where ((lx, ly), (hx, hy)) = squareBounds g
+
+-- Returns true if the grid is rectangular
+isRect :: Grid -> Bool
+isRect g = all (isJust . (g M.!?)) (getCorners g)
+
+-- Return true if given side is unfilled for coord of grid
+sideIsUnfilled :: Side -> Grid -> Coord -> Bool
+sideIsUnfilled s g c = isNothing $ M.lookup (getSideCoord c s) g
+
+--- Checking and solving
+fitsSpace :: Grid -> Coord -> Tile -> Bool
+fitsSpace g c t = and [attemptCheckBorder t (maybeNoDefault snd $ M.lookup (getSideCoord c s) g) s | s <- sides]
+
+-- Returns tiles that could be on the given side of the given coord
+possibleNeighbours :: [TileWithId] -> Grid -> Coord -> Side -> [TileWithId]
+possibleNeighbours ts g c s = filter (fitsSpace g c' . snd) ts
+                                where c' = getSideCoord c s
+
+-- Check if the entire grid is valid
+isValid :: Grid -> Bool
+isValid m = M.foldrWithKey checkSquare True m
+              where checkSquare l (_, t) v = v && fitsSpace m l t
+
+-- Add to the given side of each coord, returning all possible ways to do so and the remaining tiles from each.
+fillSideOnce :: Side -> [TileWithId] -> Grid -> [([TileWithId], Grid)]
+fillSideOnce _ [] m = [([], m)]
+fillSideOnce s xs m | null mutations = [(xs, m)]
+                    | otherwise = mutatedMaps
+            where mutations :: [(Coord, [TileWithId])] -- list of squares to mutate, and possibilities
+                  mutations = filter (not . null . snd) $ map getNextFill $ M.toList m
+                  getNextFill :: (Coord, TileWithId) -> (Coord, [TileWithId])
+                  getNextFill (c, _) | sideIsUnfilled s m c = (getSideCoord c s, possibleNeighbours xs m c s)
+                                     | otherwise = (getSideCoord c s, [])
+                  attempts :: [[(Coord, TileWithId)]] -- All the possible lists of mutations we can make
+                  attempts = filter (allUnique . map (fst . snd)) $ map (zip $ map fst mutations) (oneFromEach $ map snd mutations)
+                  mutatedMaps :: [([TileWithId], Grid)] -- new remaining tiles, new grid
+                  mutatedMaps = map doAllMutations attempts 
+                  doAllMutations :: [(Coord, TileWithId)] -> ([TileWithId], Grid)
+                  doAllMutations = foldr mutateMap (xs, m)
+                  mutateMap :: (Coord, TileWithId) -> ([TileWithId], Grid) -> ([TileWithId], Grid)
+                  mutateMap (newC, (newId, newTile)) (re, grid) = (filter ((/= newId) . fst) re, M.insert newC (newId, newTile) grid)
+
+fillRect :: [([TileWithId], Grid)] -> [([TileWithId], Grid)]
+fillRect xs | not (null fullSols) = fullSols
+            | otherwise = fillRect $ filter (not . (`elem` xs)) $ foldr (\s ps -> concatMap (uncurry $ fillSideOnce s) ps) xs sides
+          where fullSols = filter (null . fst) xs
+
+-- Pattern matching
+type Pattern = [Coord] -- List of coord offsets that must be set.
+
+data Square = Empty | Filled | Highlight
+  deriving (Eq, Show);
+type PlainGrid = M.Map Coord [[Square]]
+
+toSquare :: Bool -> Square
+toSquare True = Filled
+toSquare False = Empty
+
+monsterPattern :: Pattern
+monsterPattern = [
+  (0, 1),
+  (1, 2),
+  (4, 2),
+  (5, 1),
+  (6, 1),
+  (7, 2),
+  (10, 2),
+  (11, 1),
+  (12, 1),
+  (13, 2),
+  (16, 2),
+  (17, 1),
+  (18, 0),
+  (18, 1),
+  (19, 1)
+  ]
+
+patternAt :: Pattern -> Coord -> [Coord]
+patternAt p c = map (addCoord c) p
+
+-- Get the value at a specific coord
+getSpecificCoord :: PlainGrid -> Coord -> Maybe Square
+getSpecificCoord g (x, y) = getFromTile $ g M.!? (x `div` tileSize, y `div` tileSize)
+                              where tileSize = length $ g M.! (0, 0)
+                                    getFromTile Nothing = Nothing
+                                    getFromTile (Just t) = Just $ t!!(y `mod` tileSize)!!(x `mod` tileSize)
+
+-- Set the value at a specific coord
+setSpecificCoord :: PlainGrid -> Coord -> Square -> PlainGrid
+setSpecificCoord g (x, y) b = M.insert (tx, ty) t' g
+                                where tileSize = length $ g M.! (0, 0)
+                                      (tx, ty) = (x `div` tileSize, y `div` tileSize)
+                                      (sx, sy) = (x `mod` tileSize, y `mod` tileSize)
+                                      t = g M.! (tx, ty)
+                                      r = t!!sy
+                                      r' = take sx r ++ [b] ++ drop (sx + 1) r
+                                      t' = take sy t ++ [r'] ++ drop (sy + 1) t
+
+-- Returns true if the pattern is true at the given coord
+patternTrueAt :: PlainGrid -> Coord -> Pattern -> Bool
+patternTrueAt g b = all (areSet . addCoord b)
+                      where areSet c = case getSpecificCoord g c of
+                                         Just Filled -> True
+                                         Just Highlight -> True
+                                         _ -> False
+
+-- Strip all borders from all tiles
+stripBorders :: Grid -> PlainGrid
+stripBorders = M.map strip
+                 where strip (_, t) = map (map toSquare . init . tail) $ init $ tail t
+
+-- Find all occurences of a pattern
+findAllOccs :: PlainGrid -> Pattern -> [Coord]
+findAllOccs g p = trace (show (lx, hy, hx, hy)) $ filter (\c -> patternTrueAt g c p) $ [(x, y) | x <- [lx..hx], y <- [ly..hy]]
+                    where ((ltx, lty), (htx, hty)) = squareBounds g
+                          tileSize = length $ head $ g M.! (0, 0)
+                          (lx, ly) = (ltx * tileSize, lty * tileSize)
+                          (hx, hy) = ((htx + 1) * tileSize, (hty + 1) * tileSize)
+
+-- runghc --ghc-arg='-package split' --ghc-arg='-package extra' 20a.hs inputs/day20
+main :: IO ()
+main = do 
+        args <- getArgs;
+        ((si, st):ts) <- parseFile (head args);
+
+        -- Expand the tiles to include all orientations
+        let ts' = concatMap (\(i, t) -> map (i,) $ permutations t) ts;
+        printf "%d possible tiles\n" (length ts');
+
+        -- Get our starting states
+        let starting = [(ts', M.singleton (0, 0) (si, t')) | t' <- permutations st];
+
+        -- Get the first solution that uses all tiles
+        let imgs = map snd $ filter (null . fst) $ fillRect starting;
+
+        printf "Found %d images\n" (length imgs);
+
+        -- Remove border tiles
+        let imgs' = map stripBorders imgs;
+
+        -- Find the monsters
+        let ((df, ms):_) = sortOn ((0 -) . length . snd) $ map (\img -> (img, findAllOccs img monsterPattern)) imgs';
+
+        printf "Found, at most, %d monsters\n" (length ms);
+
+        -- Delete all tiles part of a monster
+        let tiles = concatMap (patternAt monsterPattern) ms;
+        let img' = foldr (\c i -> setSpecificCoord i c Highlight) df tiles;
+        
+        putStr $ prettyPrint img';
+
+        let answer = length $ filter (== Filled) $ concatMap (concat . snd) $ M.toList img';
+        printf "Tiles remaining = %d\n" answer;
+        return ();
+
+-- Utilities
+maybeNoDefault :: (a -> b) -> Maybe a -> Maybe b
+maybeNoDefault _ Nothing = Nothing
+maybeNoDefault f (Just x) = Just (f x)
+
+unwrap :: Maybe a -> a
+unwrap (Just x) = x
+unwrap _ = error "unwrap on null value"
+
+addCoord :: Coord -> Coord -> Coord
+addCoord (x, y) (x', y') = (x + x', y + y')
+
+-- Get all possible combinations by picking one element from each of the sublists
+oneFromEach :: [[a]] -> [[a]]
+oneFromEach [] = [[]]
+oneFromEach (xs:xss) = concat $ [ map (x : ) (oneFromEach xss) | x <- xs]
+
+allUnique :: Eq a => [a] -> Bool
+allUnique xs = length (nub xs) == length xs
+
+-- Pretty printing
+prettyPrintIds :: PlainGrid -> String
+prettyPrintIds grid = unlines [concatMap show (getRow y) | y <- [lyc..hyc]]
+        where ((_, lyc), (_, hyc)) = squareBounds grid
+              getRow y = map fst $ M.toAscList $ M.filterWithKey (\(_, y') _ -> y' == y) grid
+
+prettyPrint :: PlainGrid -> String
+prettyPrint grid = concat [unlines $ printTiles (getRow y) | y <- [lyc..hyc]]
+        where tileSize = length (grid M.! (0, 0))
+              ((_, lyc), (_, hyc)) = squareBounds grid
+              getRow y = map snd $ M.toAscList $ M.filterWithKey (\(_, y') _ -> y' == y) grid
+              printTiles ts = [concatMap (rowToStr . (!!y)) ts | y <- [0..tileSize - 1]]
+
+rowToStr :: [Square] -> String
+rowToStr [] = ""
+rowToStr (Filled:xs) = '#' : rowToStr xs
+rowToStr (Empty:xs) = '.' : rowToStr xs
+rowToStr (Highlight:xs) = 'O' : rowToStr xs
+
+-- Parsing
+parseTileDef :: String -> (Int, Tile)
+parseTileDef s = (read n, map readLine ls)
+        where (f:ls) = lines s
+              n = drop 5 $ take (length f - 1) f
+              readLine [] = []
+              readLine ('.':xs) = False : readLine xs
+              readLine ('#':xs) = True : readLine xs
+              readLine _ = error "invalid input"
+
+parseInput :: String -> [(Int, Tile)]
+parseInput = map parseTileDef . splitOn "\n\n"
+
+parseFile :: String -> IO [(Int, Tile)]
+parseFile f = do
+                c <- readFile f
+                return $ parseInput c;
\ No newline at end of file