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