Day 15 AOC 2023

day_fifteen_2023.hs

{-# LANGUAGE OverloadedStrings #-}
module DayFifteen 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 qualified Data.Sequence as DS
import Data.Sequence ((<|), (|>))
import Data.Range ((+=+), (+=*))
import Safe (atDef, atMay, minimumMay, headMay, headDef)
import Data.Char (ord)
import Data.Foldable (toList)


testInput :: T.Text
testInput = "rn=1,cm-,qp=3,cm=2,qp-,pc=4,ot=9,ab=5,pc-,pc=6,ot=7"

data Instruction = Assign String Int | Delete String deriving (Show, Ord, Eq)

sameLabel left right = getLabel left == getLabel right

type Database = DS.Seq (DS.Seq Instruction)

getAddress = hashString . getLabel

getFocalLength instruction@(Assign s i) = i
getFocalLength _ = 0

getLabel instruction@(Assign s _) = s
getLabel instruction@(Delete s) = s

hashString :: String -> Int
hashString s = go 0 s
  where go currentValue [] = currentValue
        go currentValue (h:r) = go (f h) r
          where f = (`mod` 256) . ((*) 17) . ((+) currentValue) . ord

partOne input = sum $ map (hashString . T.unpack) $ T.split (== ',') input

parseInput s = map parseInstruction $ T.split (== ',') s
  where parseInstruction instructionString
          | T.last instructionString == '-' = Delete (T.unpack (T.dropEnd 1 instructionString))
          | otherwise = Assign (T.unpack textbeforeEquals) (read (T.unpack newValue))
              where textbeforeEquals:(newValue:_) = T.split (== '=') instructionString


emptyDatabase :: Database
emptyDatabase = DS.replicate 256 DS.empty

sequenceHas sequence predicate = not $ null $ DS.findIndicesL predicate sequence

applyInstruction db instruction@(Assign s i) = DS.adjust (performInsert instruction) (getAddress instruction) db
applyInstruction db instruction@(Delete s) = DS.adjust (performDelete instruction) (getAddress instruction) db


performInsert instruction box = head $ M.catMaybes [replaced, inserted]
  where replaced = do
                     idx <- DS.findIndexL (sameLabel instruction) box
                     Just (DS.update idx instruction box)
        inserted = Just (box |> instruction)


performDelete instruction box = head $ M.catMaybes [deleted, (Just box)]
  where deleted = do
                     idx <- DS.findIndexL (sameLabel instruction) box
                     Just (DS.deleteAt idx box)

scoreDatabase db = sum $ map (uncurry scoreBox) $ (zip (toList db) (enumFrom 0))

scoreBox box boxIndex = sum $ map scoreLens (zip (toList box) (enumFrom 0))
  where scoreLens (lens, lensIndex) = (1 + boxIndex) * (1 + lensIndex) * (getFocalLength lens)

applyAllInstructions :: [Instruction] -> Database
applyAllInstructions instructions = foldl applyInstruction emptyDatabase instructions

partTwo = scoreDatabase . applyAllInstructions