day 8: rewrite

trying a new approach hinted by someone else

Signed-off-by: Amneesh Singh <natto@weirdnatto.in>

.envrc

@@ -0,0 +1 @@
+use flake

day5.hs

@@ -1,44 +1,44 @@
-import Data.Char (isDigit)
-import Data.List (transpose)
-import Data.Maybe (catMaybes)
-import Text.ParserCombinators.ReadP
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Data.List (foldl')
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Lib (readFile')
 
 main :: IO ()
 main = do
-  input <- lines <$> readFile "day5.in"
-  let (crates, cmds) = break null input
-  let cratesList = map catMaybes $ transpose $ map (fst . last . readP_to_S parseCrates) $ init crates
-  let cmdsList = map ((\(n, a, b) -> (n, a - 1, b - 1)) . fst . last . readP_to_S parseCmd) $ tail cmds
-  print cratesList
+  input <- break (== T.empty) . T.lines <$> readFile' "day5.in"
+  let (crates, cmds) = parse input
   putStr "Q1: "
-  print $ q1 cratesList cmdsList
+  print $ moveCrates T.reverse crates cmds
   putStr "Q2: "
-  print $ q2 cratesList cmdsList
+  print $ moveCrates id crates cmds
 
-q1, q2 :: [[Char]] -> [(Int, Int, Int)] -> [Char]
-q1 crates cmds = map head $ foldl (\x xs -> moveCrates x xs True) crates cmds
-q2 crates cmds = map head $ foldl (\x xs -> moveCrates x xs False) crates cmds
-
--- Computers are fast, really, not optimising right now
-moveCrates :: [[Char]] -> (Int, Int, Int) -> Bool -> [[Char]]
-moveCrates crates (n, a, b) rev =
-  let (head, tail) = splitAt n $ crates !! a
-   in replace b (replace a crates tail) ((if rev then reverse head else head) ++ crates !! b)
+moveCrates :: (Text -> Text) -> [Text] -> [(Int, Int, Int)] -> Text
+moveCrates f crates' cmds = head . T.transpose . M.elems $ foldl' move crates cmds
   where
-    replace :: Int -> [a] -> a -> [a]
-    replace i xs x = take i xs ++ [x] ++ drop (i + 1) xs
+    crates :: Map Int Text
+    crates = M.fromList $ zip [0 ..] crates'
+    move :: Map Int Text -> (Int, Int, Int) -> Map Int Text
+    move c (n, x, y) =
+      let (h, t) = T.splitAt n $ c M.! x
+       in M.update (Just . (<>) (f h)) y $ M.insert x t c
 
-parseCrates :: ReadP [Maybe Char]
-parseCrates = sepBy parseRow (char ' ')
-  where
-    parseRow :: ReadP (Maybe Char)
-    parseRow = (Just <$> (char '[' *> get <* char ']')) +++ (Nothing <$ string "   ")
-
-parseCmd :: ReadP (Int, Int, Int)
-parseCmd =
-  (,,) <$> (string "move " *> getInt)
-    <*> (string " from " *> getInt)
-    <*> (string " to " *> getInt)
-  where
-    getInt :: ReadP Int
-    getInt = read <$> many1 (satisfy isDigit)
+-- ugly code vs line length <= 90 🤔
+parse :: ([Text], [Text]) -> ([Text], [(Int, Int, Int)])
+parse (crates, cmds) =
+  ( [ T.filter (/= ' ') x
+      | (i, x) <- zip [0 ..] (T.transpose $ init crates),
+        i `mod` 4 == 1
+    ],
+    map
+      ( ( \["move", T.unpack -> n, "from", T.unpack -> x, "to", T.unpack -> y] ->
+            (read n, read x - 1, read y - 1)
+        )
+          . T.words
+      )
+      $ tail cmds
+  )

day6.hs

@@ -1,16 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 import Data.List (nub)
+import Lib (readFile')
+import Data.Text (Text)
+import qualified Data.Text as T
 
 main :: IO ()
 main = do
-  input <- readFile "day6.in"
+  input <- readFile' "day6.in"
   putStr "Q1: "
   print $ parse 4 input
   putStr "Q2: "
   print $ parse 14 input
 
-group :: Int -> [Char] -> [[Char]]
-group _ [] = []
-group n xs = take n xs : group n (tail xs)
+group :: Int -> Text -> [Text]
+group _ "" = []
+group n xs = T.take n xs : group n (T.tail xs)
 
-parse :: Int -> String -> Int
-parse n = (+ n) . length . takeWhile ((< n) . length) . map nub . group n
+parse :: Int -> Text -> Int
+parse n = (+ n) . length . takeWhile ((< n) . length) . map (nub . T.unpack) . group n

day7'.hs

@@ -1,8 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Either (rights)
+import Data.Text (Text)
+import qualified Data.Text as T (head, lines, words)
+import qualified Data.Text.Read as T (decimal)
 import Data.Tree
+import Lib (readFile')
 
 main :: IO ()
 main = do
-  tree <- snd . flip parse (emptyFs "/") . map words . lines <$> readFile "day7.in"
+  tree <- snd . flip parse (emptyFs "/") . map T.words . T.lines <$> readFile' "day7.in"
   putStr "Q1: "
   print $
     foldTree
@@ -22,24 +29,26 @@ main = do
       )
       tree
 
-type Filesystem = Tree (String, Int)
+type Filesystem = Tree (Text, Int)
 
 tail' :: [a] -> [a]
 tail' = drop 1
 
-emptyFs :: String -> Filesystem
+emptyFs :: Text -> Filesystem
 emptyFs n = Node (n, 0) []
 
-insertFs :: Filesystem -> String -> Filesystem -> Filesystem
+insertFs :: Filesystem -> Text -> Filesystem -> Filesystem
 insertFs (Node n xs) name fs = Node (fst n, snd n + snd (rootLabel fs)) (fs : xs)
 
+ls :: [[Text]] -> [Filesystem]
+ls =
+  map (\[a, b] -> Node (b, fst . head $ rights [T.decimal a]) [])
+    . filter ((/= "dir") . head)
+
 totalSize :: [Filesystem] -> Int
 totalSize = sum . map (snd . rootLabel)
 
-ls :: [[String]] -> [Filesystem]
-ls = map (\[a, b] -> Node (b, read a) []) . filter ((/= "dir") . head)
-
-parse :: [[String]] -> Filesystem -> ([[String]], Filesystem)
+parse :: [[Text]] -> Filesystem -> ([[Text]], Filesystem)
 parse input fs
   | null input || cur == ["$", "cd", ".."] = (tail' input, fs)
   | cur == ["$", "ls"] =
@@ -50,7 +59,7 @@ parse input fs
   | otherwise =
     let name = cur !! 2
         (nextInput, newFs) = parse (tail' input) (emptyFs name)
-        replaced = insertFs fs name newFs -- replace empty directory
+        replaced = insertFs fs name newFs
      in parse nextInput replaced
   where
     cur = head input

day7.hs

@@ -1,12 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Either (rights)
+import Data.Text (Text)
+import qualified Data.Text as T (head, lines, words)
+import qualified Data.Text.Read as T (decimal)
 import Data.Tree
+import Lib (readFile')
 
 -- this solution assumes that empty directories can exist,
 -- if you want to ignore that, there is a slightly different code in day7'.hs
--- needs cleaning and improvement
+
+-- needs cleaning and improvement, although i like the fact
+-- that the entire FS can be printed as a tree
 
 main :: IO ()
 main = do
-  tree <- snd . flip parse (emptyFs "/") . map words . lines <$> readFile "day7.in"
+  tree <- snd . flip parse (emptyFs "/") . map T.words . T.lines <$> readFile' "day7.in"
   putStr "Q1: "
   print $
     foldTree
@@ -26,18 +35,18 @@ main = do
       )
       tree
 
-type Filesystem = Tree (String, Int)
+type Filesystem = Tree (Text, Int)
 
 tail' :: [a] -> [a]
 tail' = drop 1
 
 -- wrapper to create an empty tree
-emptyFs :: String -> Filesystem
+emptyFs :: Text -> Filesystem
 emptyFs n = Node (n, 0) []
 
 -- This function is to replace a filesystem by name
 -- Used to replace empty directories with parsed directories in code
-replaceFs :: Filesystem -> String -> Filesystem -> Filesystem
+replaceFs :: Filesystem -> Text -> Filesystem -> Filesystem
 replaceFs (Node n xs) name fs =
   let (h, t) = span ((/= name) . fst . rootLabel) xs
    in Node
@@ -50,11 +59,17 @@ totalSize :: [Filesystem] -> Int
 totalSize = sum . map (snd . rootLabel)
 
 -- All directories/files are parsed here into leaves
-ls :: [[String]] -> [Filesystem]
-ls = map (\[a, b] -> if a == "dir" then Node (b, 0) [] else Node (b, read a) [])
+ls :: [[Text]] -> [Filesystem]
+ls =
+  map
+    ( \[a, b] ->
+        if a == "dir"
+          then Node (b, 0) []
+          else Node (b, fst . head $ rights [T.decimal a]) []
+    )
 
 -- main function where stuff happens
-parse :: [[String]] -> Filesystem -> ([[String]], Filesystem)
+parse :: [[Text]] -> Filesystem -> ([[Text]], Filesystem)
 parse input fs
   | null input || cur == ["$", "cd", ".."] = (tail' input, fs)
   | cur == ["$", "ls"] =

day8.hs

@@ -1,52 +1,48 @@
-import Data.Char (digitToInt)
-import Data.List (transpose, zip4, zipWith4)
+import Data.List (scanl, tails, transpose, zip4, zipWith4)
+import Data.Text (Text)
+import qualified Data.Text as T (lines, unpack)
+import Lib (readFile')
 
+-- new approach was hinted by an anon but I cannot quite get it right
 -- a fun approach, not necessarily the fastest (or cleanest (or smartest))
 
 main :: IO ()
 main = do
-  input <- map (map digitToInt) . lines <$> readFile "day8.in"
-  let (e, w, n, s) = trees input
-  let obscured = zipWith4 zip4 e w n s
+  input <- map T.unpack . T.lines <$> readFile' "day8.in"
   putStr "Q1: "
-  print $
-    length $
-      filter
-        (not . (\((w, _), (x, _), (y, _), (z, _)) -> w && y && x && z))
-        $ concat obscured
+  print $ q1 input
   putStr "Q2: "
-  print $
-    maximum $
-      map (\((_, w), (_, x), (_, y), (_, z)) -> w * x * y * z) $
-        concat obscured
+  print $ q2 input
 
-type Forest = [[(Bool, Int)]]
-
-trees :: [[Int]] -> (Forest, Forest, Forest, Forest)
-trees input =
-  ( trees' input,
-    map reverse $ trees' $ map reverse input,
-    transpose $ trees' $ transpose input,
-    reverse $ transpose $ trees' $ transpose $ reverse input
-  ) -- (east, west, north, south) traversals
+layer :: [[Char]] -> (a -> a -> a) -> ([[Char]] -> [[a]]) -> [[a]]
+layer input f f' =
+  zipWith4 ( zipWith4 (\w x y z -> f w . f x $ f y z) )
+    (f' e)
+    (map reverse $ f' w)
+    (transpose $ f' n)
+    (reverse . transpose $ f' s)
   where
-    trees' :: [[Int]] -> Forest
-    trees' =
-      foldr
-        ( \x xs ->
-            let (_, dist) =
-                  foldr
-                    ( \(cur, y) ((old, m), ys) ->
-                        ( if y > m then (cur, y) else (old, m),
-                          ( y <= m,
-                            let s = length $ takeWhile (< y) $ reverse $ take cur x
-                             in if s == cur then s else s + 1
-                          ) :
-                          ys
-                        )
-                    )
-                    ((-1, -1), [])
-                    (zip [0 ..] x)
-             in dist : xs
+    (e, w, n, s) =
+      ( input,
+        map reverse input,
+        transpose input,
+        transpose $ reverse input
+      ) -- (east, west, north, south]
+
+q1 :: [[Char]] -> Int
+q1 input = length . filter not . concat $ layer input (&&) q1'
+  where
+    q1' :: [[Char]] -> [[Bool]]
+    q1' = map (\x -> zipWith (<=) x $ scanl max minBound x)
+
+q2 :: [[Char]] -> Int
+q2 input = maximum . concat $ layer input (*) q2'
+  where
+    q2' :: [[Char]] -> [[Int]]
+    q2' =
+      map
+        ( \a ->
+            [ let l = length (takeWhile (< x) xs) in (+ l) . fromEnum $ length xs /= l
+              | (x : xs) <- tails a
+            ]
         )
-        []