98 lines
3.3 KiB
Haskell
98 lines
3.3 KiB
Haskell
module Day19 where
|
|
import Data.List.Split (splitOn)
|
|
import Debug.Trace (trace, traceShow)
|
|
import Data.List (delete, transpose, maximumBy, sort, nub)
|
|
import Data.Ord (comparing)
|
|
import qualified Data.Bifunctor
|
|
|
|
type Coord = (Int,Int,Int)
|
|
|
|
add :: Coord -> Coord -> Coord
|
|
add (x,y,z) (a,b,c) = (x+a, y+b, z+c)
|
|
|
|
readScanner :: [String] -> [Coord]
|
|
readScanner [] = error "empty scanner"
|
|
readScanner (x:xs) = map pos xs where
|
|
pos line = (x,y,z) where [x,y,z] = map read $ splitOn "," line
|
|
|
|
-- shamelessly stolen from spoiler
|
|
transformCoord :: Coord -> [Coord]
|
|
transformCoord (x,y,z) = [
|
|
(x,y,z),
|
|
(-x,-y,z),
|
|
(-x,y,-z),
|
|
(x,-y,-z),
|
|
(y,z,x),
|
|
(-y,-z,x),
|
|
(-y,z,-x),
|
|
(y,-z,-x),
|
|
(z,x,y),
|
|
(-z,-x,y),
|
|
(-z,x,-y),
|
|
(z,-x,-y),
|
|
(x,z,-y),
|
|
(x,-z,y),
|
|
(-x,z,y),
|
|
(-x,-z,-y),
|
|
(y,x,-z),
|
|
(y,-x,z),
|
|
(-y,x,z),
|
|
(-y,-x,-z),
|
|
(z,y,-x),
|
|
(z,-y,x),
|
|
(-z,y,x),
|
|
(-z,-y,-x)]
|
|
|
|
deltas :: [Coord] -> [(Coord, [Coord])]
|
|
deltas coords = map (\c -> (c, deltas' c)) coords where
|
|
deltas' c = map (delta c) (c `delete` coords)
|
|
delta (x,y,z) (a,b,c) = (x-a, y-b, z-c)
|
|
|
|
findOverlap :: [Coord] -> [Coord] -> [Coord]
|
|
findOverlap sc1 sc2 = map fst $ filter (in2 . snd) d1 where
|
|
d1 = deltas sc1
|
|
d2 = concatMap snd (deltas sc2)
|
|
in2 c = any (`elem` d2) c
|
|
|
|
maxi :: (Ord a1) => [a1] -> (a1, Int)
|
|
maxi xs = maximumBy (comparing fst) (zip xs [0..])
|
|
|
|
merge :: ([Coord], [Coord]) -> ([Coord], [Coord]) -> ([Coord], [Coord])
|
|
merge (diffs, known) (overlappingNew, scanner) = (diff:diffs, nub $ sort $ known ++ map (add diff) scanner) where
|
|
overlappingOrig = findOverlap scanner known
|
|
diff = (x-nx, y-ny, z-nz) where (x,y,z) = minimum overlappingNew; (nx,ny,nz) = minimum overlappingOrig
|
|
|
|
|
|
discover :: [Coord] -> [Coord] -> [[[Coord]]] -> ([Coord], [Coord], [[[Coord]]])
|
|
discover diffs known [] = (diffs, known, [])
|
|
discover diffs known aux = trace (show (map (length.fst) bestPer)) $
|
|
if bestScore < 12 then (diffs, known, aux) else (diffs ++ fst newKnown, snd newKnown, newAux) where
|
|
overlapKnown = map (map (\x -> (findOverlap known x, x))) aux
|
|
bestPer = map (maximumBy (\x y -> compare (length $ fst x) (length $ fst y))) overlapKnown
|
|
bestScore = maximum $ map (length . fst) bestPer
|
|
scanners = filter (\scanner -> length (fst scanner) >= 12) bestPer
|
|
newKnown = foldl merge ([], known) scanners
|
|
newAux = filter (\s -> all ((`notElem` s) . snd) scanners) aux
|
|
|
|
discoverUntil :: [Coord] -> [Coord] -> [[[Coord]]] -> ([Coord], [Coord], [[[Coord]]])
|
|
discoverUntil diffs known aux = if known == known' then (diffs', known', aux') else discoverUntil diffs' known' aux' where
|
|
(diffs', known', aux') = discover diffs known aux
|
|
|
|
manhattan :: Coord -> Coord -> Int
|
|
manhattan (a,b,c) (x,y,z) = abs (a-x) + abs (b-y) + abs (c-z)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
input <- map readScanner . splitOn [""] . lines <$> getContents
|
|
|
|
let known = head input
|
|
let aux = transpose $ map (\i -> map (map (\c -> transformCoord c !! i)) (tail input)) [0..23]
|
|
|
|
let (diffs, final, aux') = discoverUntil [] known aux
|
|
|
|
putStr "part 1: "
|
|
print $ length final
|
|
|
|
putStr "part 2: "
|
|
let manhattans = concatMap (\s -> map (manhattan s) diffs) diffs
|
|
print $ maximum manhattans |