Day 13

src/AOC-13a.hs

 module Main where
 
 import Data.Array
-import Data.Char
-import Data.Functor
+    ( Ix(range), (!), accumArray, array, bounds, elems, Array )
+import Data.Char ( isDigit )
+import Data.Functor ( ($>), void )
 import Text.ParserCombinators.ReadP
+    ( (<++),
+      char,
+      many,
+      munch1,
+      readP_to_S,
+      skipSpaces,
+      string,
+      ReadP )
 
 data Fold
   = FoldX Int
@@ -56,11 +65,17 @@ interpret1 :: Fold -> Pixels -> Pixels
 interpret1 (FoldX x) = foldX x
 interpret1 (FoldY y) = foldY y
 
+interpret :: Pixels -> [Fold] -> Pixels
+interpret px fs = foldl (flip interpret1) px fs
+
 overlay :: Pixels -> Pixels -> Pixels
 overlay (Pixels parr) (Pixels qarr) = Pixels rarr where
   rarr = if bounds parr == bounds qarr
          then array (bounds parr) [ (p, parr ! p || qarr ! p) | p <- range . bounds $ parr]
-         else error "overlay: nonconforming Pixel arrays."
+         else error $ unwords ["overlay: nonconforming Pixel arrays"
+                              , show . bounds $ parr
+                              , show . bounds $ qarr
+                              ]
 
 cutX  :: Int -> Pixels -> (Pixels,Pixels)
 cutX foldCol (Pixels parr) = (Pixels qarr, Pixels rarr) where
@@ -68,7 +83,7 @@ cutX foldCol (Pixels parr) = (Pixels qarr, Pixels rarr) where
   xMaxQ = foldCol - 1
   qarr = array ((0,0),(xMaxQ,yMax)) [ ((x,y),parr ! (x,y)) | x <- [0..xMaxQ], y <- [0..yMax] ]
   xMaxR = xMax - foldCol- 1
-  rarr = array ((0,0),(xMaxR,yMax)) [((x,y), parr ! (x,y+foldCol+1)) | x <- [0..xMaxR], y <-[0..yMax] ]
+  rarr = array ((0,0),(xMaxR,yMax)) [((x,y), parr ! (x+foldCol+1,y)) | x <- [0..xMaxR], y <-[0..yMax] ]
 
 cutY :: Int -> Pixels -> (Pixels,Pixels)
 cutY foldRow (Pixels parr) = (Pixels qarr, Pixels rarr) where
@@ -115,15 +130,15 @@ foldX x px = padX (width right - width left) left
              `overlay` padX (width left - width right) (flipX right)
     where
     (left,right) = cutX x px
-    width (Pixels arr) = xMax where
+    width (Pixels arr) = xMax + 1 where
       ((0,0),(xMax,_)) = bounds arr
 
 foldY :: Int -> Pixels -> Pixels
-foldY y px = padY (height top - height bottom) top 
+foldY y px = padY (height bottom - height top) top 
              `overlay` padY (height top - height bottom) (flipY bottom)
     where
     (top,bottom) = cutY y px
-    height (Pixels arr) = yMax where
+    height (Pixels arr) = yMax + 1 where
       ((0,0),(_,yMax)) = bounds arr
 
 score :: Pixels -> Int
@@ -133,4 +148,4 @@ main :: IO ()
 main = do
   input <- read @Instructions <$> readFile "data/dots.txt"
   let pixels = makePixels . dots $ input
-  print . score . foldY 7 $ pixels  
+  putStr . showPixels . interpret pixels $ (folds input)
\ No newline at end of file

src/AOC-13b.hs

 module Main where
 
