{-# Language QuasiQuotes, DataKinds, GADTs, ImportQualifiedPost, MonadComprehensions #-}
{-|
Module      : Main
Description : Day 5 solution
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2023/day/5>

Given many layers of linear shifts of intervals we need
to efficiently apply those shifts to a number of input
ranges and find the lowest bound of the output intervals.

>>> :{
:main +
"seeds: 79 14 55 13
\nseed-to-soil map:
50 98 2
52 50 48
\nsoil-to-fertilizer map:
0 15 37
37 52 2
39 0 15
\nfertilizer-to-water map:
49 53 8
0 11 42
42 0 7
57 7 4
\nwater-to-light map:
88 18 7
18 25 70
\nlight-to-temperature map:
45 77 23
81 45 19
68 64 13
\ntemperature-to-humidity map:
0 69 1
1 0 69
\nhumidity-to-location map:
60 56 37
56 93 4
"
:}
35
46

-}
module Main where

import Advent (format, chunks)
import Advent.Box (intersectBox, Box', Box(..), subtractBox')
import Control.Exception (assert)
import Control.Monad (foldM)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
-- |
--
-- >>> :main
-- 457535844
-- 41222968
main :: IO ()
IO ()
main =
 do ([Int]
seeds, [(String, String, [(Int, Int, Int)])]
rawMaps) <- [format|2023 5 seeds:( %d)*%n(%n%s-to-%s map:%n(%d %d %d%n)*)*|]
    let maps :: [IntervalRewriter]
maps = [(String, String, [(Int, Int, Int)])] -> [IntervalRewriter]
checkMaps [(String, String, [(Int, Int, Int)])]
rawMaps
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([IntervalRewriter] -> [Interval] -> Int
smallestDestination [IntervalRewriter]
maps [Int -> Int -> Interval
interval Int
start Int
1 | Int
start     <-          [Int]
seeds])
    Int -> IO ()
forall a. Show a => a -> IO ()
print ([IntervalRewriter] -> [Interval] -> Int
smallestDestination [IntervalRewriter]
maps [Int -> Int -> Interval
interval Int
start Int
n | [Int
start,Int
n] <- Int -> [Int] -> [[Int]]
forall a. Int -> [a] -> [[a]]
chunks Int
2 [Int]
seeds])

-- | Map from lower-bound to (upper-bound, shift amount)
type IntervalRewriter = Map Int (Int, Int)

-- | Apply all the maps to all the intervals and return the smallest output
smallestDestination :: [IntervalRewriter] -> [Interval] -> Int
smallestDestination :: [IntervalRewriter] -> [Interval] -> Int
smallestDestination [IntervalRewriter]
maps = Interval -> Int
Box ('S 'Z) -> Int
lowerBound (Box ('S 'Z) -> Int)
-> ([Box ('S 'Z)] -> Box ('S 'Z)) -> [Box ('S 'Z)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Box ('S 'Z)] -> Box ('S 'Z)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Box ('S 'Z)] -> Box ('S 'Z))
-> ([Box ('S 'Z)] -> [Box ('S 'Z)]) -> [Box ('S 'Z)] -> Box ('S 'Z)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box ('S 'Z) -> [Box ('S 'Z)]) -> [Box ('S 'Z)] -> [Box ('S 'Z)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([IntervalRewriter] -> Interval -> [Interval]
applyMaps [IntervalRewriter]
maps)

-- Verify that all the maps are presented in order.
-- Construct an interval rewriter from each sublist of entries
checkMaps :: [(String, String, [(Int, Int, Int)])] -> [IntervalRewriter]
checkMaps :: [(String, String, [(Int, Int, Int)])] -> [IntervalRewriter]
checkMaps [(String, String, [(Int, Int, Int)])]
input = Bool -> [IntervalRewriter] -> [IntervalRewriter]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ([String]
froms [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"location"] [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== String
"seed" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
tos) (([(Int, Int, Int)] -> IntervalRewriter)
-> [[(Int, Int, Int)]] -> [IntervalRewriter]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Int, Int)] -> IntervalRewriter
forall {b}. (Ord b, Num b) => [(b, b, b)] -> Map b (b, b)
toRewriter [[(Int, Int, Int)]]
maps)
  where
    ([String]
froms, [String]
tos, [[(Int, Int, Int)]]
maps) = [(String, String, [(Int, Int, Int)])]
-> ([String], [String], [[(Int, Int, Int)]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(String, String, [(Int, Int, Int)])]
input
    toRewriter :: [(b, b, b)] -> Map b (b, b)
toRewriter [(b, b, b)]
xs = [(b, (b, b))] -> Map b (b, b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(b
src,  (b
src b -> b -> b
forall a. Num a => a -> a -> a
+ b
len, b
dst b -> b -> b
forall a. Num a => a -> a -> a
- b
src)) | (b
dst, b
src, b
len) <- [(b, b, b)]
xs]

-- | Apply the rewrite maps left to right to the input interval.
applyMaps :: [IntervalRewriter] -> Interval -> [Interval]
applyMaps :: [IntervalRewriter] -> Interval -> [Interval]
applyMaps = (Box ('S 'Z) -> [IntervalRewriter] -> [Box ('S 'Z)])
-> [IntervalRewriter] -> Box ('S 'Z) -> [Box ('S 'Z)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Box ('S 'Z) -> IntervalRewriter -> [Box ('S 'Z)])
-> Box ('S 'Z) -> [IntervalRewriter] -> [Box ('S 'Z)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((IntervalRewriter -> Box ('S 'Z) -> [Box ('S 'Z)])
-> Box ('S 'Z) -> IntervalRewriter -> [Box ('S 'Z)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip IntervalRewriter -> Interval -> [Interval]
IntervalRewriter -> Box ('S 'Z) -> [Box ('S 'Z)]
applyMap))

-- | Apply a single rewrite map to an input interval.
applyMap :: IntervalRewriter -> Interval -> [Interval]
applyMap :: IntervalRewriter -> Interval -> [Interval]
applyMap IntervalRewriter
intervals Interval
x =
  [Box ('S 'Z)] -> Maybe [Box ('S 'Z)] -> [Box ('S 'Z)]
forall a. a -> Maybe a -> a
fromMaybe [Interval
Box ('S 'Z)
x]
  [ Int -> Interval -> Interval
shiftInterval Int
d Interval
Box ('S 'Z)
overlap
  Box ('S 'Z) -> [Box ('S 'Z)] -> [Box ('S 'Z)]
forall a. a -> [a] -> [a]
: (Box ('S 'Z) -> [Box ('S 'Z)]) -> [Box ('S 'Z)] -> [Box ('S 'Z)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (IntervalRewriter -> Interval -> [Interval]
applyMap IntervalRewriter
intervals) (Box ('S 'Z) -> Box ('S 'Z) -> [Box ('S 'Z)]
forall (n :: Nat). Box n -> Box n -> [Box n]
subtractBox' Box ('S 'Z)
overlap Interval
Box ('S 'Z)
x)
  | (Int
lo, (Int
hi, Int
d)) <- Int -> IntervalRewriter -> Maybe (Int, (Int, Int))
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLT (Interval -> Int
upperBound Interval
x) IntervalRewriter
intervals
  , Box ('S 'Z)
overlap       <- Box ('S 'Z) -> Box ('S 'Z) -> Maybe (Box ('S 'Z))
forall (n :: Nat). Box n -> Box n -> Maybe (Box n)
intersectBox (Int -> Int -> Box 'Z -> Box ('S 'Z)
forall (n :: Nat). Int -> Int -> Box n -> Box ('S n)
Dim Int
lo Int
hi Box 'Z
Pt) Interval
Box ('S 'Z)
x
  ]

-- Interval specialization of the Box module

-- | A one-dimensional cuboid
type Interval = Box' 1

-- | Construct an interval from a starting point and positive length
interval :: Int {- ^ start -} -> Int {- ^ length -} -> Interval
interval :: Int -> Int -> Interval
interval Int
start Int
len = Int -> Int -> Box 'Z -> Box ('S 'Z)
forall (n :: Nat). Int -> Int -> Box n -> Box ('S n)
Dim Int
start (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len) Box 'Z
Pt

-- | Modify the lower and upper bounds of an interval by a fixed amount.
shiftInterval :: Int -> Interval -> Interval
shiftInterval :: Int -> Interval -> Interval
shiftInterval Int
delta (Dim Int
lo Int
hi Box n
Pt) = Int -> Int -> Box 'Z -> Box ('S 'Z)
forall (n :: Nat). Int -> Int -> Box n -> Box ('S n)
Dim (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta) (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta) Box 'Z
Pt

-- | Retrieve the inclusive lower-bound of an interval
lowerBound :: Interval -> Int
lowerBound :: Interval -> Int
lowerBound (Dim Int
x Int
_ Box n
Pt) = Int
x

-- | Retrieve the exclusive upper-bound of an interval
upperBound :: Interval -> Int
upperBound :: Interval -> Int
upperBound (Dim Int
_ Int
x Box n
Pt) = Int
x