Day13.hs

module Javran.AdventOfCode.Y2023.Day13 () where

import Control.Monad
import Data.Function
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.List.Split hiding (sepBy)
import Data.Monoid hiding (First, Last)
import Javran.AdventOfCode.Prelude

data Day13 deriving (Generic)

{-
  Turns a list into all of its zippers that are not empty on either sides.

  e.g.

    [a, b, c, d] =>

    [ ([a], [b, c, d])
    , ([b, a], [c, d])
    , ([c, b, a], [d])
    ]

  Since a list zipper pushes elements backwards as it moves to the end,
  we can do a quick `zipWith` to test whether a zipper is currently
  focusing on a reflection point.

 -}
zippers :: [a] -> [] (NE.NonEmpty a, NE.NonEmpty a)
zippers =
  unfoldr
    ( \(xs, ys) -> do
        hd : tl <- pure ys
        p <- (hd NE.:| xs,) <$> NE.nonEmpty tl
        pure (p, (hd : xs, tl))
    )
    . ([],)

{-
  Finds reflections in a list, return indices of the reflection
  (1-based to be compatible with problem's description)

  Note that this is implemented as if input is a 1d array.
  Therefore for row major order representation,
  this finds horizontal reflection lines.
 -}
reflections :: Eq a => [a] -> [Int]
reflections xs = catMaybes (zipWith go [1 ..] (zippers xs))
  where
    go i (ls, rs) =
      i <$ guard (and (NE.zipWith (==) ls rs))

{-
  Returns (horizontal answers, vertical answers).
 -}
allReflections :: Eq a => [[a]] -> ([Int], [Int])
allReflections x = (reflections x, reflections (transpose x))

{-
  Applies a function exactly once to one element of the list,
  nondeterminstically.
 -}
listEdits :: (a -> [a]) -> [a] -> [] [a]
listEdits f = fix \self -> \case
  [] -> []
  hd : tl -> fmap (: tl) (f hd) <> fmap (hd :) (self tl)

{-
  Flips exactly one bit of the input 2d configuration, nondeterminstically.
 -}
alternatives :: [[Bool]] -> [] [[Bool]]
alternatives = listEdits (listEdits (pure . not))

{-
  Solves p1 and p2 at the same time, as p2 needs some info from p1 results.
 -}
solve :: [[Bool]] -> (Sum Int, Sum Int)
solve x = (Sum $ reflectionsToAns refs, Sum $ reflectionsToAns p2)
  where
    reflectionsToAns (ls, rs) = sum ls * 100 + sum rs
    refs@(a0, b0) = allReflections x

    p2 = head do
      x' <- alternatives x
      refs'@(a1, b1) <- [allReflections x']
      guard $ not (null (a1 <> b1)) && refs' /= refs
      pure (a1 \\ a0, b1 \\ b0)

instance Solution Day13 where
  solutionRun _ SolutionContext {getInputS, answerShow} = do
    inp <- splitOn [""] . lines <$> getInputS
    let xs =
          (fmap . fmap . fmap)
            ( \case
                '.' -> False
                '#' -> True
                _ -> errInvalid
            )
            inp
        (Sum p1, Sum p2) = foldMap solve xs

    answerShow p1
    answerShow p2