+import Data.Array
+    ( Ix(range), (!), accumArray, array, bounds, elems, Array )
+import Data.Char ( isDigit )
+import Data.Functor ( ($>), void )
+import Text.ParserCombinators.ReadP
+    ( (<++),
+      char,
+      many,
+      munch1,
+      readP_to_S,
+      skipSpaces,
+      string,
+      ReadP )
+
+data Fold
+  = FoldX Int
+  | FoldY Int
+  deriving Show
+
+data Instructions = Instructions
+  { dots :: [(Int,Int)]
+  , folds :: [Fold]
+  } deriving Show
+
+parseInt :: ReadP Int
+parseInt = read <$> munch1 isDigit
+
+parseFold :: ReadP Fold
+parseFold = parseDirection <*> parseInt where
+  parseDirection = parseFold' 'x' FoldX <++ parseFold' 'y' FoldY
+  parseFold' c op = string "fold along " *> char c *> char '=' $> op
+
+parseInstructions :: ReadP Instructions
+parseInstructions = do
+  ds <- many $ do
+    x <- parseInt
+    void $ char ','
+    y <- parseInt
+    skipSpaces
+    pure $ (x,y)
+  fs <- many $ parseFold <* skipSpaces
+  pure $ Instructions ds fs
+
+instance Read Instructions where
+  readsPrec _ = readP_to_S parseInstructions
+
+data Pixels = Pixels { getPixels :: Array (Int,Int) Bool }
+
+makePixels :: [(Int,Int)] -> Pixels
+makePixels ps = Pixels $ accumArray (\_ _ -> True) False  ((0,0),(xMax,yMax)) mps where
+  xMax = maximum $ map fst ps
+  yMax = maximum $ map snd ps
+  mps = [(p,()) | p <- ps]
+
+showPixels :: Pixels -> String
+showPixels (Pixels parr) = unlines scanLines where
+  scanLines = [ [ toPixel $ parr ! (x,y) | x <- [0..xMax] ] | y <- [0..yMax] ]
+  ((0,0),(xMax,yMax)) = bounds parr
+  toPixel True = '#'
+  toPixel False = '.'
+
+interpret1 :: Fold -> Pixels -> Pixels
+interpret1 (FoldX x) = foldX x
+interpret1 (FoldY y) = foldY y
+
+overlay :: Pixels -> Pixels -> Pixels
+overlay (Pixels parr) (Pixels qarr) = Pixels rarr where
+  rarr = if bounds parr == bounds qarr
+         then array (bounds parr) [ (p, parr ! p || qarr ! p) | p <- range . bounds $ parr]
+         else error $ unwords ["overlay: nonconforming Pixel arrays"
+                              , show . bounds $ parr
+                              , show . bounds $ qarr
+                              ]
+
+cutX  :: Int -> Pixels -> (Pixels,Pixels)
+cutX foldCol (Pixels parr) = (Pixels qarr, Pixels rarr) where
+  ((0,0),(xMax,yMax)) = bounds parr
+  xMaxQ = foldCol - 1
+  qarr = array ((0,0),(xMaxQ,yMax)) [ ((x,y),parr ! (x,y)) | x <- [0..xMaxQ], y <- [0..yMax] ]
+  xMaxR = xMax - foldCol- 1
+  rarr = array ((0,0),(xMaxR,yMax)) [((x,y), parr ! (x+foldCol+1,y)) | x <- [0..xMaxR], y <-[0..yMax] ]
+
+cutY :: Int -> Pixels -> (Pixels,Pixels)
+cutY foldRow (Pixels parr) = (Pixels qarr, Pixels rarr) where
+  ((0,0),(xMax,yMax)) = bounds parr
+  yMaxQ = foldRow - 1
+  qarr = array ((0,0),(xMax,yMaxQ)) [ ((x,y),parr ! (x,y)) | x <- [0..xMax], y <- [0..yMaxQ] ]
+  yMaxR = yMax - foldRow - 1
+  rarr = array ((0,0),(xMax,yMaxR)) [((x,y), parr ! (x,y+foldRow+1)) | x <- [0..xMax], y <-[0..yMaxR] ]
+
+flipX :: Pixels -> Pixels
+flipX (Pixels parr) = Pixels qarr where
+  ((0,0),(xMax,yMax)) = bounds parr
+  qarr = array (bounds parr) [((x,y),parr ! (xMax - x,y)) | x <- [0..xMax], y <- [0..yMax]]
+
+flipY :: Pixels -> Pixels
+flipY (Pixels parr) = Pixels qarr where
+  ((0,0),(xMax,yMax)) = bounds parr
+  qarr = array (bounds parr) [((x,y),parr ! (x,yMax-y)) | x <- [0..xMax], y <- [0..yMax]]
+
+padX :: Int -> Pixels -> Pixels
+padX cols (Pixels parr) 
+  | cols <= 0 = (Pixels parr)
+  | otherwise = Pixels qarr where
+      ((0,0),(xMaxP,yMax)) = bounds parr
+      xMaxQ = xMaxP + cols
+      qarr = array ((0,0),(xMaxQ,yMax)) [ ((x,y), valueAt x y) | x <- [0..xMaxQ], y <- [0..yMax] ]
+      valueAt x y
+        | x < cols = False
+        | otherwise = parr ! (x-cols,y)
+
+padY :: Int -> Pixels -> Pixels
+padY rows (Pixels parr) 
+  | rows <= 0 = (Pixels parr)
+  | otherwise = Pixels qarr where
+      ((0,0),(xMax,yMaxP)) = bounds parr
+      yMaxQ = yMaxP + rows
+      qarr = array ((0,0),(xMax,yMaxQ)) [ ((x,y), valueAt x y) | x <- [0..xMax], y <- [0..yMaxQ] ]
+      valueAt x y
+        | y < rows = False
+        | otherwise = parr ! (x,y-rows)
+
+foldX :: Int -> Pixels -> Pixels
+foldX x px = padX (width right - width left) left 
+             `overlay` padX (width left - width right) (flipX right)
+    where
+    (left,right) = cutX x px
+    width (Pixels arr) = xMax + 1 where
+      ((0,0),(xMax,_)) = bounds arr
+
+foldY :: Int -> Pixels -> Pixels
+foldY y px = padY (height bottom - height top) top 
+             `overlay` padY (height top - height bottom) (flipY bottom)
+    where
+    (top,bottom) = cutY y px
+    height (Pixels arr) = yMax + 1 where
+      ((0,0),(_,yMax)) = bounds arr
+
+score :: Pixels -> Int
+score (Pixels arr) = length . filter id . elems $ arr
+
 main :: IO ()
-main = pure ()
+main = do
+  input <- read @Instructions <$> readFile "data/dots.txt"
+  let pixels = makePixels . dots $ input
+  print . score . interpret1 (head (folds input)) $ pixels
\ No newline at end of file