From: Neil Smith Date: Wed, 14 Dec 2016 20:11:50 +0000 (+0000) Subject: Starting branch for A-star search in day 11 X-Git-Url: https://git.njae.me.uk/?a=commitdiff_plain;h=598d3180bd419deb0165998bc290d291164045b8;p=advent-of-code-16.git Starting branch for A-star search in day 11 --- diff --git a/advent11a.hs b/advent11a.hs new file mode 100644 index 0000000..5a62ab1 --- /dev/null +++ b/advent11a.hs @@ -0,0 +1,165 @@ +import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices) +import Data.Ord (comparing) +import Data.Char (isDigit) + +data Item = Generator String | Microchip String deriving (Show, Eq) +type Floor = [Item] +data Building = Building Int [Floor] deriving (Show, Eq) +-- data CBuilding = CBuilding Int [(Int, Int)] deriving (Show, Eq) +data CBuilding = CBuilding Int Integer deriving (Show, Eq) +data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int} + +instance Ord Item where + compare (Generator a) (Generator b) = compare a b + compare (Microchip a) (Microchip b) = compare a b + compare (Generator _) (Microchip _) = LT + compare (Microchip _) (Generator _) = GT + +instance Ord Building where + compare b1 b2 = comparing estimateCost b1 b2 + +building1 = Building 0 [ + (sort [Generator "polonium", Generator "thulium", + Microchip "thulium", Generator "promethium", Generator "ruthenium", + Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]), + (sort [Microchip "polonium", Microchip "promethium"]), + [], + [] + ] + +building0 = Building 0 [ + (sort [Generator "polonium", Generator "thulium", + Microchip "thulium", Generator "promethium"]), + (sort [Microchip "polonium", Microchip "promethium"]), + [], + [] + ] + +building2 = Building 0 [ + (sort [Generator "polonium", Generator "thulium", + Microchip "thulium", Generator "promethium", Generator "ruthenium", + Microchip "ruthenium", Generator "cobalt", Microchip "cobalt", + Generator "elerium", Microchip "elerium", + Generator "dilithium", Microchip "dilithium"]), + (sort [Microchip "polonium", Microchip "promethium"]), + [], + [] + ] + + +buildingTest = Building 0 [ + sort([Microchip "hydrogen", Microchip "lithium"]), + [Generator "hydrogen"], + [Generator "lithium"], + []] + +canonical :: Building -> CBuilding +-- canonical (Building f floors) = CBuilding f (sort pairs) +canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs) + where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors + floorOf (Generator g) = head (findIndices + (\fl -> (Generator g) `elem` fl) + floors) + floorOf (Microchip g) = head (findIndices + (\fl -> (Microchip g) `elem` fl) + floors) + pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names + + + +main :: IO () +main = do + part1 + part2 + + +part1 :: IO () +part1 = print $ length $ trail $ aStar (initAgenda building1) [] +-- part1 = print $ length $ trail $ +-- aStar [Agendum {current = building1, trail=[], cost = estimateCost building1}] [] + +-- part2 :: IO () +-- part2 = print $ length $ init $ extractJust $ aStar [[building2]] [] + +part2 :: IO () +part2 = print $ length $ trail $aStar (initAgenda building2) [] + +initAgenda :: Building -> [Agendum] +initAgenda b = [Agendum {current = b, trail=[], cost = estimateCost b}] + + +aStar :: [Agendum] -> [CBuilding] -> Agendum +aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0} +aStar (currentAgendum:agenda) closed = + if isGoal reached then currentAgendum + else if creached `elem` closed + then aStar agenda closed + else aStar newAgenda (creached:closed) + where + reached = current currentAgendum + creached = canonical reached + newAgenda = + -- sortBy (\t1 t2 -> (cost t1) `compare` (cost t2)) $ + sortOn (cost) $ + agenda ++ (candidates currentAgendum closed) + + +candidates :: Agendum -> [CBuilding] -> [Agendum] +candidates agendum closed = newCandidates + where + candidate = current agendum + previous = trail agendum + succs = legalSuccessors $ successors candidate + -- nonloops = (succs \\ previous) \\ closed + excludable = previous ++ closed + nonloops = filter (\s -> not $ (canonical s) `elem` excludable) succs + newCandidates = map (\n -> makeAgendum n) nonloops + makeAgendum new = Agendum {current = new, + trail = (canonical candidate):previous, + cost = estimateCost new + length previous + 1} + +isGoal :: Building -> Bool +isGoal (Building f floors) = + f+1 == height && (all (null) $ take f floors) + where height = length floors + +isLegal :: Building -> Bool +isLegal (Building f floors) = + null floor + || + not (any (isGenerator) floor) + || + any (safePair) pairs + where floor = floors!!f + pairs = [(i, j) | i <- floor, j <- floor, isGenerator i] + safePair (Generator e, Microchip f) = e == f + safePair (Generator _, Generator _) = False + +isGenerator :: Item -> Bool +isGenerator (Generator _) = True +isGenerator (Microchip _) = False + +successors :: Building -> [Building] +successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items] + where + floor = floors!!f + items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor + nextFloors = if f == 0 then [1] + else if f+1 == length floors then [f-1] + else [f+1, f-1] + +legalSuccessors :: [Building] -> [Building] +legalSuccessors = filter (isLegal) + +updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building +updateBuilding oldF oldFloors newF items = Building newF newFloors + where newFloors = map (updateFloor) $ zip [0..] oldFloors + updateFloor (f, fl) + | f == oldF = sort $ fl \\ items + | f == newF = sort $ items ++ fl + | otherwise = fl + +estimateCost :: Building -> Int +estimateCost (Building _ floors) = + sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors + diff --git a/advent11a.prof.old b/advent11a.prof.old new file mode 100644 index 0000000..22a9fae --- /dev/null +++ b/advent11a.prof.old @@ -0,0 +1,146 @@ + Tue Dec 13 23:13 2016 Time and Allocation Profiling Report (Final) + + advent11a +RTS -p -hy -RTS + + total time = 82.25 secs (82252 ticks @ 1000 us, 1 processor) + total alloc = 85,148,814,152 bytes (excludes profiling overheads) + +COST CENTRE MODULE %time %alloc + +aStar.newAgenda Main 45.0 93.7 +candidates.nonloops.\ Main 27.8 0.2 +aStar Main 14.1 0.0 +== Main 4.7 0.0 +canonical Main 3.8 4.2 +cost Main 1.8 0.0 + + + individual inherited +COST CENTRE MODULE no. entries %time %alloc %time %alloc + +MAIN MAIN 88 0 0.0 0.0 100.0 100.0 + part1 Main 178 0 0.0 0.0 0.0 0.0 + CAF:main1 Main 172 0 0.0 0.0 0.0 0.0 + part1 Main 177 1 0.0 0.0 0.0 0.0 + main Main 176 1 0.0 0.0 0.0 0.0 + CAF:main2 Main 171 0 0.0 0.0 0.0 0.0 + part1 Main 179 0 0.0 0.0 0.0 0.0 + CAF:main3 Main 170 0 0.0 0.0 0.0 0.0 + part1 Main 180 0 0.0 0.0 0.0 0.0 + CAF:main4 Main 169 0 0.0 0.0 0.0 0.0 + part1 Main 181 0 0.0 0.0 0.0 0.0 + trail Main 182 1 0.0 0.0 0.0 0.0 + CAF:main5 Main 168 0 0.0 0.0 100.0 100.0 + part1 Main 183 0 0.0 0.0 100.0 100.0 + aStar Main 185 86615 14.1 0.0 100.0 100.0 + == Main 249 472091345 1.4 0.0 1.4 0.0 + aStar.creached Main 247 86614 0.0 0.0 1.6 1.5 + canonical Main 248 86614 1.1 1.3 1.6 1.5 + canonical.pairs Main 277 86614 0.0 0.1 0.4 0.1 + canonical.pairs.\ Main 279 433070 0.0 0.0 0.3 0.0 + canonical.floorOf Main 280 866140 0.0 0.0 0.3 0.0 + canonical.floorOf.\ Main 283 1057262 0.0 0.0 0.1 0.0 + == Main 284 2667679 0.1 0.0 0.1 0.0 + canonical.floorOf.\ Main 281 1063226 0.0 0.0 0.1 0.0 + == Main 282 2096091 0.1 0.0 0.1 0.0 + canonical.names Main 275 86614 0.2 0.1 0.2 0.1 + canonical.names.\ Main 278 433070 0.0 0.0 0.0 0.0 + isGenerator Main 276 866140 0.0 0.0 0.0 0.0 + aStar.newAgenda Main 191 25950 45.0 93.7 82.8 98.4 + cost Main 240 255331378 1.8 0.0 1.8 0.0 + candidates Main 192 25950 0.0 0.0 36.1 4.7 + candidates.newCandidates Main 239 25950 0.0 0.0 0.6 0.6 + candidates.newCandidates.\ Main 241 86840 0.0 0.0 0.6 0.6 + candidates.makeAgendum Main 242 86840 0.0 0.0 0.6 0.6 + canonical Main 251 25949 0.3 0.4 0.5 0.5 + canonical.pairs Main 267 25949 0.0 0.0 0.1 0.0 + canonical.pairs.\ Main 269 129745 0.0 0.0 0.1 0.0 + canonical.floorOf Main 270 259490 0.0 0.0 0.1 0.0 + canonical.floorOf.\ Main 273 324798 0.0 0.0 0.0 0.0 + == Main 274 803862 0.0 0.0 0.0 0.0 + canonical.floorOf.\ Main 271 324013 0.0 0.0 0.0 0.0 + == Main 272 623333 0.0 0.0 0.0 0.0 + canonical.names Main 265 25949 0.0 0.0 0.0 0.0 + canonical.names.\ Main 268 129745 0.0 0.0 0.0 0.0 + isGenerator Main 266 259490 0.0 0.0 0.0 0.0 + estimateCost Main 243 86840 0.1 0.1 0.1 0.1 + estimateCost.\ Main 245 347360 0.0 0.0 0.0 0.0 + candidates.previous Main 237 25950 0.0 0.0 0.0 0.0 + trail Main 238 25950 0.0 0.0 0.0 0.0 + candidates.nonloops Main 235 25950 0.0 0.0 34.4 3.3 + candidates.nonloops.\ Main 236 174032 27.8 0.2 34.4 3.3 + == Main 252 1106692284 3.2 0.0 3.2 0.0 + canonical Main 250 174008 2.4 2.6 3.4 3.1 + canonical.pairs Main 256 174002 0.1 0.2 0.7 0.3 + canonical.pairs.\ Main 258 870010 0.0 0.0 0.6 0.1 + canonical.floorOf Main 259 1740020 0.1 0.1 0.6 0.1 + canonical.floorOf.\ Main 262 2174210 0.1 0.0 0.3 0.0 + == Main 263 5379816 0.2 0.0 0.2 0.0 + canonical.floorOf.\ Main 260 2174106 0.1 0.0 0.2 0.0 + == Main 261 4190294 0.1 0.0 0.1 0.0 + canonical.names Main 254 174002 0.3 0.3 0.3 0.3 + canonical.names.\ Main 257 870010 0.0 0.0 0.0 0.0 + isGenerator Main 255 1740020 0.0 0.0 0.0 0.0 + candidates.candidate Main 197 25950 0.0 0.0 0.0 0.0 + current Main 198 25950 0.0 0.0 0.0 0.0 + candidates.succs Main 193 25950 0.0 0.0 1.0 0.9 + successors Main 196 25950 0.1 0.1 0.7 0.7 + updateBuilding Main 216 301256 0.0 0.0 0.6 0.5 + updateBuilding.newFloors Main 219 301256 0.1 0.1 0.6 0.5 + updateBuilding.updateFloor Main 227 823352 0.4 0.4 0.5 0.4 + == Main 246 691667 0.1 0.0 0.1 0.0 + compare Main 230 1533156 0.1 0.0 0.1 0.0 + successors.floor Main 208 25950 0.0 0.0 0.0 0.0 + successors.items Main 200 25950 0.1 0.1 0.1 0.1 + successors.items.\ Main 207 451438 0.0 0.0 0.0 0.0 + successors.nextFloors Main 199 25950 0.0 0.0 0.0 0.0 + legalSuccessors Main 195 0 0.0 0.0 0.3 0.2 + isLegal Main 217 301256 0.1 0.0 0.2 0.2 + isLegal.safePair Main 234 1450573 0.0 0.0 0.0 0.0 + isLegal.pairs Main 232 263463 0.1 0.2 0.1 0.2 + isGenerator Main 233 564782 0.0 0.0 0.0 0.0 + isGenerator Main 231 345690 0.0 0.0 0.0 0.0 + isLegal.floor Main 218 301256 0.0 0.0 0.0 0.0 + aStar.reached Main 187 86615 0.0 0.0 0.0 0.0 + current Main 188 86615 0.0 0.0 0.0 0.0 + isGoal Main 186 86615 0.0 0.0 0.0 0.0 + isGoal.height Main 190 86615 0.0 0.0 0.0 0.0 + initAgenda Main 184 1 0.0 0.0 0.0 0.0 + CAF:lvl26_r8dc Main 165 0 0.0 0.0 0.0 0.0 + canonical Main 253 0 0.0 0.0 0.0 0.0 + CAF:building1 Main 156 0 0.0 0.0 0.0 0.0 + building1 Main 189 1 0.0 0.0 0.0 0.0 + CAF:main11 Main 155 0 0.0 0.0 0.0 0.0 + building1 Main 228 0 0.0 0.0 0.0 0.0 + compare Main 229 1 0.0 0.0 0.0 0.0 + CAF:main18 Main 154 0 0.0 0.0 0.0 0.0 + building1 Main 209 0 0.0 0.0 0.0 0.0 + compare Main 210 18 0.0 0.0 0.0 0.0 + CAF:legalSuccessors_rNg Main 153 0 0.0 0.0 0.0 0.0 + legalSuccessors Main 194 1 0.0 0.0 0.0 0.0 + CAF:$fOrdBuilding1 Main 149 0 0.0 0.0 0.0 0.0 + estimateCost Main 244 0 0.0 0.0 0.0 0.0 + CAF:main35 Main 147 0 0.0 0.0 0.0 0.0 + building1 Main 212 0 0.0 0.0 0.0 0.0 + CAF:main31 Main 146 0 0.0 0.0 0.0 0.0 + building1 Main 214 0 0.0 0.0 0.0 0.0 + CAF:main28 Main 145 0 0.0 0.0 0.0 0.0 + building1 Main 215 0 0.0 0.0 0.0 0.0 + CAF:main17 Main 144 0 0.0 0.0 0.0 0.0 + building1 Main 211 0 0.0 0.0 0.0 0.0 + CAF:main15 Main 143 0 0.0 0.0 0.0 0.0 + building1 Main 213 0 0.0 0.0 0.0 0.0 + CAF:lvl2_r8cu Main 137 0 0.0 0.0 0.0 0.0 + aStar Main 220 0 0.0 0.0 0.0 0.0 + aStar.newAgenda Main 221 0 0.0 0.0 0.0 0.0 + candidates Main 222 0 0.0 0.0 0.0 0.0 + candidates.succs Main 223 0 0.0 0.0 0.0 0.0 + successors Main 224 0 0.0 0.0 0.0 0.0 + updateBuilding Main 225 0 0.0 0.0 0.0 0.0 + updateBuilding.newFloors Main 226 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Handle.FD 133 0 0.0 0.0 0.0 0.0 + CAF Text.Read.Lex 125 0 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 124 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Encoding 122 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Handle.Text 121 0 0.0 0.0 0.0 0.0 + CAF GHC.IO.Encoding.Iconv 102 0 0.0 0.0 0.0 0.0 diff --git a/advent11p.hs b/advent11p.hs new file mode 100644 index 0000000..5a62ab1 --- /dev/null +++ b/advent11p.hs @@ -0,0 +1,165 @@ +import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices) +import Data.Ord (comparing) +import Data.Char (isDigit) + +data Item = Generator String | Microchip String deriving (Show, Eq) +type Floor = [Item] +data Building = Building Int [Floor] deriving (Show, Eq) +-- data CBuilding = CBuilding Int [(Int, Int)] deriving (Show, Eq) +data CBuilding = CBuilding Int Integer deriving (Show, Eq) +data Agendum = Agendum {current :: Building, trail :: [CBuilding], cost :: Int} + +instance Ord Item where + compare (Generator a) (Generator b) = compare a b + compare (Microchip a) (Microchip b) = compare a b + compare (Generator _) (Microchip _) = LT + compare (Microchip _) (Generator _) = GT + +instance Ord Building where + compare b1 b2 = comparing estimateCost b1 b2 + +building1 = Building 0 [ + (sort [Generator "polonium", Generator "thulium", + Microchip "thulium", Generator "promethium", Generator "ruthenium", + Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"]), + (sort [Microchip "polonium", Microchip "promethium"]), + [], + [] + ] + +building0 = Building 0 [ + (sort [Generator "polonium", Generator "thulium", + Microchip "thulium", Generator "promethium"]), + (sort [Microchip "polonium", Microchip "promethium"]), + [], + [] + ] + +building2 = Building 0 [ + (sort [Generator "polonium", Generator "thulium", + Microchip "thulium", Generator "promethium", Generator "ruthenium", + Microchip "ruthenium", Generator "cobalt", Microchip "cobalt", + Generator "elerium", Microchip "elerium", + Generator "dilithium", Microchip "dilithium"]), + (sort [Microchip "polonium", Microchip "promethium"]), + [], + [] + ] + + +buildingTest = Building 0 [ + sort([Microchip "hydrogen", Microchip "lithium"]), + [Generator "hydrogen"], + [Generator "lithium"], + []] + +canonical :: Building -> CBuilding +-- canonical (Building f floors) = CBuilding f (sort pairs) +canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ sort pairs) + where names = nub $ map (\(Generator n) -> n) $ filter (isGenerator) $ concat floors + floorOf (Generator g) = head (findIndices + (\fl -> (Generator g) `elem` fl) + floors) + floorOf (Microchip g) = head (findIndices + (\fl -> (Microchip g) `elem` fl) + floors) + pairs = foldl (\ps n -> (floorOf (Generator n), floorOf (Microchip n)):ps) [] names + + + +main :: IO () +main = do + part1 + part2 + + +part1 :: IO () +part1 = print $ length $ trail $ aStar (initAgenda building1) [] +-- part1 = print $ length $ trail $ +-- aStar [Agendum {current = building1, trail=[], cost = estimateCost building1}] [] + +-- part2 :: IO () +-- part2 = print $ length $ init $ extractJust $ aStar [[building2]] [] + +part2 :: IO () +part2 = print $ length $ trail $aStar (initAgenda building2) [] + +initAgenda :: Building -> [Agendum] +initAgenda b = [Agendum {current = b, trail=[], cost = estimateCost b}] + + +aStar :: [Agendum] -> [CBuilding] -> Agendum +aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0} +aStar (currentAgendum:agenda) closed = + if isGoal reached then currentAgendum + else if creached `elem` closed + then aStar agenda closed + else aStar newAgenda (creached:closed) + where + reached = current currentAgendum + creached = canonical reached + newAgenda = + -- sortBy (\t1 t2 -> (cost t1) `compare` (cost t2)) $ + sortOn (cost) $ + agenda ++ (candidates currentAgendum closed) + + +candidates :: Agendum -> [CBuilding] -> [Agendum] +candidates agendum closed = newCandidates + where + candidate = current agendum + previous = trail agendum + succs = legalSuccessors $ successors candidate + -- nonloops = (succs \\ previous) \\ closed + excludable = previous ++ closed + nonloops = filter (\s -> not $ (canonical s) `elem` excludable) succs + newCandidates = map (\n -> makeAgendum n) nonloops + makeAgendum new = Agendum {current = new, + trail = (canonical candidate):previous, + cost = estimateCost new + length previous + 1} + +isGoal :: Building -> Bool +isGoal (Building f floors) = + f+1 == height && (all (null) $ take f floors) + where height = length floors + +isLegal :: Building -> Bool +isLegal (Building f floors) = + null floor + || + not (any (isGenerator) floor) + || + any (safePair) pairs + where floor = floors!!f + pairs = [(i, j) | i <- floor, j <- floor, isGenerator i] + safePair (Generator e, Microchip f) = e == f + safePair (Generator _, Generator _) = False + +isGenerator :: Item -> Bool +isGenerator (Generator _) = True +isGenerator (Microchip _) = False + +successors :: Building -> [Building] +successors (Building f floors) = [updateBuilding f floors nf is | nf <- nextFloors, is <- items] + where + floor = floors!!f + items = filter (\is -> length is == 1 || length is == 2) $ subsequences floor + nextFloors = if f == 0 then [1] + else if f+1 == length floors then [f-1] + else [f+1, f-1] + +legalSuccessors :: [Building] -> [Building] +legalSuccessors = filter (isLegal) + +updateBuilding :: Int -> [Floor] -> Int -> [Item] -> Building +updateBuilding oldF oldFloors newF items = Building newF newFloors + where newFloors = map (updateFloor) $ zip [0..] oldFloors + updateFloor (f, fl) + | f == oldF = sort $ fl \\ items + | f == newF = sort $ items ++ fl + | otherwise = fl + +estimateCost :: Building -> Int +estimateCost (Building _ floors) = + sum $ map (\(c, f) -> c * length f) $ zip [0..] $ reverse floors +