Version using hashsets and sequences, rather than lists

diff --git a/adventofcode1611/adventofcode1611.cabal b/adventofcode1611/adventofcode1611.cabal
index 64b9754ea802e694823ec2773c6b790beead630c..19ce815b155992baa691b663b67a5587a46bf7a3 100644 (file)
--- a/adventofcode1611/adventofcode1611.cabal
+++ b/adventofcode1611/adventofcode1611.cabal
@@ -51,6 +51,18 @@ executable advent11p
                      , pqueue
   default-language:    Haskell2010
 
+executable advent11ps
+  hs-source-dirs:      app
+  main-is:             advent11ps.hs
+  ghc-options:         -O2 -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , adventofcode16
+                     , pqueue
+                     , hashable
+                     , containers
+                     , unordered-containers
+  default-language:    Haskell2010
+
 test-suite adventofcode1611-test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test

diff --git a/adventofcode1611/app/advent11ps.hs b/adventofcode1611/app/advent11ps.hs
new file mode 100644 (file)
index 0000000..349c8a5
--- /dev/null
+++ b/adventofcode1611/app/advent11ps.hs
@@ -0,0 +1,183 @@
+-- Using the idea of canonical representation of buildings from
+-- https://andars.github.io/aoc_day11.html by Andrew Foote,
+-- plus my extension of represening the pairs as an integer.
+
+-- This version is A* search, using a priority queue for the agenda
+-- and HashSets for various collecions.
+
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main(main) where
+
+import GHC.Generics (Generic)
+
+-- import Prelude hiding (length, take, drop)
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
+import Data.Ord (comparing)
+import Data.Char (isDigit)
+import Data.Maybe (fromMaybe)
+import qualified Data.PQueue.Prio.Min as P
+import Data.Hashable
+import qualified Data.HashSet as S
+import qualified Data.Sequence as Q
+import Data.Sequence ((<|), (|>), (><))
+import Data.Foldable (toList, foldr')
+
+
+data Item = Generator String | Microchip String deriving (Show, Eq, Generic)
+instance Hashable Item
+type Floor = [Item]
+data Building = Building Int [Floor] deriving (Show, Eq, Generic)
+instance Hashable Building
+data CBuilding = CBuilding Int Integer deriving (Show, Eq, Generic)
+instance Hashable CBuilding
+type CBuildings = S.HashSet CBuilding
+data Agendum = Agendum {current :: Building, trail :: Q.Seq CBuilding, cost :: Int} deriving (Show, Eq)
+type Agenda = P.MinPQueue Int Agendum 
+type Candidates = S.HashSet (Int, Agendum)
+
+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 (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 $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) S.empty
+
+part2 :: IO ()
+part2 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building2) S.empty
+initAgenda :: Building -> Agenda
+initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail = Q.empty, cost = estimateCost b}
+
+
+aStar :: Agenda -> CBuildings -> Maybe Agendum
+-- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
+aStar agenda closed 
+    | P.null agenda = Nothing
+    | otherwise = 
+        if isGoal reached then Just currentAgendum
+        else if creached `S.member` closed 
+            then aStar (P.deleteMin agenda) closed
+            else aStar newAgenda (S.insert creached closed)
+        where 
+            (_, currentAgendum) = P.findMin agenda
+            reached = current currentAgendum
+            creached = canonical reached
+            newAgenda = foldr' (\(c, a) q -> P.insert c a q) (P.deleteMin agenda) $ candidates currentAgendum closed
+            -- newAgenda = P.union (P.deleteMin agenda) 
+            --                     (P.fromList $ toList $ candidates currentAgendum closed)
+
+
+candidates :: Agendum -> CBuildings -> Q.Seq (Int, Agendum)
+candidates agendum closed = newCandidates
+    where
+        candidate = current agendum
+        previous = trail agendum
+        succs = legalSuccessors $ successors candidate
+        nonloops = Q.filter (\s -> not $ (canonical s) `S.member` closed) succs
+        newCandidates = fmap (\a -> (cost a, a)) $ fmap (\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 -> (Q.Seq Building)
+successors (Building f floors) = Q.fromList [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 :: (Q.Seq Building) -> (Q.Seq Building)
+legalSuccessors = Q.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
+