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