advent_day_06.hs

data Action = On | Off | Toggle deriving (Show, Eq)
data Rectangle = Rectangle Point Point deriving Show
data Point = Point Int Int deriving Show

-- strToInstruction :: String -> Maybe Instruction
-- strToInstruction ('t':'u':'r':'n':' ':'o':'n':xs) = Just (Instruction On (strToRectangle xs))
-- strToInstruction ('t':'u':'r':'n':' ':'o':'f':'f':' ':xs) = Just (Instruction Off (strToRectangle xs))
-- strToInstruction ('t':'o':'g':'g':'l':'e':' ': xs) = Just (Instruction Toggle (strToRectangle xs))
-- strToInstruction x = trace x Nothing

strToInstruction :: String -> Maybe Instruction
strToInstruction ('t':'u':'r':'n':' ':'o':'n':xs) = Just (Instruction On (fromJust (strToRectangle xs)))
strToInstruction ('t':'u':'r':'n':' ':'o':'f':'f':' ':xs) = Just (Instruction Off (fromJust (strToRectangle xs)))
strToInstruction ('t':'o':'g':'g':'l':'e':' ': xs) = Just (Instruction Toggle (fromJust (strToRectangle xs)))

-- pretend this can't runtime error
-- halfway fixing it by making it a Maybe Rectangle
-- but we need to use something else for the regex match to "catch" that
-- (plus not use fromJust in the caller...)
strToRectangle :: String -> Maybe Rectangle
strToRectangle xs = Just (Rectangle (Point (read x1) (read y1)) (Point (read x2) (read y2)))
	where  [_:x1:y1:x2:y2:_] = xs =~ "([0-9]+),([0-9]+) through ([0-9]+),([0-9]+)" :: [[String]]

inRectangle :: Point -> Rectangle -> Bool
inRectangle (Point x y) (Rectangle (Point x1 y1) (Point x2 y2)) = x1 <= x && x <= x2 && y1 <= y && y <= y2

rectangleToPoints :: Rectangle -> [Point]
rectangleToPoints (Rectangle (Point x1 y1) (Point x2 y2)) = concat [[Point x y  | y <- [y1..y2]] | x <- [x1..x2]]

pointToIndex :: Int -> Point -> Int
pointToIndex lengthOfSide (Point x y) = y * lengthOfSide + x

rectangleToIndices :: Int -> Rectangle -> [Int]
rectangleToIndices lengthOfSide rect = map (pointToIndex lengthOfSide) (rectangleToPoints rect)

defaultState :: Array Int Int
defaultState = array (0,999999) $ map (\x -> (x, 0)) [0..999999]

adjustState :: Array Int Int -> Int -> Int -> Array Int Int
adjustState state position newVal = state // [(position, newVal)]

changeState :: Int -> Action -> Int
changeState x On = x + 1
changeState x Toggle = x + 2
changeState 0 Off = 0
changeState x Off = x - 1

act :: Array Int Int -> Instruction -> Array Int Int
act states (Instruction action rect) = states // map (\x -> (x, changeState (states ! x) action)) indices
	where indices = rectangleToIndices 1000 rect

strToInstruction :: String -> Maybe Instruction
strToInstruction ('t':'u':'r':'n':' ':'o':'n':xs) = Just (Instruction On (fromJust (strToRectangle xs)))
strToInstruction ('t':'u':'r':'n':' ':'o':'f':'f':' ':xs) = Just (Instruction Off (fromJust (strToRectangle xs)))
strToInstruction ('t':'o':'g':'g':'l':'e':' ': xs) = Just (Instruction Toggle (fromJust (strToRectangle xs)))

-- pretend this can't runtime error
-- halfway fixing it by making it a Maybe Rectangle
-- but we need to use something else for the regex match to "catch" that
-- (plus not use fromJust in the caller...)
strToRectangle :: String -> Maybe Rectangle
strToRectangle xs = Just (Rectangle (Point (read x1) (read y1)) (Point (read x2) (read y2)))
	where  [_:x1:y1:x2:y2:_] = xs =~ "([0-9]+),([0-9]+) through ([0-9]+),([0-9]+)" :: [[String]]

inRectangle :: Point -> Rectangle -> Bool
inRectangle (Point x y) (Rectangle (Point x1 y1) (Point x2 y2)) = x1 <= x && x <= x2 && y1 <= y && y <= y2

rectangleToPoints :: Rectangle -> [Point]
rectangleToPoints (Rectangle (Point x1 y1) (Point x2 y2)) = concat [[Point x y  | y <- [y1..y2]] | x <- [x1..x2]]

pointToIndex :: Int -> Point -> Int
pointToIndex lengthOfSide (Point x y) = y * lengthOfSide + x

rectangleToIndices :: Int -> Rectangle -> [Int]
rectangleToIndices lengthOfSide rect = map (pointToIndex lengthOfSide) (rectangleToPoints rect)

defaultState :: Array Int Int
defaultState = array (0,999999) $ map (\x -> (x, 0)) [0..999999]

adjustState :: Array Int Int -> Int -> Int -> Array Int Int
adjustState state position newVal = state // [(position, newVal)]

changeState :: Int -> Action -> Int
changeState x On = x + 1
changeState x Toggle = x + 2
changeState 0 Off = 0
changeState x Off = x - 1

act :: Array Int Int -> Instruction -> Array Int Int
act states (Instruction action rect) = states // map (\x -> (x, changeState (states ! x) action)) indices
	where indices = rectangleToIndices 1000 rect

Super imperformant. Took 1m22s to solve part two of the problem!

Uses of fromJust should be removed.

We could seriously improve speed by using a MutableArray, but meh that's unsafe