From a842bedaedf7b56a307ddfd244b2aa5df25481b4 Mon Sep 17 00:00:00 2001 From: Samae Date: Sun, 31 Dec 2023 18:36:25 +0200 Subject: [PATCH] save --- src/Day5.hs | 124 ++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 90 insertions(+), 34 deletions(-) diff --git a/src/Day5.hs b/src/Day5.hs index 44ebf51..1900550 100644 --- a/src/Day5.hs +++ b/src/Day5.hs @@ -8,11 +8,7 @@ import Debug.Trace import Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString as BS -import Data.RangeSet.List (RSet) -import qualified Data.RangeSet.List as RSet -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Function ((&)) +import Data.List (find) main :: IO () main = do @@ -38,37 +34,97 @@ seedLocation :: RawAlmanach -> Int -> Int seedLocation ra = mapSrcDst (combinedMaps ra) combinedMaps :: RawAlmanach -> AlmanachMap -combinedMaps ra = mergeMaps (rawHumidityToLoc ra) - $ mergeMaps (rawTempToHumidity ra) - $ mergeMaps (rawLightToTemp ra) - $ mergeMaps (rawWaterToLight ra) - $ mergeMaps (rawFertToWater ra) - $ mergeMaps (rawSoilToFert ra) (rawSeedToSoil ra) +combinedMaps ra = unionAl (rawHumidityToLoc ra) + $ unionAl (rawTempToHumidity ra) + $ unionAl (rawLightToTemp ra) + $ unionAl (rawWaterToLight ra) + $ unionAl (rawFertToWater ra) + $ unionAl (rawSoilToFert ra) (rawSeedToSoil ra) mapSrcDst :: AlmanachMap -> Int -> Int -mapSrcDst m src = case Map.lookup True $ Map.mapKeys (RSet.member src) m of - Just v -> src + v +mapSrcDst m src = case lookupKVAl m src of + Just (_,v) -> src + v Nothing -> src -mergeMaps :: AlmanachMap -> AlmanachMap -> AlmanachMap -mergeMaps al1 = Map.foldlWithKey' f Map.empty - where - -- f acc k v = Map.union (mergeSet al1 k v) acc - f acc k v = Map.union (mergeSet al1 k v) acc +lookupKVAl :: AlmanachMap -> Int -> Maybe ((Int,Int),Int) +lookupKVAl m i = find (\ ((l,r),_) -> l <= i && i <= r) m -mergeSet :: AlmanachMap -> RSet Int -> Int -> AlmanachMap -mergeSet m r mod' = Map.foldrWithKey' f Map.empty m - where - f k v acc = specialInsert right v acc - & specialInsert middle (v+mod') - & specialInsert left mod' - where - left = RSet.difference r k - middle = RSet.intersection k r - right = RSet.difference k r - specialInsert r' v' m' = case Map.lookup True $ Map.mapKeys ((== RSet.empty) . RSet.intersection r) m of - Just _ -> Map.insert r' v' m' - Nothing -> mergeSet m' r' v' +insertAl :: Int -> Int -> Int -> AlmanachMap -> AlmanachMap +insertAl x y i set@(uv@((u,v),j) : xs) + | v < x = uv : insertAl x y i xs + | y < u = ((x,y),i) : set + -- | otherwise = prependAl (min x u) (max y v) i xs + -- |-----<**>------| + -- u x y v + | u <= x && y <= v && x <= y = trace "uxyv" $ + case (u==x,y==v,x==y) of + (False, False, False ) -> ((u,x-1),j) : ((x,y), i+j) : ((y+1,v),j) : xs + (True , False, False ) -> ((x,y), i+j) : ((y+1,v),j) : xs + (False, True , False ) -> ((u,x-1),j) : ((x,y), i+j) : xs + (True , True , False ) -> ((x,y), i+j) : xs + (False, False, True ) -> ((u,x-1),j) : ((x,x), i+j) : ((y+1,v),j) : xs + (True , False, True ) -> ((x,x), i+j) : ((y+1,v),j) : xs + (False, True , True ) -> ((u,x-1),j) : ((x,x), i+j) : xs + (True , True , True ) -> ((x,x), i+j) : xs + -- <*****|++>------| + -- x u y v + | x <= u && y <= v && u <= y = trace "xuyv" $ + case (x==u,y==v,u==y) of + (False, False, False ) -> ((x,u-1),i) : ((u,y), i+j) : ((y+1,v),j) : xs + (True , False, False ) -> ((u,y), i+j) : ((y+1,v),j) : xs + (False, True , False ) -> ((x,u-1),i) : ((u,y), i+j) : xs + (True , True , False ) -> ((u,y), i+j) : xs + (False, False, True ) -> ((x,u-1),i) : ((u,y), i+j) : ((y+1,v),j) : xs + (True , False, True ) -> ((u,y), i+j) : ((y+1,v),j) : xs + (False, True , True ) -> ((x,u-1),i) : ((u,y), i+j) : xs + (True , True , True ) -> ((u,y), i+j) : xs + -- |-----<++|******> + -- u x v y + | u <= x && v <= y && x <= v = trace "uxvy" $ + case (u==x,v==y,x==v) of + (False, False, False ) -> ((u,x-1),j) : ((x,v), i+j) : ((v+1,y),i) : xs + (True , False, False ) -> ((x,v), i+j) : ((v+1,y),i) : xs + (False, True , False ) -> ((u,x-1),j) : ((x,v), i+j) : xs + (True , True , False ) -> ((x,v), i+j) : xs + (False, False, True ) -> ((u,x-1),j) : ((x,v), i+j) : ((v+1,y),i) : xs + (True , False, True ) -> ((x,v), i+j) : ((v+1,y),i) : xs + (False, True , True ) -> ((u,x-1),j) : ((x,v), i+j) : xs + (True , True , True ) -> ((x,v), i+j) : xs + -- <*****|++|******> + -- x u v y + | x <= u && v <= y && u <= v = trace "xuvy" $ + case (x==u,v==y,u==v) of + (False, False, False ) -> ((x,u-1),i) : ((u,v), i+j) : ((v+1,y),i) : xs + (True , False, False ) -> ((u,v), i+j) : ((v+1,y),i) : xs + (False, True , False ) -> ((x,u-1),i) : ((u,v), i+j) : xs + (True , True , False ) -> ((u,v), i+j) : xs + (False, False, True ) -> ((x,u-1),i) : ((u,v), i+j) : ((v+1,y),i) : xs + (True , False, True ) -> ((u,v), i+j) : ((v+1,y),i) : xs + (False, True , True ) -> ((x,u-1),i) : ((u,v), i+j) : xs + (True , True , True ) -> ((u,v), i+j) : xs + | otherwise = trace ( "x:" <> show x + <> " y:" <> show y + <> " u:" <> show u + <> " v:" <> show v + ) undefined +insertAl x y i [] = [((x,y),i)] + +-- -- | Add @[x,y]@ to the beginning (assuming @x <= u@). +-- prependAl :: Int -> Int -> Int -> AlmanachMap -> AlmanachMap +-- prependAl x y vi set@(((u,v),_) : xs) +-- | y < u && succ y /= u = ((x,y),v) : set +-- | otherwise = prependAl x (max y v) vi xs +-- prependAl x y v [] = [((x,y),v)] + +-- | Union two range lists. +unionAl :: AlmanachMap -> AlmanachMap -> AlmanachMap +unionAl (((x,y),i):as) (((u,v),j):bs) = + insertAl x y i $ insertAl u v j $ unionAl as bs +unionAl s [] = s +unionAl [] s = s + +emptyAl :: AlmanachMap +emptyAl = [] data RawAlmanach = RawAlmanach { rawSeeds :: [Int] @@ -82,7 +138,7 @@ data RawAlmanach = RawAlmanach } deriving Show -type AlmanachMap = Map (RSet Int) Int +type AlmanachMap = [((Int,Int),Int)] justSpace :: Parser BS.ByteString @@ -91,11 +147,11 @@ justSpace = " " almanachMap :: Parser AlmanachMap almanachMap = do xs <- oneRange `sepBy` endOfLine - pure $ Map.fromList xs + pure $ foldl (\ acc ((u,v),i) -> insertAl u v i acc) emptyAl xs where oneRange = do a:b:c:_ <- decimal `sepBy` justSpace - pure (RSet.fromRangeList [(b,b+c-1)], a-b) + pure ((b,b+c-1), a-b) rawAlmanach :: Parser RawAlmanach rawAlmanach = do