Day 21

src/AOC-19a.hs

 module Main where
 
+import Control.Monad
+import Data.Char
+import Data.List
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Text.ParserCombinators.ReadP
+
+type Position = (Int,Int,Int)
+data ScannerData = ScannerData { index :: Int, beacons :: [Position] }
+data Scanners = Scanners { sdlist :: [ScannerData] }
+
+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 $ (x,y,z)
+
+parseScannerData :: ReadP ScannerData
+parseScannerData = do
+  void $ string "--- scanner "
+  n <- parseInt
+  void $ string " ---"
+  skipSpaces
+  bs <- parsePosition `sepBy` skipSpaces
+  pure $ ScannerData n bs
+
+parseScanners :: ReadP Scanners
+parseScanners = Scanners <$> parseScannerData `sepBy` skipSpaces
+
+instance Read ScannerData where
+  readsPrec _ = readP_to_S parseScannerData
+
+instance Show ScannerData where
+  show (ScannerData n bs) =
+    unlines $ header : map showBeacon bs
+    where
+    header = "--- scanner " ++ show n ++ " ---"
+    showBeacon (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
+
+-- An orientiation is a pair of [Int] (ax,ay,az,sx,sy,sz), where
+--    as = [ax,ay,az] is a permutation of [1,2,3] 
+--    sx, sy, and sz elements [-1,1]
+-- and the sign of the permutation as times sx, sy, and sz is 1
+
+type Orientation = (Int,Int,Int,Int,Int,Int)
+
+sign :: [Int] -> Int
+sign as = f $ sum [s xi yi | let n = length as - 1, xi <- [0..n], yi <- [xi+1..n]] where
+  s :: Int -> Int -> Int
+  s xi yi
+    | as !! xi > as !! yi = 1
+    | otherwise = 0
+  f :: Int -> Int
+  f n = case n `mod` 2 of
+    0 -> 1
+    1 -> -1
+    _ -> error "sign.f -- impossible"
+
+orientations :: [Orientation]
+orientations =
+  [ (ax,ay,az,sx,sy,sz)
+  | as <- permutations [1,2,3]
+  , let sas = sign as
+        [ax,ay,az] = as
+  , sx <- [1,-1]
+  , sy <- [1,-1]
+  , sz <- [1,-1]
+  , sas * sx * sy * sz == 1
+  ]
+
+invertOrientation :: Orientation -> Orientation
+invertOrientation (ax,ay,_,sx,sy,sz) =
+  case ax of
+    1 -> case ay of
+      2 -> -- az == 3
+        (1,2,3,sx,sy,sz)
+      3 -> -- az == 2
+        (1,3,2,sx,sz,sy)
+      _ -> error "invertOrientation -- impossible axis"
+    2 -> case ay of
+      1 -> -- az = 3
+        (2,1,3,sy,sx,sz)
+      3 -> -- ax == 1
+        (2,3,1,sy,sz,sx)
+      _ -> error "invertOrientation -- impossible axis"
+    3 -> case ay of
+      1 -> -- az = 2
+        (3,1,2,sz,sx,sy)
+      2 -> -- az == 3
+        (3,1,2,sz,sx,sy)
+      _ -> error "invertOrientation -- impossible axis"
+    _ -> error "invertOrientation -- impossible axis"
+
+positionAtOrientation :: Position -> Orientation -> Position
+positionAtOrientation (x,y,z) (ax,ay,az,sx,sy,sz) = (sx * coordinate ax, sy * coordinate ay, sz * coordinate az) where
+  coordinate 1 = x
+  coordinate 2 = y
+  coordinate 3 = z
+  coordinate _ = error "positionAtOrientation -- unknown coordinate"
+
+atOrientation :: ScannerData -> Orientation -> ScannerData
+atOrientation (ScannerData n bs) orientation = ScannerData n bs' where
+  bs' = map (`positionAtOrientation` orientation) bs
+
+overlay :: ScannerData -> ScannerData -> [Position]
+overlay (ScannerData _ as) (ScannerData _ bs) = hits where
+  offsets = M.unionsWith (+)
+    [ M.singleton (ax-bx,ay-by,az-bz) one
+    | (ax,ay,az) <- as
+    , (bx,by,bz) <- bs
+    ]
+  one = 1 :: Int
+  hits = [ p 
+         | (p,v) <- M.assocs offsets
+         , v >= 12
+        , let bs' = map (translate p) bs
+        , sort [ bpt | bpt <- bs', distance (0,0,0) bpt <= 1000] 
+          == sort [apt | apt <- as, distance p apt <= 1000]
+        ]
+
+translate :: Position -> Position -> Position
+translate (x1,y1,z1) (x2,y2,z2) = (x1+x2,y1+y2,z1+z2)
+
+reflect :: Position -> Position
+reflect (x,y,z) = (-x,-y,-z)
+
+distance :: Position -> Position -> Int
+distance (x1,y1,z1) (x2,y2,z2) =
+  maximum [abs $ x1-x2, abs $ y1-y2, abs $ z1-z2]
+
+-- The result is
+-- (ia,ib,p,orient) where
+-- ia and ib are indexes of a Scanner
+-- orient is the orientation that was applied to the points in b to produce b'
+-- p is the location of scanner b' in a's coordinate system
+
+overlays :: [ScannerData] -> [(Int,Int,Position,Orientation)]
+overlays sds = do
+  (sa,sb) <- [ (sds !! x, sds !! y) 
+             | let n = length sds - 1
+             , x <- [0..n]
+             , y <- [x+1..n]
+             ] 
+  orientation <- orientations
+  let sb' = sb `atOrientation` orientation
+  (x,y,z) <- overlay sa sb'
+  pure $ (index sa, index sb',(x,y,z),orientation)
+
+uniq :: Ord a => [a] -> [a]
+uniq = S.toList . S.fromList
+
+
+assembleBeacons :: Scanners -> [Position]
+assembleBeacons (Scanners sds) = uniq points where
+  scannerMap = iter (M.singleton 0 []) [] (overlays sds) where
+  iter :: M.Map Int [(Position,Orientation)] 
+       -> [(Int,Int,Position,Orientation)] 
+       -> [(Int,Int,Position,Orientation)]
+       -> M.Map Int [(Position,Orientation)]
+  iter m [] [] = m
+  iter m delayed [] = iter m [] (reverse delayed)
+  iter m delayed (offset@(i,j,p,theta) : rest) =
+    let ks = M.keys m
+    in case (i `elem` ks, j `elem` ks) of
+        (False,False) -> iter m (offset : delayed) rest -- neither ScannerData in map
+        (True,True) -> iter m delayed rest -- both ScannerData's in map
+        (True,False) ->
+          let os = m M.! i
+          in iter (M.insert j ((p,theta) : os) m) delayed rest
+        (False,True) ->
+          let os = m M.! j
+              theta' = invertOrientation theta
+              p' = reflect p `positionAtOrientation` theta'
+          in iter (M.insert i ((p',theta') : os) m) delayed rest
+  points = [ applyTransformations pt (reverse ts)
+           | (i,ts) <- M.assocs scannerMap
+           , pt <- beacons $ sds !! i
+           ] 
+
+applyTransformations :: Position -> [(Position,Orientation)] -> Position
+applyTransformations pt ts = foldr f pt ts where
+  f (pos,orient) p' = translate pos (p'  `positionAtOrientation` orient)
+
 main :: IO ()
-main = pure ()
+main = do 
+  sc <- read @Scanners <$> readFile "data/beacons.txt"
+  print . length . assembleBeacons $ sc
+
+{-
+  wrong answers: 471 too high
+-}
\ No newline at end of file

src/AOC-20a.hs

 module Main where
 
+import Data.Array
+
+type ImageAlgorithm = Array Int Int   -- 512 elements
+type Image = (Array (Int,Int) Int,Int) -- the second coordinate is the default pixel
+
+processInput :: String -> (ImageAlgorithm,Image)
+processInput s = (toAlgorithm header,toImage (tail rest)) where
+  header : rest = lines s
+  toAlgorithm = array (0,511) . zip [0..] . verify
+  verify str
+    | length str == 512 = map decode str
+    | otherwise = error "processInput -- invalid image algorithm"
+  decode :: Char -> Int
+  decode '#' = 1
+  decode '.' = 0
+  decode c   = error $ "processInput.decode -- invalid character: " ++ [c]
+  toImage ls = (array ((1,1),(width,height)) pixels, 0) where
+    width = length (head ls)
+    height = length ls
+    pixels = [((x,y),decode c)
+             | (y,row) <- zip [1..] ls
+             , (x,c) <- zip [1..] row
+             ]
+
+padImage :: Image -> Image
+padImage (input,px) = (output,px) where
+  xInputMin = minimum [ x | ((x,_),v) <- assocs input, v /= px ]
+  yInputMin = minimum [ y | ((_,y),v) <- assocs input, v /= px ]
+  xInputMax = maximum [ x | ((x,_),v) <- assocs input, v /= px ]
+  yInputMax = maximum [ y | ((_,y),v) <- assocs input, v /= px ]
+  xOffset = 3 - xInputMin
+  yOffset = 3 - yInputMin
+  xOutputMax = 5 + xInputMax - xInputMin
+  yOutputMax = 5 + yInputMax - yInputMin
+  bds = ((1,1),(xOutputMax,yOutputMax))
+  output = array ((1,1),(xOutputMax,yOutputMax)) [ (p,pixelAt p) | p <- range bds]
+  pixelAt (x,y)
+    | x <= 2 || y <= 2 || x >= xOutputMax - 1 || y >= yOutputMax - 1 = px
+    | otherwise = input ! (x - xOffset, y - yOffset)
+
+showImage :: Image -> String
+showImage (arr,_) = unlines [ [ encode (arr ! (x,y)) | x <- [1..xMax] ] | y <- [1..yMax]] where
+  ((1,1),(xMax,yMax)) = bounds arr
+  encode 0 = '.'
+  encode 1 = '#'
+  encode c = error $ "showImage.encode: invalid pixel value: " ++ show c
+
+processImage :: ImageAlgorithm -> Image -> Image
+processImage algorithm img = (result,dpx) where
+  (arr,_)= padImage img
+  ((1,1),(xMax,yMax)) = bounds arr
+  dpx = algorithm ! 0
+  borderpx = algorithm ! if dpx == 0 then 0 else 511
+  result = array (bounds arr) $ [ ((x,y),pixelAt (x,y)) | x <-[1..xMax], y <- [1..yMax]]
+  pixelAt (x,y)
+    | x == 1 || x == xMax || y == 1 || y == yMax = borderpx
+    | otherwise = algorithm ! fromBinary (neighborhoodBits (x,y))
+  neighborhoodBits (x,y) = map (arr !) [(x',y') | y' <- [y-1..y+1], x' <- [x-1..x+1]]
+
+fromBinary :: [Int] -> Int
+fromBinary = sum . zipWith (*) (iterate (*2) 1) . reverse
+
+twice :: (a -> a) -> (a -> a)
+twice f a = f (f a)
+
+countLit :: Image -> Int
+countLit (img,_) = length [p | p <- range (bounds img), img ! p == 1]
+
 main :: IO ()
-main = pure ()
+main = do
+  (algorithm,image) <- processInput <$> readFile "data/image.txt"
+  print . countLit . twice (processImage algorithm) $ image
+
+{-
+  5406 too high
+-}

src/AOC-21a.hs

 module Main where
 
+diracGame :: Int -> Int -> IO Int
+diracGame startA startB = iter (1,0) 1 (startA,0) (startB,0) where
+  iter :: (Int,Int) -> Int -> (Int,Int) -> (Int,Int) -> IO Int
+  iter (die,dieRolls) currentPlayer (posA,scoreA) (posB,scoreB) = do
+        let r1 = roll die
+            r2 = roll r1
+            r3 = roll r2
+            nDieRolls = dieRolls + 3
+        let nPosA = ((posA + die + r1 + r2 - 1) `mod` 10) + 1
+            nScoreA = scoreA + nPosA
+        putStrLn $ "Player " ++ show currentPlayer ++ " rolls "
+                  ++ show die ++"+" ++ show r1 ++ "+" ++ show r2 ++
+                  " and moves to space " ++ show nPosA ++ 
+                  " for a total score of " ++ show nScoreA ++ "."
+        if nScoreA >= 1000
+        then do
+          let result = scoreB * nDieRolls
+          putStrLn $ "Result: " ++ show scoreB ++ " * " ++ show nDieRolls ++ " = " ++ show result
+          pure result
+        else
+          iter (r3,nDieRolls) (3-currentPlayer) (posB,scoreB) (nPosA,nScoreA)
+
+roll :: Int -> Int
+roll = (+1)
+
 main :: IO ()
-main = pure ()
+main = do
+  r <- diracGame 4 6
+  print r

src/AOC-21b.hs

 module Main where
 
+import Data.Array ( Ix(range), Array, (!), array )
+import qualified Data.Map as M
+
+splits :: [(Int,Integer)] 
+splits = M.assocs $ roll 3 (M.singleton 0 1) where
+  roll :: Int -> M.Map Int Integer -> M.Map Int Integer
+  roll 0 m = m
+  roll n m = roll (n-1) $ M.unionsWith (+) . map ((`M.mapKeys` m) . (+)) $ [1,2,3]
+
+-- universes xPos xScore yPos yScore = (losers,winners)
+-- where player X will make the next move.
+
+universes :: Array (Int,Int,Int,Int) (Integer,Integer)
+universes = array bds [(p, score p) | p <- range bds] where
+  bds = ((0,1,0,1),(20,10,20,10))
+  score (xScore,xPos,yScore,yPos) = sumPairs
+                    [ (c * losers, c * winners)
+                    | (r,c) <- splits
+                    , let nPos = ((xPos + r - 1) `mod` 10) + 1
+                          nScore = xScore + nPos
+                          (winners,losers) = univ yScore yPos nScore nPos
+                    ]
+  sumPairs = foldr1 (\(a,b) (c,d) -> (a+c,b+d))
+  univ xScore xPos yScore yPos
+    | yScore >= 21 = (1,0)
+    | otherwise = universes ! (xScore,xPos,yScore,yPos)
+  
+diracGame :: Int -> Int -> (Integer,Integer)
+diracGame p1 p2 = universes ! (0,p1,0,p2)
+
 main :: IO ()
-main = pure ()
+main = do
+  print . snd $ diracGame 4 6
\ No newline at end of file

test/beacons.txt

+--- scanner 0 ---
+404,-588,-901
+528,-643,409
+-838,591,734
+390,-675,-793
+-537,-823,-458
+-485,-357,347
+-345,-311,381
+-661,-816,-575
+-876,649,763
+-618,-824,-621
+553,345,-567
+474,580,667
+-447,-329,318
+-584,868,-557
+544,-627,-890
+564,392,-477
+455,729,728
+-892,524,684
+-689,845,-530
+423,-701,434
+7,-33,-71
+630,319,-379
+443,580,662
+-789,900,-551
+459,-707,401
+
+--- scanner 1 ---
+686,422,578
+605,423,415
+515,917,-361
+-336,658,858
+95,138,22
+-476,619,847
+-340,-569,-846
+567,-361,727
+-460,603,-452
+669,-402,600
+729,430,532
+-500,-761,534
+-322,571,750
+-466,-666,-811
+-429,-592,574
+-355,545,-477
+703,-491,-529
+-328,-685,520
+413,935,-424
+-391,539,-444
+586,-435,557
+-364,-763,-893
+807,-499,-711
+755,-354,-619
+553,889,-390
+
+--- scanner 2 ---
+649,640,665
+682,-795,504
+-784,533,-524
+-644,584,-595
+-588,-843,648
+-30,6,44
+-674,560,763
+500,723,-460
+609,671,-379
+-555,-800,653
+-675,-892,-343
+697,-426,-610
+578,704,681
+493,664,-388
+-671,-858,530
+-667,343,800
+571,-461,-707
+-138,-166,112
+-889,563,-600
+646,-828,498
+640,759,510
+-630,509,768
+-681,-892,-333
+673,-379,-804
+-742,-814,-386
+577,-820,562
+
+--- scanner 3 ---
+-589,542,597
+605,-692,669
+-500,565,-823
+-660,373,557
+-458,-679,-417
+-488,449,543
+-626,468,-788
+338,-750,-386
+528,-832,-391
+562,-778,733
+-938,-730,414
+543,643,-506
+-524,371,-870
+407,773,750
+-104,29,83
+378,-903,-323
+-778,-728,485
+426,699,580
+-438,-605,-362
+-469,-447,-387
+509,732,623
+647,635,-688
+-868,-804,481
+614,-800,639
+595,780,-596
+
+--- scanner 4 ---
+727,592,562
+-293,-554,779
+441,611,-461
+-714,465,-776
+-743,427,-804
+-660,-479,-426
+832,-632,460
+927,-485,-438
+408,393,-506
+466,436,-512
+110,16,151
+-258,-428,682
+-393,719,612
+-211,-452,876
+808,-476,-593
+-575,615,604
+-485,667,467
+-680,325,-822
+-627,-443,-432
+872,-547,-609
+833,512,582
+807,604,487
+839,-516,451
+891,-625,532
+-652,-548,-490
+30,-46,-14
\ No newline at end of file

test/image.txt

+..#.#..#####.#.#.#.###.##.....###.##.#..###.####..#####..#....#..#..##..###..######.###...####..#..#####..##..#.#####...##.#.#..#.##..#.#......#.###.######.###.####...#.##.##..#..#..#####.....#.#....###..#.##......#.....#..#..#..##..#...##.######.####.####.#.#...#.......#..#.#.#...####.##.#......#..#...##.#.##..#...##.#.##..###.#......#.#.......#.#.#.####.###.##...#.....####.#..#..#.##.#....##..#.####....##...##..#...#......#.#.......#.......##..####..#...#.#.#...##..#.#..###..#####........#..####......#..#
+
+#..#.
+#....
+##..#
+..#..
+..###
\ No newline at end of file