From 833fcf24d661ef600d00c017ce7796b2fc938a17 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Sun, 27 Dec 2020 14:09:22 +0100
Subject: Day 20

---
 2020/20.hs | 224 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 224 insertions(+)
 create mode 100644 2020/20.hs

(limited to '2020/20.hs')

diff --git a/2020/20.hs b/2020/20.hs
new file mode 100644
index 0000000..73ebef5
--- /dev/null
+++ b/2020/20.hs
@@ -0,0 +1,224 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+module Main (main, showLayout) where
+
+import Data.List (sortBy, transpose, intercalate, tails)
+import Data.Foldable (toList)
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict (Map)
+import Data.Maybe (catMaybes, listToMaybe, fromJust)
+import Data.Ord (Down(..), comparing)
+import qualified Data.Set as Set
+import Data.Set (Set)
+
+import Input
+import Util
+
+
+data V4 a = V4 a a a a
+  deriving (Show, Functor)
+
+instance Applicative V4 where
+    pure x = V4 x x x x
+    V4 f1 f2 f3 f4 <*> V4 x1 x2 x3 x4 = V4 (f1 x1) (f2 x2) (f3 x3) (f4 x4)
+
+instance Foldable V4 where
+    foldr f z (V4 a b c d) = f a (f b (f c (f d z)))
+
+ifmap :: (Int -> a -> b) -> V4 a -> V4 b
+ifmap f (V4 a b c d) = fmap (uncurry f) (V4 (0, a) (1, b) (2, c) (3, d))
+
+(!*) :: V4 a -> Int -> a
+V4 a b c d !* i = [a, b, c, d] !! i
+
+data B = F | T
+  deriving (Eq, Ord)
+
+instance Show B where
+    show F = "."
+    show T = "#"
+
+newtype Border' a = Border { unBorder :: [a] }
+  deriving (Eq, Ord, Functor)
+type Border = Border' B
+
+instance Show a => Show (Border' a) where
+    show (Border l) =
+        let l' = map show l
+        in if all ((== 1) . length) l' then concat l' else show l
+
+data Rotation = R Int B  -- rotated n, then possibly horizontally flipped
+  deriving (Show)
+
+data Tile' a = Tile Int Rotation (V4 (Border' a)) [[a]]
+  deriving (Functor)
+
+type Tile = Tile' B
+
+instance Show a => Show (Tile' a) where
+    showsPrec p (Tile i r v _) = showParen (p > 10) (showString ("Tile " ++ show i ++ " (" ++ show r ++ ") ") . showsPrec 11 v . showString " {...}")
+
+boolb :: Bool -> B
+boolb True = T
+boolb False = F
+
+notB :: B -> B
+notB F = T
+notB T = F
+
+tileID :: Tile -> Int
+tileID (Tile i _ _ _) = i
+
+parseTile :: [String] -> Tile
+parseTile [] = error "empty tile"
+parseTile (hdr:lns) =
+    fmap (boolb . (== '#')) $
+         Tile (if take 5 hdr == "Tile " then read (take 4 (drop 5 hdr)) else error ("tile header?" ++ show hdr))
+              (R 0 F)
+              (V4 (Border (head lns))
+                  (Border (map last lns))
+                  (Border (reverse (last lns)))
+                  (Border (reverse (map head lns))))
+              lns
+
+-- Rotates clockwise 90 degrees
+rotArray :: [[a]] -> [[a]]
+rotArray = map reverse . transpose
+
+-- Flips horizontally
+flipArray :: [[a]] -> [[a]]
+flipArray = map reverse
+
+-- Rotates clockwise 90 degrees
+rotate :: Tile -> Tile
+rotate (Tile i (R rotn rotf) (V4 a b c d) e) = Tile i (R (rotn+1) rotf) (V4 d a b c) (rotArray e)
+
+-- Flips horizontally
+flipTile :: Tile -> Tile
+flipTile (Tile i (R rotn rotf) (V4 (Border a) (Border b) (Border c) (Border d)) e) =
+    Tile i (R rotn (notB rotf)) (V4 (Border (reverse a)) (Border (reverse d)) (Border (reverse c)) (Border (reverse b))) (flipArray e)
+
+type Cd = (Int, Int)  -- coordinate
+
+data Layout = Layout (Map Cd Tile) (Set Cd)
+  deriving (Show)
+
+lput :: Cd -> Tile -> Layout -> Layout
+lput pos tile (Layout mp bd) =
+    Layout (Map.insertWith (error "lput: taken") pos tile mp)
+           (Set.delete pos bd <> (Set.fromList (toList (neighbours pos)) Set.\\ Map.keysSet mp))
+
+neighbours :: Cd -> V4 Cd
+neighbours (x, y) = V4 (x, y-1) (x+1, y) (x, y+1) (x-1, y)
+
+borderAt :: Cd -> Layout -> V4 (Maybe Border)
+borderAt pos (Layout mp _) =
+    ifmap (\i pos' -> (\(Tile _ _ bd _) -> Border (reverse (unBorder (bd !* mod (i + 2) 4)))) <$> Map.lookup pos' mp) (neighbours pos)
+
+densityAt :: Layout -> Cd -> Int
+densityAt ly pos = length (catMaybes (toList (borderAt pos ly)))
+
+matchesOutline :: Tile -> V4 (Maybe Border) -> Bool
+matchesOutline (Tile _ _ bd _) outl =
+    all id ((\b -> maybe True (== b)) <$> bd <*> outl)
+
+rotrefls :: Tile -> [Tile]
+rotrefls = concatMap (\t -> [t, flipTile t]) . take 4 . iterate rotate
+
+matchesAtPos :: Layout -> [Tile] -> Cd -> [(Tile, [Tile])]
+matchesAtPos ly ts pos =
+    [(t', rest)
+    | (t, rest) <- splits' ts
+    , t' <- rotrefls t
+    , matchesOutline t' (borderAt pos ly)]
+
+allCandidates :: Layout -> [Tile] -> [(Cd, Tile, [Tile])]
+allCandidates ly@(Layout _ bd) ts =
+    catMaybes
+        [case matchesAtPos ly ts pos of
+           [(t, ts')] -> Just (pos, t, ts')
+           _ -> Nothing
+        | pos <- sortBy (comparing (Down . densityAt ly)) (toList bd)]
+
+findCandidate :: Layout -> [Tile] -> Maybe (Cd, Tile, [Tile])
+findCandidate ly ts = listToMaybe (allCandidates ly ts)
+
+placeAll :: Layout -> [Tile] -> (Layout, [Tile])
+placeAll ly ts
+  | Just (pos, t, ts') <- findCandidate ly ts = placeAll (lput pos t ly) ts'
+  | otherwise = (ly, ts)
+
+extents :: Map Cd a -> ((Int, Int), (Int, Int))
+extents mp =
+    let keys = Map.keys mp
+    in ((minimum (map fst keys), maximum (map fst keys))
+       ,(minimum (map snd keys), maximum (map snd keys)))
+
+showLayout :: Layout -> String
+showLayout (Layout mp bd) =
+    let mp' = foldr (uncurry Map.insert) (Map.map Just mp) (map (,Nothing) (toList bd))
+        ((xmin, xmax), (ymin, ymax)) = extents mp'
+    in unlines [intercalate " "
+                    [maybe "...." (maybe "----" (show . tileID)) (Map.lookup (x, y) mp')
+                    | x <- [xmin..xmax]]
+               | y <- [ymin..ymax]]
+
+cornerProd :: Layout -> Int
+cornerProd (Layout mp _) =
+    let ((xmin, xmax), (ymin, ymax)) = extents mp
+    in product (map (tileID . fromJust . (`Map.lookup` mp)) [(xmin,ymin), (xmin,ymax), (xmax,ymin), (xmax,ymax)])
+
+squareOfTiles :: Layout -> [[Tile]]
+squareOfTiles (Layout mp _) =
+    let ((xmin, xmax), (ymin, ymax)) = extents mp
+    in [[mp Map.! (x, y) | x <- [xmin..xmax]] | y <- [ymin..ymax]]
+
+removeEdges :: [[B]] -> [[B]]
+removeEdges = map trim . trim
+  where trim = tail . reverse . tail . reverse
+
+joinEdges :: [[Tile]] -> [[B]]
+joinEdges tiles =
+    concat [map concat (transpose [removeEdges body | Tile _ _ _ body <- tilerow])
+           | tilerow <- tiles]
+
+monster :: [[B]]
+monster = map (map (\case '#' -> T ; ' ' -> F ; _ -> undefined)) pat
+  where pat = ["                  # "
+              ,"#    ##    ##    ###"
+              ," #  #  #  #  #  #   "]
+
+fieldParts :: [[a]] -> [[[a]]]
+fieldParts bd = concatMap maptails (tails bd)
+  where maptails [] = []
+        maptails ([]:_) = []
+        maptails l = l : maptails (map tail l)
+
+exceedsLength :: [a] -> [a] -> Bool
+_ `exceedsLength` [] = True
+[] `exceedsLength` _ = False
+(_:xs) `exceedsLength` (_:ys) = xs `exceedsLength` ys
+
+matchPattern :: [[B]] -> [[B]] -> Bool
+matchPattern bd pat =
+    bd `exceedsLength` pat &&
+        all (\(bdrow, patrow) -> bdrow `exceedsLength` patrow &&
+                                    all (\(b, p) -> (p == F) || (b == T)) (zip bdrow patrow))
+            (zip bd pat)
+
+countPattern :: [[B]] -> [[B]] -> Int
+countPattern bd pat = length (filter (`matchPattern` pat) (fieldParts bd))
+
+numTrue :: [[B]] -> Int
+numTrue = length . concat . map (filter (== T))
+
+main :: IO ()
+main = do
+    tile0:tiles <- map parseTile . filter (not . null) . toList . splitOn null <$> getInput 20
+    let initLayout = lput (0, 0) tile0 (Layout mempty (Set.singleton (0, 0)))
+        (ly', _) = placeAll initLayout tiles
+    print (cornerProd ly')
+    let image = joinEdges (squareOfTiles ly')
+        images = concatMap (\b -> [b, flipArray b]) (take 4 (iterate rotArray image))
+    print (numTrue image - numTrue monster * maximum (map (`countPattern` monster) images))
-- 
cgit v1.2.3-54-g00ecf