```{-# LANGUAGE QuasiQuotes #-}

-- |
-- Module      : AOC.Challenge.Day10
-- Copyright   : (c) Justin Le 2018
--
-- 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           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
letterforms :: (String, String)
letterforms = ("ABCEFGHJKLNPRXZ",[here|
..##..#####..####.############.####.#....#...####....##.....#....######.#####.#....#######
.#..#.#....##....##.....#.....#....##....#....#.#...#.#.....##...##....##....##....#.....#
#....##....##.....#.....#.....#.....#....#....#.#..#..#.....##...##....##....#.#..#......#
#....##....##.....#.....#.....#.....#....#....#.#.#...#.....#.#..##....##....#.#..#.....#.
#....######.#.....#####.#####.#.....######....#.##....#.....#.#..######.#####...##.....#..
#######....##.....#.....#.....#..####....#....#.##....#.....#..#.##.....#..#....##....#...
#....##....##.....#.....#.....#....##....#....#.#.#...#.....#..#.##.....#...#..#..#..#....
#....##....##.....#.....#.....#....##....##...#.#..#..#.....#...###.....#...#..#..#.#.....
#....##....##....##.....#.....#...###....##...#.#...#.#.....#...###.....#....##....##.....
#....######..####.#######......###.##....#.###..#....########....##.....#....##....#######
|])
```