app/advent11p.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
   7 module Main(main) where
   8
   9 import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
  10 import Data.Ord (comparing)
  11 import Data.Char (isDigit)
  12 import Data.Maybe (fromMaybe)
  13 import qualified Data.PQueue.Prio.Min as P
  14
  15 data Item = Generator String | Microchip String deriving (Show, Eq)
  16 type Floor = [Item]
  17 data Building = Building Int [Floor] deriving (Show, Eq)
  18 data CBuilding = CBuilding Int Integer deriving (Show, Eq)
  19 data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int}
  20 type Agenda = P.MinPQueue Int Agendum
  21
  22 instance Ord Item where
  23     compare (Generator a) (Generator b) = compare a b
  24     compare (Microchip a) (Microchip b) = compare a b
  25     compare (Generator _) (Microchip _) = LT
  26     compare (Microchip _) (Generator _) = GT
  27
  28 instance Ord Building where
  29     compare b1 b2 = comparing estimateCost b1 b2
  30
  31 building1 = Building 0 [
  32     (sort [Generator "polonium", Generator "thulium",
  33      Microchip "thulium", Generator "promethium", Generator "ruthenium",
  34      Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]),
  35     (sort [Microchip "polonium", Microchip "promethium"]),
  36     [],
  37     []
  38     ]
  39
  40 building0 = Building 0 [
  41     (sort [Generator "polonium", Generator "thulium",
  42      Microchip "thulium", Generator "promethium"]),
  43     (sort [Microchip "polonium", Microchip "promethium"]),
  44     [],
  45     []
  46     ]
  47
  48 building2 = Building 0 [
  49     (sort [Generator "polonium", Generator "thulium",
  50      Microchip "thulium", Generator "promethium", Generator "ruthenium",
  51      Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
  52      Generator "elerium", Microchip "elerium",
  53      Generator "dilithium", Microchip "dilithium"]),
  54     (sort [Microchip "polonium", Microchip "promethium"]),
  55     [],
  56     []
  57     ]
  58
  59
  60 buildingTest = Building 0 [
  61     sort([Microchip "hydrogen", Microchip "lithium"]),
  62     [Generator "hydrogen"],
  63     [Generator "lithium"],
  64     []]
  65
  66 canonical :: Building -> CBuilding
  67 canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs)
  68     where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors
  69           floorOf (Generator g) = head (findIndices
  70                                                 (\fl -> (Generator g) `elem` fl)
  71                                                 floors)
  72           floorOf (Microchip g) = head (findIndices
  73                                                 (\fl -> (Microchip g) `elem` fl)
  74                                                 floors)
  75           pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
  76
  77
  78 main :: IO ()
  79 main = do
  80     part1
  81     part2
  82
  83 part1 :: IO ()
  84 part1 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) []
  85
  86 part2 :: IO ()
  87 part2 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building2) []
  88
  89 initAgenda :: Building -> Agenda
  90 initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail=[], cost = estimateCost b}
  91
  92
  93 aStar :: Agenda -> [CBuilding] -> Maybe Agendum
  94 -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
  95 aStar agenda closed
  96     | P.null agenda = Nothing
  97     | otherwise =
  98         if isGoal reached then Just currentAgendum
  99         else if creached `elem` closed
 100             then aStar (P.deleteMin agenda) closed
 101             else aStar newAgenda (creached:closed)
 102         where
 103             (_, currentAgendum) = P.findMin agenda
 104             reached = current currentAgendum
 105             creached = canonical reached
 106             newAgenda = P.union (P.deleteMin agenda)
 107                                 (P.fromList $ candidates currentAgendum closed)
 108
 109
 110 candidates :: Agendum -> [CBuilding] -> [(Int, Agendum)]
 111 candidates agendum closed = newCandidates
 112     where
 113         candidate = current agendum
 114         previous = trail agendum
 115         succs = legalSuccessors $ successors candidate
 116         nonloops = filter (\s -> not $ (canonical s) `elem` closed) succs
 117         newCandidates = map (\a -> (cost a, a)) $ map (\n -> makeAgendum n) nonloops
 118         makeAgendum new = Agendum {current = new,
 119                                     trail = (canonical candidate):previous,
 120                                     cost = estimateCost new + length previous + 1}
 121
 122 isGoal :: Building -> Bool
 123 isGoal (Building f floors) =
 124     f+1 == height && (all (null) $ take f floors)
 125     where height = length floors
 126
 127 isLegal :: Building -> Bool
 128 isLegal (Building f floors) =
 129     null floor
 130     ||
 131     not (any (isGenerator) floor)
 132     ||
 133     any (safePair) pairs
 134     where floor = floors!!f
 135           pairs = [(i, j) | i <- floor, j <- floor, isGenerator i]
 136           safePair (Generator e, Microchip f) = e == f
 137           safePair (Generator _, Generator _) = False
 138
 139 isGenerator :: Item -> Bool
 140 isGenerator (Generator _) = True
 141 isGenerator (Microchip _) = False
 142
 143 successors :: Building -> [Building]
 144 successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
 145     where
 146         floor = floors!!f
 147         items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor
 148         nextFloors = if f == 0 then [1]
 149                      else if f+1 == length floors then [f-1]
 150                      else [f+1, f-1]
 151
 152 legalSuccessors :: [Building] -> [Building]
 153 legalSuccessors = filter (isLegal)
 154
 155 updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
 156 updateBuilding oldF oldFloors newF items = Building newF newFloors
 157     where newFloors = map (updateFloor) $ zip [0..] oldFloors
 158           updateFloor (f, fl)
 159             | f == oldF = sort $ fl \\ items
 160             | f == newF = sort $ items ++ fl
 161             | otherwise = fl
 162
 163 estimateCost :: Building -> Int
 164 estimateCost (Building _ floors) =
 165     sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
 166