Day 13

DayThirteen.hs

module DayThirteen
    ( main
    ) where
import qualified Data.Maybe as M
import qualified Data.Ord as O
import qualified Data.Text as T
import qualified Data.Text.IO as TI
import qualified Data.List as L
import qualified Data.List.Split as LS
import qualified Data.Function as F
import Debug.Trace

data Packet = LeafNode Int | Packet [Packet] deriving (Eq, Show)
data Token = OpenBracket | CloseBracket | Number Int deriving (Eq, Show)

instance Ord Packet where
  left `compare` right = left `myCompare` right

myCompare (Packet leftItems) (LeafNode rightItem) = myCompare (Packet leftItems) (Packet [LeafNode rightItem])
myCompare (LeafNode leftItem) (Packet rightItems) = myCompare (Packet [LeafNode leftItem]) (Packet rightItems)
myCompare (LeafNode leftInt) (LeafNode rightInt) = O.compare leftInt rightInt
myCompare (Packet []) (Packet []) = O.EQ
myCompare (Packet leftItems) (Packet rightItems) = compare leftItems rightItems  -- thanks to a random reddit user for telling me to rely on list's ord instance

compareStrings = myCompare `F.on` parseAndUnwrap

parseAndUnwrap string = head children
  where ((Packet children), _) = parsed
        parsed = parseToPacket (Packet []) lexed
        lexed = lexTree string

parseToPacket :: Packet -> [Token] -> (Packet, [Token])
parseToPacket a [] = (a, [])
parseToPacket (Packet children) (OpenBracket:rest) = parseToPacket (Packet $ children ++ [subLeafNode]) newRemaining
  where (subLeafNode, newRemaining) = parseToPacket (Packet []) rest
parseToPacket packet@(Packet children) (CloseBracket:rest) = (packet, rest)
parseToPacket (Packet children) ((Number n):rest) = parseToPacket (Packet $ children ++ [LeafNode n]) rest

lexTree s = L.reverse $ myLex [] s
  where myLex current "" = current
        myLex current ('[':rest) = myLex (OpenBracket:current) rest
        myLex current (']':rest) = myLex (CloseBracket:current) rest
        myLex current (',':rest) = myLex current rest
        myLex current toLex = myLex ((Number (read headDigits)):current) (L.drop (length headDigits) toLex)
          where headDigits = L.takeWhile (\c -> c `L.elem` "1234567890") toLex

getLines path = do
  input <- TI.readFile path
  return $ T.lines input

main lines = badIndices
  where nonempty = filter (/= "") $ map T.unpack lines
        chunks = LS.chunksOf 2 nonempty
        compareChunk [a,b] = compareStrings a b
        comparisons = map compareChunk chunks
        badIndices = L.findIndices isBad chunks
        isBad chunk = (compareChunk chunk) == LT
        inc x = x + 1

decoderOne = "[[2]]"
decoderTwo = "[[6]]"

partTwo lines = L.findIndices (\line -> (line == (parseAndUnwrap decoderOne) || line == (parseAndUnwrap decoderTwo))) sorted
  where nonempty = [decoderOne, decoderTwo] ++ (filter (/= "") $ map T.unpack (lines))
        sorted = L.sort $ map parseAndUnwrap nonempty