adventofcode1611/app/advent11ps.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 -- and HashSets for various collecions.
   7
   8 {-# LANGUAGE DeriveGeneric #-}
   9
  10 module Main(main) where
  11
  12 import GHC.Generics (Generic)
  13
  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
  20 import Data.Hashable
  21 import qualified Data.HashSet as S
  22 import qualified Data.Sequence as Q
  23 import Data.Sequence ((<|), (|>), (><))
  24 import Data.Foldable (toList, foldr')
  25 import Debug.Trace
  26
  27
  28 data Item = Generator String | Microchip String deriving (Eq, Generic)
  29 instance Hashable Item
  30 type Floor = [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) =
  37 --         s `hashWithSalt`
  38 --         f `hashWithSalt` fs
  39
  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)
  44
  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
  50
  51 instance Show Item where
  52     show (Generator a) = "G" ++ take 2 a
  53     show (Microchip a) = "M" ++ take 2 a
  54
  55 -- instance Ord Building where
  56 --     compare b1 b2 = comparing estimateCost b1 b2
  57
  58 instance Show Building where
  59     show (Building f floors) = (show f) ++ "<* " ++ (intercalate "; " $ map (showFloor) floors)
  60         where showFloor fl = intercalate ", " $ map (show) fl
  61
  62
  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"]),
  68     [],
  69     []
  70     ]
  71
  72 building0 = Building 0 [
  73     (sort [Generator "polonium", Generator "thulium",
  74      Microchip "thulium", Generator "promethium"]),
  75     (sort [Microchip "polonium", Microchip "promethium"]),
  76     [],
  77     []
  78     ]
  79
  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"]),
  87     [],
  88     []
  89     ]
  90
  91
  92 buildingTest = Building 0 [
  93     sort([Microchip "hydrogen", Microchip "lithium"]),
  94     [Generator "hydrogen"],
  95     [Generator "lithium"],
  96     []]
  97
  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)
 103                                                 floors)
 104           floorOf (Microchip g) = head (findIndices
 105                                                 (\fl -> (Microchip g) `elem` fl)
 106                                                 floors)
 107           pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names
 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 initAgenda :: Building -> Agenda
 125 initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail = Q.empty, cost = estimateCost b}
 126
 127
 128 aStar :: Agenda -> CBuildings -> Maybe Agendum
 129 -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
 130 aStar agenda closed
 131     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " :: " ++ (show newAgenda)) False = undefined
 132     | P.null agenda = Nothing
 133     | otherwise =
 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)
 138         where
 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)
 145
 146
 147 candidates :: Agendum -> CBuildings -> Q.Seq (Int, 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 $ (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}
 158
 159 isGoal :: Building -> Bool
 160 isGoal (Building f floors) =
 161     f+1 == height && (all (null) $ take f floors)
 162     where height = length floors
 163
 164 isLegal :: Building -> Bool
 165 isLegal (Building f floors) =
 166     null floor
 167     ||
 168     not (any (isGenerator) floor)
 169     ||
 170     any (safePair) pairs
 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
 175
 176 isGenerator :: Item -> Bool
 177 isGenerator (Generator _) = True
 178 isGenerator (Microchip _) = False
 179
 180 successors :: Building -> (Q.Seq Building)
 181 successors (Building f floors) = Q.fromList [updateBuilding f floors nf is | nf <- nextFloors, is <- items]
 182     where
 183         floor = floors!!f
 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]
 187                      else [f+1, f-1]
 188
 189 legalSuccessors :: (Q.Seq Building) -> (Q.Seq Building)
 190 legalSuccessors = Q.filter (isLegal)
 191
 192 updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building
 193 updateBuilding oldF oldFloors newF items = Building newF newFloors
 194     where newFloors = map (updateFloor) $ zip [0..] oldFloors
 195           updateFloor (f, fl)
 196             | f == oldF = sort $ fl \\ items
 197             | f == newF = sort $ items ++ fl
 198             | otherwise = fl
 199
 200 estimateCost :: Building -> Int
 201 estimateCost (Building _ floors) =
 202     sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors
 203