adventofcode1611/app/advent11psmh.hs

   1 -- Using the idea of canonical representation of buildings from
   2 -- https://andars.github.io/aoc_day11.html by Andrew Foote,
   3 -- plus my extension of represening the pairs as an integer.
   4
   5 -- This version is A* search, using a priority queue for the agenda,
   6 -- Sets for various collecions, and a Map to store the floors in the
   7 -- building.
   8
   9 {-# LANGUAGE DeriveGeneric #-}
  10
  11 module Main(main) where
  12
  13 import GHC.Generics (Generic)
  14
  15 -- import Prelude hiding (length, take, drop)
  16 import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices, intercalate)
  17 import Data.Ord (comparing)
  18 import Data.Char (isDigit)
  19 import Data.Maybe (fromMaybe, fromJust)
  20 import qualified Data.PQueue.Prio.Min as P
  21 import qualified Data.HashSet as S
  22 import qualified Data.Sequence as Q
  23 import qualified Data.HashMap.Strict as M
  24 import Data.Hashable
  25 import Data.Sequence ((<|), (|>), (><))
  26 import Data.Foldable (toList, foldr', foldl', all)
  27 import Debug.Trace
  28
  29 data Item = Generator String | Microchip String deriving (Eq, Generic)
  30 instance Hashable Item
  31 data Floor = Floor (S.HashSet Item) deriving (Eq, Generic)
  32 instance Hashable Floor
  33 unFloor :: Floor -> S.HashSet Item
  34 unFloor (Floor f) = f
  35 data Floors = Floors (M.HashMap Int Floor) deriving (Eq, Generic)
  36 instance Hashable Floors
  37 data Building = Building Int Floors deriving (Eq, Generic)
  38 instance Hashable Building
  39 type Buildings = S.HashSet Building
  40 -- data CBuilding = CBuilding Int Integer deriving (Show, Eq, Generic)
  41 -- instance Hashable CBuilding
  42 -- type CBuildings = S.HashSet CBuilding
  43 data Agendum = Agendum {current :: Building, trail :: Q.Seq Building, cost :: Int} deriving (Show, Eq)
  44 type Agenda = P.MinPQueue Int Agendum
  45 type Candidates = S.HashSet (Int, Agendum)
  46
  47 instance Show Item where
  48     show (Generator a) = "G" ++ take 2 a
  49     show (Microchip a) = "M" ++ take 2 a
  50
  51 instance Ord Item where
  52     compare (Generator a) (Generator b) = compare a b
  53     compare (Microchip a) (Microchip b) = compare a b
  54     compare (Generator _) (Microchip _) = LT
  55     compare (Microchip _) (Generator _) = GT
  56
  57 -- instance Ord Building where
  58 --     compare b1 b2 = comparing estimateCost b1 b2
  59
  60 instance Show Building where
  61     show (Building f (Floors floors)) = (show f) ++ "<* " ++ (intercalate "; " $ toList $ M.map (showFloor. unFloor) floors)
  62         where showFloor fl = intercalate ", " $ toList $ S.map (show) fl
  63
  64
  65 -- building1 = Building 0 [
  66 --     (sort [Generator "polonium", Generator "thulium",
  67 --      Microchip "thulium", Generator "promethium", Generator "ruthenium",
  68 --      Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
  69 --     (sort [Microchip "polonium", Microchip "promethium"]),
  70 --     [],
  71 --     []
  72 --     ]
  73
  74 building1 = Building 0 (Floors $ M.fromList
  75         [ (0, Floor $ S.fromList [Generator "polonium", Generator "thulium",
  76                           Microchip "thulium", Generator "promethium", Generator "ruthenium",
  77                           Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"])
  78         , (1, Floor $ S.fromList [Microchip "polonium", Microchip "promethium"])
  79         , (2, Floor $ S.empty )
  80         , (3, Floor $ S.empty )
  81         ])
  82
  83
  84
  85 building0 = Building 0 (Floors $ M.fromList
  86         [ (0, Floor $ S.fromList [Generator "polonium", Generator "thulium", Microchip "thulium", Generator "promethium"])
  87         , (1, Floor $ S.fromList [Microchip "polonium", Microchip "promethium"])
  88         , (2, Floor $ S.empty )
  89         , (3, Floor $ S.empty )
  90         ])
  91
  92 building2 = Building 0 (Floors $ M.fromList
  93         [ (0, Floor $ S.fromList [Generator "polonium", Generator "thulium",
  94                           Microchip "thulium", Generator "promethium", Generator "ruthenium",
  95                           Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
  96                           Generator "dilithium", Microchip "dilithium"])
  97         , (1, Floor $ S.fromList [Microchip "polonium", Microchip "promethium"])
  98         , (2, Floor $ S.empty )
  99         , (3, Floor $ S.empty )
 100         ])
 101
 102 buildingTest = Building 0 (Floors $ M.fromList
 103         [ (0, Floor $ S.fromList [Microchip "hydrogen", Microchip "lithium"])
 104         , (1, Floor $ S.fromList [Generator "hydrogen"])
 105         , (2, Floor $ S.fromList [Generator "lithium"])
 106         , (3, Floor $ S.empty )
 107         ])
 108
 109
 110 main :: IO ()
 111 main = do
 112     -- part0
 113     part1
 114     part2
 115
 116 part0 :: IO ()
 117 part0 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda buildingTest) S.empty
 118
 119 part1 :: IO ()
 120 part1 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) S.empty
 121
 122 part2 :: IO ()
 123 part2 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building2) S.empty
 124
 125
 126 initAgenda :: Building -> Agenda
 127 initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail = Q.empty, cost = estimateCost b}
 128
 129
 130 aStar :: Agenda -> Buildings -> Maybe Agendum
 131 -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
 132 aStar agenda closed
 133     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
 134     | P.null agenda = Nothing
 135     | otherwise =
 136         if isGoal reached then Just currentAgendum
 137         else if reached `S.member` closed
 138             then aStar (P.deleteMin agenda) closed
 139             else aStar newAgenda (S.insert reached closed)
 140         where
 141             (_, currentAgendum) = P.findMin agenda
 142             reached = current currentAgendum
 143             newAgenda = foldl' (\q a -> P.insert (cost a) a q) (P.deleteMin agenda) $ candidates currentAgendum closed
 144
 145
 146
 147 candidates :: Agendum -> Buildings -> Q.Seq Agendum
 148 candidates agendum closed = newCandidates
 149     where
 150         candidate = current agendum
 151         previous = trail agendum
 152         succs = legalSuccessors $ successors candidate
 153         nonloops = Q.filter (\s -> not $ s `S.member` closed) succs
 154         newCandidates = fmap (\n -> makeAgendum n) nonloops
 155         makeAgendum new = Agendum {current = new,
 156                                     trail = candidate <| previous,
 157                                     cost = estimateCost new + length previous + 1}
 158
 159 isGoal :: Building -> Bool
 160 isGoal (Building f (Floors floors)) =
 161     f+1 == height && (all (\fl -> S.null $ unFloor fl) $ M.filterWithKey (\k _ -> k < f) floors)
 162     where height = M.size floors
 163
 164 isLegal :: Building -> Bool
 165 isLegal (Building f (Floors floors)) =
 166     null floor
 167     ||
 168     not (any (isGenerator) floor)
 169     ||
 170     any (safePair) pairs
 171     where floor = unFloor $ fromJust $ M.lookup f floors
 172           pairs = [(i, j) | i <- (S.toList floor), j <- (S.toList floor), isGenerator i]
 173           safePair (Generator e, Microchip f) = e == f
 174           safePair (Generator _, Generator _) = False
 175
 176 isGenerator :: Item -> Bool
 177 isGenerator (Generator _) = True
 178 isGenerator (Microchip _) = False
 179
 180 successors :: Building -> (Q.Seq Building)
 181 successors b@(Building f (Floors floors)) = Q.fromList [updateBuilding b nf is | nf <- nextFloors, is <- items]
 182     where
 183         floor = unFloor $ fromJust $ M.lookup f floors
 184         items = map (S.fromList) $ filter (\is -> length is == 1 || length is == 2) $ subsequences $ toList floor
 185         nextFloors = if f == 0 then [1]
 186                      else if f+1 == length floors then [f-1]
 187                      else [f+1, f-1]
 188
 189 legalSuccessors :: (Q.Seq Building) -> (Q.Seq Building)
 190 legalSuccessors = Q.filter (isLegal)
 191
 192 updateBuilding :: Building -> Int -> S.HashSet Item -> Building
 193 updateBuilding (Building oldF (Floors oldFloors)) newF items = Building newF (Floors newFloors)
 194     where oldFloorsE = fmap (unFloor) oldFloors
 195           newFloorsE = M.adjust (\f -> f `S.union` items) newF $ M.adjust (\f -> f `S.difference` items) oldF oldFloorsE
 196           newFloors = fmap (Floor) newFloorsE
 197
 198
 199 estimateCost :: Building -> Int
 200 estimateCost (Building _ (Floors floors)) =
 201     sum $ map (\(c, f) -> c * S.size f) $ zip [0..] $ reverse $ M.elems $ fmap (unFloor) floors
 202