Day 19

src/AOC-19b.hs

 module Main where
 
+import Control.Monad ( void )
+import Data.Array ( (!), array, Array )
+import Data.Char ( isDigit )
+import Data.List ( uncons )
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Text.ParserCombinators.ReadP
+    ( char, munch1, option, readP_to_S, sepBy, skipSpaces, string, ReadP )
+
+newtype Position = Position { getCoordinates :: (Int,Int,Int) }
+  deriving (Eq,Ord)
+data ScannerData = ScannerData { scanId :: Int, scanner :: Position, beacons :: [Position] }
+data Scanners = Scanners { sdlist :: [ScannerData] }
+
+origin :: Position
+origin = Position (0,0,0)
+
+parseInt :: ReadP Int
+parseInt = do
+  sig <- option 1 (char '-' *> pure (-1))
+  mag <- read <$> munch1 isDigit
+  pure $ sig * mag
+
+parsePosition :: ReadP Position
+parsePosition = do
+  x <- parseInt
+  void $ char ','
+  y <- parseInt
+  void $ char ','
+  z <- parseInt
+  pure $ Position (x,y,z)
+
+parseScannerData :: ReadP ScannerData
+parseScannerData = do
+  void $ string "--- scanner "
+  n <- parseInt
+  void $ string " ---"
+  skipSpaces
+  bs <- parsePosition `sepBy` skipSpaces
+  pure $ ScannerData n origin bs
+
+parseScanners :: ReadP Scanners
+parseScanners = Scanners <$> parseScannerData `sepBy` skipSpaces
+
+instance Show ScannerData where
+  show (ScannerData n _ bs) =
+    unlines $ header : map showBeacon bs
+    where
+    header = "--- scanner " ++ show n ++ " ---"
+    showBeacon (Position (x,y,z)) = show x ++ "," ++ show y ++ "," ++ show z
+
+instance Read Scanners where
+  readsPrec _ = readP_to_S parseScanners
+
+instance Show Scanners where
+  show (Scanners sds) = unlines . map show $ sds
+
+--- These will all be 3x3, ((1,1),(3,3)).
+
+data Rotation = Rotation { matrix :: Array (Int,Int) Int }
+  deriving (Eq,Ord)
+
+rotationBounds :: ((Int,Int),(Int,Int))
+rotationBounds = ((1,1),(3,3))
+
+mkRotation :: [Int] -> Rotation
+mkRotation = Rotation . array rotationBounds . zip indicies where
+  indicies = [(x,y) | y <- [1..3], x <- [1..3]]
+
+infix 7 .*.
+(.*.) :: Rotation -> Rotation -> Rotation
+Rotation a .*. Rotation b = Rotation c where
+  c = array ((1,1),(3,3)) [((x,z),cval x z) | x <- [1..3], z <- [1..3]]
+  cval x z = sum [(a ! (x,y)) * (b ! (y,z)) | y <- [1..3]]
+
+instance Show Rotation where
+  show (Rotation arr) = 
+    unlines . map unwords $ [ map show [arr ! (1,y), arr ! (2,y), arr ! (3,y)] | y <- [1..3]]
+
+identity :: Rotation
+identity = mkRotation
+  [ 1, 0, 0
+  , 0, 1, 0
+  , 0, 0, 1
+  ]
+
+rot90x :: Rotation
+rot90x = mkRotation
+  [ 1,  0,  0
+  , 0,  0, -1
+  , 0,  1,  0
+  ]
+
+rot90y :: Rotation
+rot90y = mkRotation
+  [  0,  0,  1
+  ,  0,  1,  0
+  , -1,  0,  0
+  ]
+
+uniq :: Ord a => [a] -> [a]
+uniq = S.toList . S.fromList
+
+rotations :: [Rotation]
+rotations = iter [identity] where
+  iter arrs
+    | arrs == arrs' = arrs'
+    | otherwise = iter arrs'
+    where
+    arrs' = uniq $ arrs ++ [ a .*. b | a <- arrs, b <- [rot90x,rot90y]]
+
+class Coordinatized c where
+  rotateBy :: c -> Rotation -> c
+  translateBy :: c -> Position -> c
+
+instance Coordinatized Position where
+  Position (x,y,z) `rotateBy` Rotation arr = Position (f 1, f 2, f 3) where
+    f n = x * (arr ! (1,n)) + y * (arr ! (2,n)) + z * (arr ! (3,n))
+  Position (x,y,z) `translateBy` Position (a,b,c) = Position (x+a,y+b,z+c)
+
+instance Coordinatized ScannerData where
+  ScannerData ix c bs `rotateBy` rot = ScannerData ix (c `rotateBy` rot) ((`rotateBy` rot) <$> bs) 
+  ScannerData ix c bs `translateBy` tr = ScannerData ix (c `translateBy` tr) ((`translateBy` tr) <$> bs)
+
+distance :: Position -> Position -> Int
+distance (Position (x1,y1,z1)) (Position (x2,y2,z2)) =
+  abs (x1-x2) + abs (y1-y2) + abs (z1-z2)
+
+allPairs :: [a] -> [(a,a)]
+allPairs []  = []
+allPairs (a:as) = (((,) a) <$> as) ++ allPairs as
+
+overlay :: ScannerData -> ScannerData -> [ScannerData]
+overlay as bs = hits where
+  offsets = M.unionsWith (+)
+    [ M.singleton (ax-bx,ay-by,az-bz) (1::Int)
+    | Position (ax,ay,az) <- beacons as
+    , Position (bx,by,bz) <- beacons bs
+    ]
+  hits = [ bs `translateBy` Position p
+         | (p,v) <- M.assocs offsets
+         , v >= 12
+         ]
+
+overlays :: ScannerData -> ScannerData -> [ScannerData]
+overlays a b = concatMap (overlay a) . map (b `rotateBy`) $ rotations
+
+piece :: [ScannerData] -> ScannerData -> Maybe ScannerData
+piece targets source = fst <$> uncons hits where
+  hits = do
+    t <- targets
+    rot <- rotations
+    let s = source `rotateBy` rot
+    overlay t s
+
+-- the output scanners will all be in the coordinate system of the first scanner.
+
+assembleBeacons :: Scanners -> [ScannerData]
+assembleBeacons (Scanners scanners) = iter [head scanners] [] [] (tail scanners) where
+  iter :: [ScannerData] -> [ScannerData] -> [ScannerData] -> [ScannerData] -> [ScannerData]
+    -- frontier newFrontier unpieced pending
+  iter frontier [] [] [] = frontier
+  iter frontier newFrontier unpieced [] = 
+    frontier ++ iter newFrontier [] [] (reverse unpieced)
+  iter frontier newFrontier unpieced (next:rest) = case piece frontier next of
+    Nothing -> iter frontier newFrontier (next:unpieced) rest
+    Just b -> iter frontier (b:newFrontier) unpieced rest
+
 main :: IO ()
