Day 14 advent of code broken code

main.hs

    {-# LANGUAGE BlockArguments, Strict, LambdaCase, NoMonomorphismRestriction, MultiWayIf #-}
    import Control.Monad.State.Strict
    import Data.List
    import Data.Char
    import Data.Ord hiding (Down)
    import Data.Bifunctor
    import Data.Function
    import Data.Functor.Identity
    import Debug.Trace

    alterF = modify . first
    alterS = modify . second
    focusMap x y f g = modifyAt y (modifyAt x f) g where
      modifyAt n f = map (snd . mapAt n f) . zipWith (,) [0..]
        where mapAt n f (i,v) | n == i    = (i,f v)
                              | otherwise = (i,v)


    getInput = readFile "/tmp/inputtest.txt" >>= pure . map (unfoldr breakApart) . lines where
      breakApart [] = Nothing
      breakApart line = 
        let (captured, remainder) = break (=='-') line
        in case captured of
          [] -> undefined
          _  -> let (x,y) = bimap (filter (`notElem` ", >")) (filter (`notElem` ", >")) $ break (==',') captured
                in Just ((read @Int x, read @Int y), if null remainder then [] else tail remainder)


    makeGrid :: [[(Int,Int)]] -> (Int,[[Int]])
    makeGrid input = (smallestX,) . fst . snd $ fillInRocks
      where
        (smallestX,_) = minimumBy (comparing fst) $ concat input
        (maxX,maxY)   = bimap maximum maximum . unzip $ concat input
        grid          = replicate (maxY + 1) (map (const 0) [1..(maxX - smallestX + 1)])

        forEach xs state' f = foldM (\st x -> runState (f x) st) state' xs

        fillInRocks         = forEach input (grid,Nothing) compute

        makeRange a b | a > b     = [b..a]
                      | otherwise = [a..b]

        compute :: [(Int,Int)] -> State ([[Int]],Maybe (Int,Int)) ()
        compute []          = alterS (const Nothing) >> pure ()
        compute ((x,y):xys) = gets snd >>= \case
          Nothing      -> do let x' = x - smallestX
                             alterF (focusMap x' y (const 1))
                             alterS (const (Just (x',y)))
                             compute xys
          Just (x',y') -> do let xrange = makeRange x' (x - smallestX )
                             let yrange = makeRange y' y
                             forM_ xrange \xpos ->
                               forM_ yrange \ypos ->
                                 alterF (focusMap xpos ypos (const 1))
                             alterS (const (Just (x - smallestX,y)))
                             compute xys


    gridZipper grid beginAt f fstate = runState (move beginAt) (((0,0),[[]],grid),fstate) where
      tailOrEmpty [] = []
      tailOrEmpty t  = tail t
      move (nx,ny) = gets fst >>= \((x,y),backwards,forwards) -> if
        | ny > y    -> alterF (const ((x,y + 1),([] : (head backwards ++ head forwards) : tailOrEmpty backwards),(tail forwards))) >> move (nx,ny) 
        | ny < y    -> alterF (const ((x,y - 1),(tailOrEmpty backwards),([] : (head backwards ++ head forwards) : tailOrEmpty forwards))) >> move (nx,ny) 
        | otherwise -> if
            | nx > x    -> alterF (const ((nx,y),((head backwards ++ take (nx - x) (head forwards)) : tailOrEmpty backwards),(drop (nx - x) (head forwards) : tailOrEmpty forwards))) >> move (nx,ny) 
            | nx < x    -> alterF (const ((nx,y),(drop (nx - x) (head backwards) : tailOrEmpty backwards),(take (nx - x) (head backwards) : tailOrEmpty forwards))) >> move (nx,ny)
            | otherwise -> if
              | null (head forwards) -> gets snd >>= \fstate -> f fstate Nothing (x,y) (alterS . const) move
              | otherwise -> gets snd >>= \fstate -> f fstate (Just (head (head forwards))) (x,y) (alterS . const) move



    data Attempted = Down | LeftDown | RightDown deriving (Eq,Show)

    type Position = (Int,Int)
    type SolutionState = (Int,[Position],Attempted)
    type PartialGrid = [[Int]]

    solve beginAt grid = _a $ gridZipper grid beginAt sandify (0,[],Down) where
      ---sandify :: SolutionState
      ---        -> Maybe Int
      ---        -> Position
      ---        -> SolutionState
      ---        -> StateT ((Position, PartialGrid, PartialGrid), SolutionState) Data.Functor.Identity.Identity Int
      ---        -> w
      ---        -> Int
      sandify :: (Integer, [(Int,Int)], Attempted)
             -> Maybe Int
             -> (Int, Int)
             -> ((Integer, [(Int,Int)], Attempted) -> StateT (((Int, Int), [[(Int, Int)]], [[(Int, Int)]]), (Integer, [(Int, Int)], Attempted)) Identity ())
             -> ((Int, Int)
                 -> StateT
                      (((Int, Int), [[(Int,Int)]], [[(Int,Int)]]), (Integer, [(Int,Int)], Attempted))
                      Identity
                      Integer)
             -> StateT
                  (((Int, Int), [[(Int,Int)]], [[(Int,Int)]]), (Integer, [(Int,Int)], Attempted))
                  Identity
                  Integer
      sandify (count,_,_)     Nothing _     _    _ = pure count
      sandify (count,hist,at) current (x,y) swap move 
        | current == Just 1 || current == Just 2 = if
          | at == Down      -> do swap (count, tail hist, LeftDown)
                                  move (bimap (-1) (+1) $ head $ tail hist)
          | at == LeftDown  -> do swap (count, tail hist, RightDown)
                                  move (bimap (+1) (+1) $ head $ tail hist)
          | at == RightDown -> do swap (count + 1, tail (tail hist), Down)
                                  alterF (\(pos,b,f) -> (pos,focusMap 1 1 (const 2) b, f))
                                  move (head (tail hist))
        | otherwise = swap (count, ((x,y) : hist), at) >> move (x,y + 1)


    prettyGrid = putStrLn . unlines . (map unwords)  . map (map (\c -> if c == 1 then "#" else "."))


    main = do
      (smallestX,grid) <- makeGrid <$> getInput :: IO (Int, [[Int]])
      print $ (solve (500 - smallestX,0) grid  :: Integer)
      pure ()

non_compile.txt

Main.hs:80:55: error:
    • Couldn't match type ‘(Int, Int)’ with ‘Int’
      Expected: (Integer, [(Int, Int)], Attempted)
                -> Maybe Int
                -> (Int, Int)
                -> ((Integer, [(Int, Int)], Attempted)
                    -> StateT
                         (((Int, Int), [[(Int, Int)]], [[(Int, Int)]]),
                          (Integer, [(Int, Int)], Attempted))
                         Identity
                         ())
                -> ((Int, Int)
                    -> StateT
                         (((Int, Int), [[Int]], [[Int]]),
                          (Integer, [(Int, Int)], Attempted))
                         Identity
                         Integer)
                -> StateT
                     (((Int, Int), [[Int]], [[Int]]),
                      (Integer, [(Int, Int)], Attempted))
                     Identity
                     Integer
        Actual: (Integer, [(Int, Int)], Attempted)
                -> Maybe Int
                -> (Int, Int)
                -> ((Integer, [(Int, Int)], Attempted)
                    -> StateT
                         (((Int, Int), [[(Int, Int)]], [[(Int, Int)]]),
                          (Integer, [(Int, Int)], Attempted))
                         Identity
                         ())
                -> ((Int, Int)
                    -> StateT
                         (((Int, Int), [[(Int, Int)]], [[(Int, Int)]]),
                          (Integer, [(Int, Int)], Attempted))
                         Identity
                         Integer)
                -> StateT
                     (((Int, Int), [[(Int, Int)]], [[(Int, Int)]]),
                      (Integer, [(Int, Int)], Attempted))
                     Identity
                     Integer
    • In the third argument of ‘gridZipper’, namely ‘sandify’
      In the second argument of ‘($)’, namely
        ‘gridZipper grid beginAt sandify (0, [], Down)’
      In the expression:
        _a $ gridZipper grid beginAt sandify (0, [], Down)