-- import qualified Data.Text.IO as TIO
import qualified Data.Map.Strict as M
-import Data.Map.Strict ((!))
+-- import Data.Map.Strict ((!))
import qualified Data.PQueue.Prio.Min as P
import qualified Data.Set as S
import qualified Data.Sequence as Q
import Data.Sequence ((<|), (|>), (><))
import Data.Foldable (toList, foldr', foldl', all)
-import Data.Maybe (fromJust)
-import Data.List
+-- import Data.Maybe (fromJust)
+-- import Data.List
import Data.Char
import Control.Monad.Reader
+import Control.Lens hiding ((<|), (|>))
+-- import Data.Map.Lens
type Position = (Integer, Integer) -- r, c
type PointOfInterest = M.Map Position Char
-data Explorer = Explorer { _position :: Position
- , _keysHeld :: Keys
- } deriving (Eq, Ord, Show)
-type ExploredStates = S.Set Explorer
+class (Eq e, Ord e) => ExplorerC e where
+ successors :: e -> CaveContext (Q.Seq e)
+ estimateCost :: e -> CaveContext Int
+ -- positionE :: e -> Position
+ keysHeldE :: e -> Keys
+ emptyExplorer :: e
+
+
+data Explorer1 = Explorer1 { _position1 :: Position
+ , _keysHeld1 :: Keys
+ } deriving (Eq, Ord, Show)
+data Explorer4 = Explorer4 { _position4 :: S.Set Position
+ , _keysHeld4 :: Keys
+ } deriving (Eq, Ord, Show)
+type ExploredStates e = S.Set e
type Cave = S.Set Position
data CaveComplex = CaveComplex { _cave :: Cave
} deriving (Eq, Ord, Show)
type CaveContext = Reader CaveComplex
-data Agendum = Agendum { _current :: Explorer
- , _trail :: Q.Seq Explorer
+data Agendum e = Agendum { _current :: e
+ , _trail :: Q.Seq e
, _cost :: Int} deriving (Show, Eq)
-type Agenda = P.MinPQueue Int Agendum
-type Candidates = S.Set (Int, Agendum)
-
+type Agenda e = P.MinPQueue Int (Agendum e)
+-- type Candidates e = S.Set (Int, Agendum e)
+
+instance ExplorerC Explorer1 where
+ successors explorer =
+ do let here = _position1 explorer
+ let locations0 = possibleNeighbours here
+ cave <- asks _cave
+ keys <- asks _keys
+ doors <- asks _doors
+ let keysHeld = _keysHeld1 explorer
+ let locations1 = Q.filter (`S.member` cave) locations0
+ let locations2 = Q.filter (hasKeyFor doors keysHeld) locations1
+ return $ fmap (\l -> explorer { _position1 = l, _keysHeld1 = pickupKey keys keysHeld l}) locations2
+
+ estimateCost explorer = -- return 0
+ do keys <- asks _keys
+ let (r, c) = _position1 explorer
+ let unfoundKeys = M.keysSet $ M.filter (`S.notMember` (_keysHeld1 explorer)) keys
+ let (minR, maxR, minC, maxC) = bounds $ unfoundKeys
+ -- = minimum $ map fst $ M.keys unfoundKeys
+ -- let minC = minimum $ map snd $ M.keys unfoundKeys
+ -- let maxR = maximum $ map fst $ M.keys unfoundKeys
+ -- let maxC = maximum $ map snd $ M.keys unfoundKeys
+ let spanR = spanV r minR maxR
+ let spanC = spanV c minC maxC
+ if S.null unfoundKeys
+ then return 0
+ else return $ fromIntegral (spanR + spanC)
+ -- return $ sum $ map (manhattan here) $ M.keys unfoundKeys
+
+ -- positionE = _position1
+ keysHeldE = _keysHeld1
+ emptyExplorer = Explorer1 { _position1 = (0, 0), _keysHeld1 = S.empty }
+
+instance ExplorerC Explorer4 where
+ successors explorer =
+ do let rawHeres = _position4 explorer
+ let heres = setToSeq $ allSplits rawHeres
+ let locations0 = over (traversed . _1) possibleNeighbours heres
+ cave <- asks _cave
+ keys <- asks _keys
+ doors <- asks _doors
+ let keysHeld = _keysHeld4 explorer
+ let locations1 = over (traversed . _1) (Q.filter (`S.member` cave)) locations0
+ let locations2 = over (traversed . _1) (Q.filter (hasKeyFor doors keysHeld)) locations1
+ let locations3 = fmap (\(ls, hs) -> fmap (\l -> (l, hs)) ls) locations2
+ let locations4 = foldl1 (><) locations3
+ return $ fmap (\(l, hs) -> explorer { _position4 = S.insert l hs, _keysHeld4 = pickupKey keys keysHeld l}) locations4
+
+ estimateCost explorer = -- return 0
+ do keys <- asks _keys
+ let unfoundKeys = M.keysSet $ M.filter (`S.notMember` (_keysHeld4 explorer)) keys
+ let (minR, maxR, minC, maxC) = bounds unfoundKeys
+ let (minDR, maxDR, minDC, maxDC) = bounds $ _position4 explorer
+ let dr = abs (minR - minDR) + abs (maxR - maxDR)
+ let dc = abs (minC - minDC) + abs (maxC - maxDC)
+ if S.null unfoundKeys
+ then return 0
+ else return $ fromIntegral (dr + dc)
+ -- return $ sum $ map (manhattan here) $ M.keys unfoundKeys
+
+ -- positionE = _position1
+ keysHeldE = _keysHeld4
+ emptyExplorer = Explorer4 { _position4 = S.fromList $ replicate 4 (0, 0), _keysHeld4 = S.empty }
-- print cc
-- print explorer
print $ part1 cc explorer
+ print $ part2 cc explorer
-part1 :: CaveComplex -> Explorer -> Int
+part1 :: ExplorerC e => CaveComplex -> e -> Int
part1 cave explorer = maybe 0 (( + 1) . _cost ) result
where result = runReader (searchCave explorer) cave
-- where result = runReader (searchCave explorer) cave
-keySeq :: Agendum -> Q.Seq Keys
+part2 :: CaveComplex -> Explorer1 -> Int
+part2 caveComplex0 explorer1 = maybe 0 (( + 1) . _cost ) result
+ where
+ (re, ce) = _position1 explorer1
+ cave0 = _cave caveComplex0
+ cave = cave0 `S.difference` [(re, ce), (re + 1, ce), (re - 1, ce), (re, ce + 1), (re, ce - 1)]
+ caveComplex = caveComplex0 {_cave = cave}
+ explorer = Explorer4 {_position4 = [(re + 1, ce + 1), (re - 1, ce + 1), (re + 1, ce - 1), (re - 1, ce - 1)], _keysHeld4 = S.empty }
+ result = runReader (searchCave explorer) caveComplex
+
+keySeq :: ExplorerC e => (Agendum e) -> Q.Seq Keys
keySeq agendum = Q.filter (not . S.null) kdiff
- where keyss = fmap _keysHeld $ _trail agendum
- kdiff = fmap (uncurry S.difference) $ Q.zip ((_keysHeld $ _current agendum) <| keyss) keyss
+ where keyss = fmap keysHeldE $ _trail agendum
+ kdiff = fmap (uncurry S.difference) $ Q.zip ((keysHeldE $ _current agendum) <| keyss) keyss
-searchCave :: Explorer -> CaveContext (Maybe Agendum)
+searchCave :: ExplorerC e => e -> CaveContext (Maybe (Agendum e))
searchCave explorer =
do agenda <- initAgenda explorer
aStar agenda S.empty
buildCaveComplex text = foldl' buildCaveRow (cc0, explorer0) $ zip [0..] rows
where cc0 = CaveComplex {_cave = S.empty, _keys = M.empty, _doors = M.empty}
- explorer0 = Explorer { _position = (0, 0), _keysHeld = S.empty }
+ explorer0 = emptyExplorer -- Explorer { _position = (0, 0), _keysHeld = S.empty }
rows = lines text
buildCaveRow (cc, explorer) (r, row) = foldl' (buildCaveCell r) (cc, explorer) $ zip [0..] row
buildCaveCell r (cc, explorer) (c, char)
| char == '.' = (cc', explorer)
- | char == '@' = (cc', explorer { _position = here })
+ | char == '@' = (cc', explorer { _position1 = here })
| isLower char = (cc' { _keys = M.insert here char $ _keys cc'}, explorer)
| isUpper char = (cc' { _doors = M.insert here char $ _doors cc'}, explorer)
| otherwise = (cc, explorer)
here = (r, c)
-
-
-initAgenda :: Explorer -> CaveContext Agenda
+initAgenda :: ExplorerC e => e -> CaveContext (Agenda e)
initAgenda explorer =
do cost <- estimateCost explorer
return $ P.singleton cost Agendum { _current = explorer, _trail = Q.empty, _cost = cost}
-aStar :: Agenda -> ExploredStates -> CaveContext (Maybe Agendum)
+aStar :: ExplorerC e => Agenda e -> ExploredStates e -> CaveContext (Maybe (Agendum e))
-- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
aStar agenda closed
-- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
else aStar newAgenda (S.insert reached closed)
-isGoal :: Explorer -> CaveContext Bool
+isGoal :: ExplorerC e => e -> CaveContext Bool
isGoal explorer =
do keys <- asks (S.fromList . M.elems . _keys)
- return $ keys == _keysHeld explorer
+ return $ keys == keysHeldE explorer
-candidates :: Agendum -> ExploredStates -> CaveContext (Q.Seq Agendum)
+candidates :: ExplorerC e => Agendum e -> ExploredStates e -> CaveContext (Q.Seq (Agendum e))
candidates agendum closed =
do let candidate = _current agendum
let previous = _trail agendum
let nonloops = Q.filter (\s -> not $ s `S.member` closed) succs
mapM (makeAgendum candidate previous) nonloops
-makeAgendum :: Explorer -> (Q.Seq Explorer) -> Explorer -> CaveContext Agendum
+makeAgendum :: ExplorerC e => e -> (Q.Seq e) -> e -> CaveContext (Agendum e)
makeAgendum candidate previous new =
do cost <- estimateCost new
return Agendum { _current = new
, _cost = cost + (Q.length previous)
}
-successors :: Explorer -> CaveContext (Q.Seq Explorer)
-successors explorer =
- do let here = _position explorer
- let locations0 = possibleNeighbours here
- cave <- asks _cave
- keys <- asks _keys
- doors <- asks _doors
- let keysHeld = _keysHeld explorer
- let locations1 = Q.filter (`S.member` cave) locations0
- let locations2 = Q.filter (hasKeyFor doors keysHeld) locations1
- return $ fmap (\l -> explorer { _position = l, _keysHeld = pickupKey keys keysHeld l}) locations2
hasKeyFor :: PointOfInterest -> Keys -> Position -> Bool
-- else held
-estimateCost :: Explorer -> CaveContext Int
-estimateCost explorer = -- return 0
- do keys <- asks _keys
- let (r, c) = _position explorer
- let unfoundKeys = M.filter (`S.notMember` (_keysHeld explorer)) keys
- let minR = minimum $ map fst $ M.keys unfoundKeys
- let minC = minimum $ map snd $ M.keys unfoundKeys
- let maxR = maximum $ map fst $ M.keys unfoundKeys
- let maxC = maximum $ map snd $ M.keys unfoundKeys
- let spanR = spanV r minR maxR
- let spanC = spanV c minC maxC
- if M.null unfoundKeys
- then return 0
- else return $ fromIntegral (spanR + spanC)
- -- return $ sum $ map (manhattan here) $ M.keys unfoundKeys
-
spanV this minV maxV
| this < minV = maxV - this
| this > maxV = this - minV
possibleNeighbours :: Position -> Q.Seq Position
possibleNeighbours (r, c) = [(r + 1, c), (r - 1, c), (r, c + 1), (r, c - 1)]
+
+bounds :: S.Set Position -> (Integer, Integer, Integer, Integer)
+bounds points = (minR, maxR, minC, maxC)
+ where minR = S.findMin $ S.map fst points
+ minC = S.findMin $ S.map snd points
+ maxR = S.findMax $ S.map fst points
+ maxC = S.findMax $ S.map snd points
+
+
+allSplits :: Ord a => S.Set a -> S.Set (a, S.Set a)
+allSplits xs = S.map (\x -> (x, S.delete x xs)) xs
+
+setToSeq :: Ord a => S.Set a -> Q.Seq a
+setToSeq = S.foldl (|>) Q.empty
projects / advent-of-code-19.git / blobdiff