-main = pure ()
+main = do 
+  sd <- read @Scanners <$> readFile "data/beacons.txt"
+  let scanners = map scanner . assembleBeacons $ sd
+      result = maximum [distance a b | (a,b) <- allPairs scanners]
+  print result
+
+{-
+  17801 too high
+-}
\ No newline at end of file

src/AOC-25a.hs

 module Main where
 
+import Data.Array
+
+data Herd = None | East | South
+    deriving Eq
+
+type SeaCucumberArray = Array (Int,Int) Herd
+
+instance Show Herd where
+    show None = "."
+    show East = ">"
+    show South = "v"
+
+makeSeaCucumberArray :: String -> SeaCucumberArray
+makeSeaCucumberArray s =
+    array ((1,1),(xMax,yMax))
+        [ ((x,y),charToCuke c) 
+        | (y,row) <- zip [1..] rows
+        , (x,c) <- zip [1..] row 
+        ]
+    where
+    charToCuke '.'= None
+    charToCuke '>' = East
+    charToCuke 'v' = South
+    charToCuke _ = error "charToCuke -- unknown character"
+    rows = lines s
+    yMax = length rows
+    xMax = length (head rows)
+
+showSeaCucumberArray :: SeaCucumberArray -> String 
+showSeaCucumberArray arr = unlines 
+    [ [ head $ show h | x <- [1..xMax], let h = arr Data.Array.! (x,y)]
+    | y <- [1..yMax]
+    ]
+    where
+    (xMax,yMax) = snd . bounds $ arr
+
+moveEast :: SeaCucumberArray -> SeaCucumberArray
+moveEast arr = array (bounds arr) [ (p, v p) | p <- range (bounds arr)] where
+    (xMax,_) = snd . bounds $ arr
+    v p
+        | arr ! p == None && arr ! west p == East = East
+        | arr ! p == East && arr ! east p == None = None
+        | otherwise = arr ! p
+    west (x,y)
+        | x > 1 = (x-1,y)
+        | otherwise = (xMax,y)
+    east (x,y)
+        | x < xMax = (x+1,y)
+        | otherwise = (1,y)
+
+moveSouth :: SeaCucumberArray -> SeaCucumberArray
+moveSouth arr = array (bounds arr) [ (p, v p) | p <- range (bounds arr)] where
+    (_,yMax) = snd . bounds $ arr
+    v p
+        | arr ! p == None && arr ! north p == South = South
+        | arr ! p == South && arr ! south p == None = None
+        | otherwise = arr ! p
+    north (x,y)
+        | y > 1 = (x,y-1)
+        | otherwise = (x,yMax)
+    south (x,y)
+        | y < yMax = (x,y+1)
+        | otherwise = (x,1)
+
+step :: SeaCucumberArray -> SeaCucumberArray
+step = moveSouth . moveEast
+
+stationary :: SeaCucumberArray -> Int 
+stationary arr = iter . zip [1..] . iterate step $ arr where
+    iter ((n,a): rest@((_',b) : _ ))
+        | a == b = n
+        | otherwise = iter rest
+    iter _ = error "stationary.iter -- out of list"
+
 main :: IO ()
-main = pure ()
+main = do
+    scca <- makeSeaCucumberArray <$> readFile "data/sea-cucumbers.txt"
+    putStr . show . stationary $ scca