--- /dev/null
+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
+
--- /dev/null
+ 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
--- /dev/null
+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
+
projects / advent-of-code-16.git / commitdiff