{-# 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 (main) where

import Advent (format, chunks)
import Advent.Box (intersectBox, Box', Box(..), subtractBox')
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 (seeds, rawMaps) <- [format|2023 5 seeds:( %d)*%n(%n%s-to-%s map:%n(%d %d %d%n)*)*|]
    let maps = [(String, String, [(Int, Int, Int)])] -> [IntervalRewriter]
checkMaps [(String, String, [(Int, Int, Int)])]
rawMaps
    print (smallestDestination maps [interval start 1 | start     <-          seeds])
    print (smallestDestination maps [interval start n | [start,n] <- chunks 2 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)

-- Construct an interval rewriter from each sublist of entries
-- from seed to location
checkMaps :: [(String, String, [(Int, Int, Int)])] -> [IntervalRewriter]
checkMaps :: [(String, String, [(Int, Int, Int)])] -> [IntervalRewriter]
checkMaps [(String, String, [(Int, Int, Int)])]
input = String
-> Map String (String, [(Int, Int, Int)]) -> [IntervalRewriter]
go String
"seed" Map String (String, [(Int, Int, Int)])
maps
  where
    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]
    maps :: Map String (String, [(Int, Int, Int)])
maps = [(String, (String, [(Int, Int, Int)]))]
-> Map String (String, [(Int, Int, Int)])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
src, (String
dst, [(Int, Int, Int)]
entries)) | (String
src, String
dst, [(Int, Int, Int)]
entries) <- [(String, String, [(Int, Int, Int)])]
input]
    go :: String
-> Map String (String, [(Int, Int, Int)]) -> [IntervalRewriter]
go String
"location" Map String (String, [(Int, Int, Int)])
_ = []
    go String
k Map String (String, [(Int, Int, Int)])
m | (String
k', [(Int, Int, Int)]
x) <- Map String (String, [(Int, Int, Int)])
maps Map String (String, [(Int, Int, Int)])
-> String -> (String, [(Int, Int, Int)])
forall k a. Ord k => Map k a -> k -> a
Map.! String
k = [(Int, Int, Int)] -> IntervalRewriter
forall {b}. (Ord b, Num b) => [(b, b, b)] -> Map b (b, b)
toRewriter [(Int, Int, Int)]
x IntervalRewriter -> [IntervalRewriter] -> [IntervalRewriter]
forall a. a -> [a] -> [a]
: String
-> Map String (String, [(Int, Int, Int)]) -> [IntervalRewriter]
go String
k' (String
-> Map String (String, [(Int, Int, Int)])
-> Map String (String, [(Int, Int, Int)])
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
k Map String (String, [(Int, Int, Int)])
m)

-- | 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