advent19/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2021/12/19/advent-of-code-2021-day-17/
   2
   3 import Data.Text ()
   4 import qualified Data.Text.IO as TIO
   5 import Data.Attoparsec.Text hiding (take, takeWhile)
   6
   7 import Linear (V3(..), (^+^), (^-^))
   8 import qualified Data.Set as S
   9 import qualified Data.MultiSet as MS
  10 import Data.Monoid
  11 import Data.Semigroup
  12 import Data.Maybe
  13 import Data.List
  14 import Control.Monad
  15
  16 type Coord = V3 Int
  17
  18 data Scanner = Scanner
  19   { scannerName :: Int
  20   , beacons :: [Coord]
  21   , transformation :: Endo Coord
  22   , signature :: MS.MultiSet Int
  23   }
  24   deriving (Show)
  25
  26 instance Eq Scanner where
  27   s1 == s2 = (scannerName s1) == (scannerName s2)
  28
  29 data Reconstruction = Reconstruction
  30   { found :: [Scanner] -- these have had the transform applied to the beacons
  31   , pending :: [Scanner] -- these have had the transform applied to the beacons
  32   , waiting :: [Scanner] -- these are as discovered
  33   }
  34   deriving (Show)
  35
  36
  37 -- Transformations
  38
  39 type Transform = Endo Coord
  40
  41 instance Show Transform where
  42   -- show c = show $ appEndo c (V3 1 2 3)
  43   show c = show $ appEndo c (V3 0 0 0)
  44
  45 nullTrans = Endo id
  46 rotX = Endo \(V3 x y z) -> V3    x (- z)   y
  47 rotY = Endo \(V3 x y z) -> V3    z    y (- x)
  48 rotZ = Endo \(V3 x y z) -> V3 (- y)   x    z
  49 translate v = Endo (v ^+^)
  50
  51 rotations :: [Transform]
  52 rotations = [a <> b | a <- ras, b <- rbs]
  53   where ras = [nullTrans, rotY, stimes 2 rotY, stimes 3 rotY, rotZ, stimes 3 rotZ]
  54         rbs = [nullTrans, rotX, stimes 2 rotX, stimes 3 rotX]
  55
  56 -- Main
  57
  58 main :: IO ()
  59 main =
  60   do  text <- TIO.readFile "data/advent19.txt"
  61       let scanners = successfulParse text
  62       let rec0 = mkReconstruction scanners
  63       let rec = reconstruct rec0
  64       let transScanners = found rec
  65       -- print scanners
  66       -- print $ findCands scanners
  67       -- print $ matchingTransform (scanners!!0) (scanners!!1)
  68       -- let rc = mkReconstruction scanners
  69       -- print $ reconstruct rc
  70       print $ part1 transScanners
  71       print $ part2 transScanners
  72
  73 part1 scanners = S.size $ S.unions $ map (S.fromList . beacons) scanners
  74
  75 part2 scanners = maximum [manhattan (a ^-^ b) | a <- origins, b <- origins]
  76   where extractOrigin sc = appEndo (transformation sc) (V3 0 0 0)
  77         origins = map extractOrigin scanners
  78         manhattan (V3 x y z) = (abs x) + (abs y) + (abs z)
  79
  80
  81 sign :: [Coord] -> MS.MultiSet Int
  82 sign bcns = MS.fromList [pythag (a ^-^ b) | a <- bcns, b <- bcns, a < b]
  83   where pythag (V3 x y z) = x^2 + y^2 + z^2
  84
  85 vagueMatch :: Scanner -> Scanner -> Bool
  86 vagueMatch scanner1 scanner2 = s >= (12 * 11) `div` 2
  87   where s = MS.size $ MS.intersection (signature scanner1) (signature scanner2)
  88
  89
  90 findCands scs = map onlyNames [(a, b) | a <- scs, b <- scs, a `vagueMatch` b]
  91   where onlyNames (sa, sb) = (scannerName sa, scannerName sb)
  92
  93
  94 matchingTransform :: Scanner -> Scanner -> Maybe Transform
  95 matchingTransform s1 s2 = listToMaybe $ matchingTransformAll s1 s2
  96
  97 matchingTransformAll :: Scanner -> Scanner -> [Transform]
  98 matchingTransformAll scanner1 scanner2 =
  99   do  let beacons1 = beacons scanner1
 100       let beacons2 = beacons scanner2
 101       rot <- rotations
 102       b1 <- beacons1
 103       b2 <- beacons2
 104       let t = b1 ^-^ (appEndo rot b2)
 105       let translation = translate t
 106       let transB2 = map (appEndo (translation <> rot)) beacons2
 107       guard $ (length $ intersect beacons1 transB2) >= 12
 108       return (translation <> rot)
 109
 110
 111 mkReconstruction :: [Scanner] -> Reconstruction
 112 mkReconstruction (s:ss) = Reconstruction {found = [], pending = [s], waiting = ss}
 113
 114 reconstruct r
 115   | null $ waiting r = Reconstruction { found = (found r) ++ (pending r), pending = [], waiting = []}
 116   | null $ pending r = r
 117   | otherwise = reconstruct $ reconstructStep r
 118
 119 reconstructStep Reconstruction{..} =
 120   Reconstruction { found = current : found
 121                  , pending = currents ++ newCurrents
 122                  , waiting = waiting'
 123                  }
 124   where (current:currents) = pending
 125         possMatches = filter (vagueMatch current) waiting
 126         matches = filter (isJust . snd) $ zip possMatches $ map (matchingTransform current) possMatches
 127         waiting' = waiting \\ (map fst matches)
 128         newCurrents = map (transformScanner) matches
 129
 130 transformScanner (Scanner{..}, trans) =
 131   Scanner { beacons = map (appEndo $ fromJust trans) beacons
 132           , transformation = fromJust trans
 133           , ..}
 134
 135
 136 -- Parse the input file
 137
 138 scannersP = scannerP `sepBy` blankLines
 139 scannerP = scannerify <$> nameP <*> beaconsP
 140   where
 141     scannerify name beacons =
 142       Scanner { scannerName = name
 143               , beacons = beacons
 144               , transformation = nullTrans
 145               , signature = sign beacons
 146               }
 147
 148 nameP = ("--- scanner " *>) decimal <* " ---" <* endOfLine
 149
 150 beaconsP = beaconP `sepBy` endOfLine
 151 beaconP = V3 <$> (signed decimal <* ",") <*> (signed decimal <* ",") <*> (signed decimal)
 152
 153 blankLines = many1 endOfLine
 154
 155 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 156 successfulParse input =
 157   case parseOnly scannersP input of
 158     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 159     Right scanners -> scanners