Day Twelve

day_twelve_2023.hs

{-# LANGUAGE OverloadedStrings #-}
module DayTwelve where

import qualified Data.Text as T
import Data.Ratio ((%))
import qualified Data.List as L
import qualified Text.Read as TR
import Debug.Trace (traceShowId, traceShow)
import qualified Data.Maybe as M
import qualified Data.Map as DM
import qualified Data.Set as S
import qualified Data.List.Split as DLS
import qualified Data.Range as R
import Data.Range ((+=+), (+=*))
import Safe (atDef, atMay, minimumMay, headMay, headDef)

-- SETUP
data Tile = Working | Broken | Unknown deriving (Eq, Ord)
data Row = Row [Tile] [Int] deriving (Eq, Show, Ord)
getTiles (Row tiles _) = tiles
getSegmentSpecification (Row _ segments) = segments
rowSize = length . getTiles

instance Show Tile where
  show Unknown = "?"
  show Broken = "#"
  show _ = "."


edgecaseRow = parseRow ".?##???.#?.... 3,2"


testRows :: [T.Text]
testRows = ["???.### 1,1,3",
            ".??..??...?##. 1,1,3",
            "?#?#?#?#?#?#?#? 1,3,1,6",
            "????.#...#... 4,1,1",
            "????.######..#####. 1,6,5",
            "?###???????? 3,2,1"]

parseTile '#' = Broken
parseTile '?' = Unknown
parseTile _  = Working

tails items@(h:r) = items:(tails r)
tails [] = []

cacheable bigRow@(Row tiles sizes) = do
  subInstructions <- tails (sizes)
  subTiles <- tails $ drop 10 tiles
  [Row subTiles subInstructions]

expandRow times row = Row expanded instructions
  where expanded = L.intercalate [Unknown] $ take times $ cycle $ [getTiles row]
        instructions = concat $ take times $ cycle [getSegmentSpecification row]


parseRow :: T.Text -> Row
parseRow row = Row tilesList sizesList
  where sizesList :: [Int]
        sizesList = M.catMaybes $ map (TR.readMaybe . T.unpack) $ T.split (== ',') sizes
        layout:sizes:_ = T.split (== ' ') row
        tilesList = map parseTile (T.unpack layout)


fastSolutionCount remainingRow@(Row tiles []) cache = if (any (== Broken) tiles) then 0 else 1
fastSolutionCount remainingRow@(Row tiles toPlace@(currentTask:rest)) cache
  | DM.member remainingRow cache = cache DM.! remainingRow
  | chopOutBoring remainingRow /= remainingRow = fastSolutionCount (chopOutBoring remainingRow) cache
  | otherwise = sum childAnswers
  where lp = legalPlacements remainingRow currentTask
        childAnswers = map recur lp
        recur newPlacementIndex = fastSolutionCount (Row (drop n tiles) rest) cache
          where n = newPlacementIndex + currentTask + 1


-- this just skips the fast-lookup step on the first level of recursion
getCountForCache remainingRow@(Row tiles []) cache = if (any (== Broken) tiles) then 0 else 1
getCountForCache remainingRow@(Row tiles toPlace@(currentTask:rest)) cache
  | chopOutBoring remainingRow /= remainingRow = fastSolutionCount (chopOutBoring remainingRow) cache
  | otherwise = sum childAnswers
  where lp = legalPlacements remainingRow currentTask
        childAnswers = map recur lp
        recur newPlacementIndex = fastSolutionCount (Row (drop n tiles) rest) cache
          where n = newPlacementIndex + currentTask + 1


legalPlacements :: Row -> Int -> [Int]
legalPlacements row@(Row tiles _) placingSize = filter canPlace indices
  where canPlace idx = inMultirange usable ourRange  && (avoidsMessyOverlaps broken ourRange)
          where ourRange = (idx +=+ (idx + placingSize - 1))
        usable = usableIndices row
        broken = brokenIndices row
        indices = 0 `enumFromTo` max
        nextBrokenSpot = fmap inc $ headMay $ L.elemIndices Broken tiles
        inc x = x + 1
        max = head $ M.catMaybes [nextBrokenSpot, Just ((rowSize row) - placingSize)]
        avoidsMessyOverlaps world current = (all (inMultirange [current]) potentialHits) && (head (R.joinRanges [current])) `elem` (R.joinRanges (current:world))
          where potentialHits = filter (R.rangesAdjoin current) world



chopOutBoring row@(Row tiles sizes) = Row newTiles sizes
  where newTiles = dropWhile (== Working) tiles


usableIndices row = R.joinRanges $ map R.SingletonRange $ (L.elemIndices Broken tiles) ++ (L.elemIndices Unknown tiles)
  where tiles = getTiles row

unknownIndices row = R.joinRanges $ map R.SingletonRange $ (L.elemIndices Unknown tiles)
  where tiles = getTiles row

brokenIndices row = R.joinRanges $ map R.SingletonRange (L.elemIndices Broken tiles)
  where tiles = getTiles row

inMultirange ranges candidate = R.intersection ranges cr == cr
  where cr = R.joinRanges [candidate]


partTwo copiesCount row = fastSolutionCount bigRow builtCache
  where bigRow = expandRow copiesCount row
        cacheKeys = cacheable bigRow
        builtCache = DM.fromList $ map (\x -> (x, getCountForCache x builtCache)) cacheKeys