{-# LANGUAGE QuasiQuotes #-} -- | -- Module : AOC.Challenge.Day10 -- Copyright : (c) Justin Le 2018 -- License : BSD3 -- -- Maintainer : justin@jle.im -- Stability : experimental -- Portability : non-portable -- -- Day 10. See "AOC.Solver" for the types used in this module! module AOC.Challenge.Day10 ( day10a , day10b , centralize ) where import AOC.Common (clearOut, boundingBox) import AOC.Solver ((:~>)(..)) import Control.Monad (guard) import Data.Bifunctor (second) import Data.Char (isDigit) import Data.Foldable (foldMap) import Data.List (unfoldr, uncons) import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Semigroup (Sum(..)) import Data.Set (Set) import Linear (V2(..)) import Text.Heredoc (here) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Set.NonEmpty as NES import qualified Linear as L type Point = V2 Double type Lattice = V2 Int -- | Shift so that centroid is at zero centralize :: [Point] -> [Point] centralize ps = map (subtract mean) ps where (Sum tot, Sum len) = foldMap (\x -> (Sum x, Sum 1)) ps mean = tot L.^/ len -- | Multiply and find trace traceMul :: [Point] -> [Point] -> Double traceMul xs ys = sum $ zipWith L.dot xs ys findWord :: [Point] -- ^ velocities -> [Point] -- ^ points -> (Set Lattice, Int) -- ^ points in word, and # of iterations findWord (centralize->vs) (centralize->xs) = (S.fromList ((map . fmap) round final), round t) where t = negate $ traceMul xs vs / traceMul vs vs final = zipWith (\v x -> x + t L.*^ v) vs xs day10a :: ([Point], [Point]) :~> Set Lattice day10a = MkSol { sParse = fmap unzip . traverse parsePoint . lines , sShow = parseResult , sSolve = Just . fst . uncurry findWord } day10b :: ([Point], [Point]) :~> Int day10b = MkSol { sParse = fmap unzip . traverse parsePoint . lines , sShow = show , sSolve = Just . snd . uncurry findWord } -- | New solution: Parse the set of points into a string, based on -- 'letterforms'. parseResult :: Set Lattice -> String parseResult ps = case M.lookup letter letterMap of Nothing -> [] Just c -> c : parseResult rest where origin `V2` _ = boundingBox . NES.unsafeFromSet $ ps shiftedPs = subtract origin `S.map` ps (letter, rest) = S.partition (\(V2 x y) -> x < 6 && y < 10) shiftedPs parsePoint :: String -> Maybe (Point, Point) parsePoint xs = case map read . words . clearOut p $ xs of [x,y,vx,vy] -> Just (V2 vx vy, V2 x y) _ -> Nothing where p '-' = False p c = not $ isDigit c -- | A map of a set of "on" points (for a 6x10 grid) to the letter -- they represent letterMap :: Map (Set Lattice) Char letterMap = M.fromList . unfoldr (uncurry peel) . second (filter (not . null) . lines) $ letterforms where peel :: String -> [String] -> Maybe ((Set Lattice, Char), (String, [String])) peel cs ls = do (d,ds) <- uncons cs let (m,ms) = unzip . map (splitAt 6) $ ls pointMap = S.fromList . foldMap catMaybes . zipWith (\j -> zipWith (\i c -> V2 i j <$ guard (c == '#')) [0..] ) [0..] $ m pure ((pointMap, d), (ds, ms)) -- | All known letterforms. Based on -- <https://gist.github.com/usbpc/5fa0be48ad7b4b0594b3b8b029bc47b4>. letterforms :: (String, String) letterforms = ("ABCEFGHJKLNPRXZ",[here| ..##..#####..####.############.####.#....#...####....##.....#....######.#####.#....####### .#..#.#....##....##.....#.....#....##....#....#.#...#.#.....##...##....##....##....#.....# #....##....##.....#.....#.....#.....#....#....#.#..#..#.....##...##....##....#.#..#......# #....##....##.....#.....#.....#.....#....#....#.#.#...#.....#.#..##....##....#.#..#.....#. #....######.#.....#####.#####.#.....######....#.##....#.....#.#..######.#####...##.....#.. #######....##.....#.....#.....#..####....#....#.##....#.....#..#.##.....#..#....##....#... #....##....##.....#.....#.....#....##....#....#.#.#...#.....#..#.##.....#...#..#..#..#.... #....##....##.....#.....#.....#....##....##...#.#..#..#.....#...###.....#...#..#..#.#..... #....##....##....##.....#.....#...###....##...#.#...#.#.....#...###.....#....##....##..... #....######..####.#######......###.##....#.###..#....########....##.....#....##....####### |])