adventofcode1622/app/advent22psm.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2
   3 module Main(main) where
   4
   5 import GHC.Generics (Generic)
   6 import Text.Parsec
   7 import Text.ParserCombinators.Parsec.Number
   8 import Data.Maybe (catMaybes, fromJust, fromMaybe)
   9 import Data.List (find, delete, sort)
  10 import Data.Foldable (foldr')
  11 import Data.Hashable
  12 import qualified Data.HashSet as S
  13 import qualified Data.Sequence as Q
  14 import Data.Sequence ((<|), (|>), (><))
  15 import qualified Data.PQueue.Prio.Min as P
  16 import qualified Data.HashMap.Strict as M
  17 import Data.HashMap.Strict ((!))
  18
  19 import Debug.Trace
  20
  21
  22 data Node = Node { size :: Int
  23                  , used :: Int
  24                  , available :: Int
  25                  , use_pc :: Int
  26                  } deriving (Show, Eq, Ord, Generic)
  27 instance Hashable Node
  28 type NodeLocation = (Int, Int)
  29 type NodeMap = M.HashMap NodeLocation Node
  30
  31 data SearchState = SearchState { targetLoc :: NodeLocation
  32                                , holeLoc :: NodeLocation
  33                                , grid :: NodeMap
  34                                , trail :: Q.Seq CSearchState
  35                                } deriving (Generic)
  36 instance Hashable SearchState where
  37     hashWithSalt salt s = hashWithSalt salt (canonical s)
  38 instance Eq SearchState where
  39     s1 == s2 = canonical s1 == canonical s2
  40 instance Show SearchState where
  41     show s = "Search {" ++ (show $ canonical s) ++ " ; " ++ (show $ trail s) ++ "}"
  42
  43 type CSearchState = (NodeLocation, NodeLocation)
  44 type CSearchStates = S.HashSet CSearchState
  45 type Agenda = P.MinPQueue Int SearchState
  46
  47
  48 canonical :: SearchState -> CSearchState
  49 canonical s = (targetLoc s, holeLoc s)
  50
  51 testGrid = "\
  52 \Filesystem            Size  Used  Avail  Use%\n\
  53 \/dev/grid/node-x0-y0   10T    8T     2T   80%\n\
  54 \/dev/grid/node-x0-y1   11T    6T     5T   54%\n\
  55 \/dev/grid/node-x0-y2   32T   28T     4T   87%\n\
  56 \/dev/grid/node-x1-y0    9T    7T     2T   77%\n\
  57 \/dev/grid/node-x1-y1    8T    0T     8T    0%\n\
  58 \/dev/grid/node-x1-y2   11T    7T     4T   63%\n\
  59 \/dev/grid/node-x2-y0   10T    6T     4T   60%\n\
  60 \/dev/grid/node-x2-y1    9T    8T     1T   88%\n\
  61 \/dev/grid/node-x2-y2    9T    6T     3T   66%\n\
  62 \"
  63
  64 main :: IO ()
  65 main = do
  66     text <- readFile "data/advent22.txt"
  67     let sizes = M.fromList $ successfulParse $ parseFile text
  68     part1 sizes
  69     part2 sizes
  70     -- part2 $ M.fromList $ successfulParse $ parseFile testGrid
  71
  72 part1 :: NodeMap ->  IO ()
  73 part1 sizes = print $ length viable
  74     where viable = [(a, b) | a <- M.keys sizes,
  75                              b <- M.keys sizes,
  76                              a /= b,
  77                              (used $ sizes!a) > 0,
  78                              (used $ sizes!a) <= (available $ sizes!b)]
  79
  80
  81 part2 :: NodeMap ->  IO ()
  82 part2 sizes = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda sizes) $ aStar (initAgenda sizes) S.empty
  83
  84 initAgenda :: NodeMap -> Agenda
  85 initAgenda nodes = P.singleton (heuristic st) st
  86     where st = startSt nodes
  87
  88 aStar :: Agenda -> CSearchStates -> Maybe SearchState
  89 aStar agenda closed
  90     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show current) ++ " :: " ++ (show newAgenda)) False = undefined
  91     | P.null agenda = Nothing
  92     | otherwise =
  93         if isGoal current then Just current
  94         else if creached `S.member` closed
  95             then aStar (P.deleteMin agenda) closed
  96             else aStar newAgenda (S.insert creached closed)
  97         where
  98             (_, current) = P.findMin agenda
  99             creached = canonical current
 100             newAgenda = foldr' (\(c, a) q -> P.insert c a q) (P.deleteMin agenda) $ candidates current closed
 101
 102
 103 -- searchTrace :: [SearchState] -> String
 104 -- searchTrace ss = unlines $ map (sst) ss
 105 --     where sst s = "(" ++ show (tx s) ++ ", " ++ show (ty s) ++ ") :: " ++ holeS s
 106 --           hole sk = fromJust $ find (\n -> used n == 0) $ grid sk
 107 --           holeS sk = "(" ++ show (x $ hole sk) ++ ", " ++ show (y $ hole sk) ++ ")"
 108
 109 startSt :: NodeMap -> SearchState
 110 startSt nodes = SearchState { targetLoc = (maximum xs, 0)
 111                             , holeLoc = hole
 112                             , trail = Q.empty
 113                             , grid = nodes
 114                             }
 115     where xs = map (\n -> fst n) (M.keys nodes)
 116           hole = holeLocation nodes
 117
 118 holeLocation :: NodeMap -> NodeLocation
 119 holeLocation nodes = head $ M.keys $ M.filter (\n -> used n == 0) nodes
 120
 121 isGoal :: SearchState -> Bool
 122 isGoal st = targetLoc st == (0, 0)
 123
 124 heuristic :: SearchState -> Int
 125 heuristic st = (tx + ty) + (abs (hx - tx)) + (abs (hy - ty)) - 1
 126     where (tx, ty) = targetLoc st
 127           (hx, hy) = holeLoc st
 128
 129 adjacent :: NodeLocation -> NodeLocation -> Bool
 130 adjacent (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) == 1
 131
 132 -- A move of data from n1 to n2 is legal.
 133 legal :: NodeMap -> NodeLocation -> NodeLocation -> Bool
 134 legal nodes n1 n2 = adjacent n1 n2 && (used $ nodes!n1) > 0 && (used $ nodes!n1) <= (available $ nodes!n2)
 135
 136 candidates :: SearchState -> CSearchStates -> S.HashSet (Int, SearchState)
 137 candidates st closed = newCandidates
 138     where
 139         previous = trail st
 140         succs = successors st
 141         nonloops = S.filter (\s -> not $ (canonical s) `S.member` closed) succs
 142         cost s = heuristic s + (Q.length $ trail s)
 143         newCandidates = S.map (\a -> (cost a, a)) nonloops
 144
 145 successors :: SearchState -> S.HashSet SearchState
 146 successors st = S.fromList $ map (newState st) possibleMoves
 147     where nodes = grid st
 148           h = holeLoc st
 149           possibleMoves = [(h, n) | n <- (M.keys nodes), legal nodes n h]
 150
 151
 152 -- Moving hole from h to h'
 153 newState :: SearchState -> (NodeLocation, NodeLocation) -> SearchState
 154 newState st (h, h') = candidate
 155     where candidate = st {targetLoc = t', holeLoc = h', trail = trail', grid = grid'}
 156           t = targetLoc st
 157           t' = if t == h' then h else t
 158           trail' = (canonical st) <| (trail st)
 159           u = used ((grid st)!h')
 160           u' = used ((grid st)!h)
 161           a = size((grid st)!h) - used ((grid st)!h')
 162           a' = size((grid st)!h') - used ((grid st)!h)
 163           grid' = M.adjust (\n -> n {used = u, available = a}) h $ M.adjust (\n -> n {used = u', available = a'}) h' $ grid st
 164
 165
 166 --
 167 -- Parsing
 168 --
 169
 170 duFile = duLine `sepEndBy` newline
 171 -- duLine = (optionMaybe nodeL)
 172
 173 duLine = (nodeL >>= return . Just) <|> (headerL >> return Nothing)
 174
 175 headerL = (many (noneOf "\r\n"))
 176
 177 nodeL = nodeify <$> (string "/dev/grid/node-x" *> int)
 178                 <*> (string "-y" *> int)
 179                 <*> (spaces *> int <* string "T")
 180                 <*> (spaces *> int <* string "T")
 181                 <*> (spaces *> int <* string "T")
 182                 <*> (spaces *> int <* string "%")
 183             where nodeify x y size used available use_pc =
 184                       ((x, y), Node {size=size, used=used, available=available, use_pc=use_pc})
 185
 186 parseFile :: String -> Either ParseError [Maybe (NodeLocation, Node)]
 187 parseFile input = parse duFile "(unknown)" input
 188
 189 parseLine :: String -> Either ParseError (Maybe (NodeLocation, Node))
 190 parseLine input = parse duLine "(unknown)" input
 191
 192 successfulParse :: Either ParseError [Maybe a] -> [a]
 193 successfulParse (Left _) = []
 194 successfulParse (Right a) = catMaybes a