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.
5 -- This version is A* search, using a priority queue for the agenda
6 -- and HashSets for various collecions.
8 {-# LANGUAGE DeriveGeneric #-}
10 module Main(main) where
12 import GHC.Generics (Generic)
14 -- import Prelude hiding (length, take, drop)
15 import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices, intercalate)
16 import Data.Ord (comparing)
17 import Data.Char (isDigit)
18 import Data.Maybe (fromMaybe)
19 import qualified Data.PQueue.Prio.Min as P
21 import qualified Data.HashSet as S
22 import qualified Data.Sequence as Q
23 import Data.Sequence ((<|), (|>), (><))
24 import Data.Foldable (toList, foldr')
28 data Item = Generator String | Microchip String deriving (Eq, Generic)
29 instance Hashable Item
31 data Building = Building Int [Floor] deriving (Eq, Ord, Generic)
32 instance Hashable Building
33 data CBuilding = CBuilding Int Integer deriving (Show, Eq, Generic)
34 instance Hashable CBuilding
35 -- instance Hashable CBuilding where
36 -- hashWithSalt s (CBuilding f fs) =
38 -- f `hashWithSalt` fs
40 type CBuildings = S.HashSet CBuilding
41 data Agendum = Agendum {current :: Building, trail :: Q.Seq CBuilding, cost :: Int} deriving (Show, Eq)
42 type Agenda = P.MinPQueue Int Agendum
43 -- type Candidates = S.HashSet (Int, Agendum)
45 instance Ord Item where
46 compare (Generator a) (Generator b) = compare a b
47 compare (Microchip a) (Microchip b) = compare a b
48 compare (Generator _) (Microchip _) = LT
49 compare (Microchip _) (Generator _) = GT
51 instance Show Item where
52 show (Generator a) = "G" ++ take 2 a
53 show (Microchip a) = "M" ++ take 2 a
55 -- instance Ord Building where
56 -- compare b1 b2 = comparing estimateCost b1 b2
58 instance Show Building where
59 show (Building f floors) = (show f) ++ "<* " ++ (intercalate "; " $ map (showFloor) floors)
60 where showFloor fl = intercalate ", " $ map (show) fl
63 building1 = Building 0 [
64 (sort [Generator "polonium", Generator "thulium",
65 Microchip "thulium", Generator "promethium", Generator "ruthenium",
66 Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
67 (sort [Microchip "polonium", Microchip "promethium"]),
72 building0 = Building 0 [
73 (sort [Generator "polonium", Generator "thulium",
74 Microchip "thulium", Generator "promethium"]),
75 (sort [Microchip "polonium", Microchip "promethium"]),
80 building2 = Building 0 [
81 (sort [Generator "polonium", Generator "thulium",
82 Microchip "thulium", Generator "promethium", Generator "ruthenium",
83 Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
84 Generator "elerium", Microchip "elerium",
85 Generator "dilithium", Microchip "dilithium"]),
86 (sort [Microchip "polonium", Microchip "promethium"]),
92 buildingTest = Building 0 [
93 sort([Microchip "hydrogen", Microchip "lithium"]),
94 [Generator "hydrogen"],
95 [Generator "lithium"],
98 canonical :: Building -> CBuilding
99 canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
100 where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
101 floorOf (Generator g) = head (findIndices
102 (\fl -> (Generator g) `elem` fl)
104 floorOf (Microchip g) = head (findIndices
105 (\fl -> (Microchip g) `elem` fl)
107 pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
117 part0 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda buildingTest) S.empty
120 part1 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) S.empty
123 part2 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building2) S.empty
124 initAgenda :: Building -> Agenda
125 initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail = Q.empty, cost = estimateCost b}
128 aStar :: Agenda -> CBuildings -> Maybe Agendum
129 -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
131 -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " :: " ++ (show newAgenda)) False = undefined
132 | P.null agenda = Nothing
134 if isGoal reached then Just currentAgendum
135 else if creached `S.member` closed
136 then aStar (P.deleteMin agenda) closed
137 else aStar newAgenda (S.insert creached closed)
139 (_, currentAgendum) = P.findMin agenda
140 reached = current currentAgendum
141 creached = canonical reached
142 newAgenda = foldr' (\(c, a) q -> P.insert c a q) (P.deleteMin agenda) $ candidates currentAgendum closed
143 -- newAgenda = P.union (P.deleteMin agenda)
144 -- (P.fromList $ toList $ candidates currentAgendum closed)
147 candidates :: Agendum -> CBuildings -> Q.Seq (Int, Agendum)
148 candidates agendum closed = newCandidates
150 candidate = current agendum
151 previous = trail agendum
152 succs = legalSuccessors $ successors candidate
153 nonloops = Q.filter (\s -> not $ (canonical s) `S.member` closed) succs
154 newCandidates = fmap (\a -> (cost a, a)) $ fmap (\n -> makeAgendum n) nonloops
155 makeAgendum new = Agendum {current = new,
156 trail = (canonical candidate) <| previous,
157 cost = estimateCost new + length previous + 1}
159 isGoal :: Building -> Bool
160 isGoal (Building f floors) =
161 f+1 == height && (all (null) $ take f floors)
162 where height = length floors
164 isLegal :: Building -> Bool
165 isLegal (Building f floors) =
168 not (any (isGenerator) floor)
171 where floor = floors!!f
172 pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
173 safePair (Generator e, Microchip f) = e == f
174 safePair (Generator _, Generator _) = False
176 isGenerator :: Item -> Bool
177 isGenerator (Generator _) = True
178 isGenerator (Microchip _) = False
180 successors :: Building -> (Q.Seq Building)
181 successors (Building f floors) = Q.fromList [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
184 items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
185 nextFloors = if f == 0 then [1]
186 else if f+1 == length floors then [f-1]
189 legalSuccessors :: (Q.Seq Building) -> (Q.Seq Building)
190 legalSuccessors = Q.filter (isLegal)
192 updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
193 updateBuilding oldF oldFloors newF items = Building newF newFloors
194 where newFloors = map (updateFloor) $ zip [0..] oldFloors
196 | f == oldF = sort $ fl \\ items
197 | f == newF = sort $ items ++ fl
200 estimateCost :: Building -> Int
201 estimateCost (Building _ floors) =
202 sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors