Trying out different data structures for day 11, seeing if any improve matters
authorNeil Smith <neil.git@njae.me.uk>
Fri, 30 Dec 2016 11:28:57 +0000 (11:28 +0000)
committerNeil Smith <neil.git@njae.me.uk>
Fri, 30 Dec 2016 11:28:57 +0000 (11:28 +0000)
README.html
README.md
adventofcode1611/adventofcode1611.cabal
adventofcode1611/app/advent11ps.hs
adventofcode1611/app/advent11psm.hs [new file with mode: 0644]
adventofcode1611/app/advent11psmh.hs [new file with mode: 0644]
stack.yaml

index a85b3e3862b72a69b374c6bdbd6fbb2018239392..2525fa50d86671ac892720ea9f4f48216ebae751 100644 (file)
 </div>
 <p>Code to solve the <a href="http://adventofcode.com/2016/">Advent of Code</a> puzzles. This year, I'm trying to use the puzzles as a prompt to learn <a href="https://wiki.haskell.org/Haskell">Haskell</a>.</p>
 <p><a href="http://learnyouahaskell.com/chapters">Learn you a Haskell</a>, <a href="https://www.haskell.org/tutorial/index.html">Introduction to Haskell 98</a>, and <a href="https://hackage.haskell.org/">Hackage</a> are good resources.</p>
-<p>I'm using the basic Haskell Platform installation (install with</p>
-<pre><code>$ sudo aptitude install haskell-platform</code></pre>
+<h1 id="toolchain">Toolchain</h1>
+<p>I'm using the basic Haskell Platform installation, togeher with <code>Stack</code> to manage the packages and dependencies (install with</p>
+<pre><code>$ sudo aptitude install haskell-platform haskell-stack</code></pre>
 <p>).</p>
+<p>I have one package for each day, to save time waiting for Stack to check every executable before compiling what's changed. Each package needs a separate directory tree and a separate <code>.cabal</code> file.</p>
+<p>Compile with</p>
+<pre><code>stack build</code></pre>
+<p>or</p>
+<pre><code>stack build adventofcode1601</code></pre>
+<p>Run with</p>
+<pre><code>stack exec advent01</code></pre>
+<p>Run interactively with</p>
+<pre><code>stack ghci adventofcode1601:exe:advent01</code></pre>
+<p>To profile, use</p>
+<pre><code>stack build --executable-profiling --library-profiling -ghc-options=&quot;-fprof-auto -rtsopts&quot; adventofcode1601</code></pre>
+<p>then run with</p>
+<pre><code>stack exec -- advent01 +RTS -p -hy</code></pre>
+<h1 id="readme">Readme</h1>
+<p>Build this readme file wth</p>
+<pre><code>pandoc -s README.md &gt; README.html</code></pre>
+<h3 id="earlier-instructions-for-compiling-before-use-of-stack">Earlier instructions, for compiling before use of Stack</h3>
 <p>I'm also using some extra libraries. Before installing, run <code>cabal update</code> then set <code>library-profiling: True</code> in <code>~/.cabal/config</code> . Then install the packages with</p>
 <pre><code>$ cabal install MissingH
 $ cabal install parsec-numbers
@@ -30,8 +48,6 @@ $ cabal install pqueue</code></pre>
 <pre><code>ghc -O2 --make advent01.hs -prof -auto-all -caf-all -fforce-recomp -rstopts
 time ./advent01 +RTS -p -hy</code></pre>
 <p>and create the profile picture with <code>h2ps advent01.hp</code> .</p>
-<p>Build this readme file wth</p>
-<pre><code>pandoc -s README.md &gt; README.html</code></pre>
 <p>(Using the <a href="https://github.com/markdowncss/modest">Modest style</a>.)</p>
 </body>
 </html>
index 2e4886ca28d1928ef768353217ce845fb803e444..78f784902e697cbf693ffb83b1427f29474601c0 100644 (file)
--- a/README.md
+++ b/README.md
@@ -7,12 +7,53 @@ Code to solve the [Advent of Code](http://adventofcode.com/2016/) puzzles. This
 
 [Learn you a Haskell](http://learnyouahaskell.com/chapters), [Introduction to Haskell 98](https://www.haskell.org/tutorial/index.html), and [Hackage](https://hackage.haskell.org/) are good resources.
 
-I'm using the basic Haskell Platform installation (install with
+# Toolchain
+
+I'm using the basic Haskell Platform installation, togeher with `Stack` to manage the packages and dependencies (install with
 ```
-$ sudo aptitude install haskell-platform
+$ sudo aptitude install haskell-platform haskell-stack
 ```
 ).
 
+I have one package for each day, to save time waiting for Stack to check every executable before compiling what's changed. Each package needs a separate directory tree and a separate `.cabal` file. 
+
+Compile with
+```
+stack build
+```
+or 
+```
+stack build adventofcode1601
+```
+
+Run with
+```
+stack exec advent01
+```
+
+Run interactively with
+```
+stack ghci adventofcode1601:exe:advent01
+```
+
+To profile, use 
+```
+stack build --executable-profiling --library-profiling -ghc-options="-fprof-auto -rtsopts" adventofcode1601
+```
+then run with
+```
+stack exec -- advent01 +RTS -p -hy
+```
+
+# Readme
+
+Build this readme file wth
+```
+pandoc -s README.md > README.html
+```
+
+### Earlier instructions, for compiling before use of Stack
+
 I'm also using some extra libraries. Before installing, run `cabal update` then set `library-profiling: True` in `~/.cabal/config` . Then install the packages with  
 ```
 $ cabal install MissingH
@@ -39,9 +80,4 @@ time ./advent01 +RTS -p -hy
 
 and create the profile picture with `h2ps advent01.hp` . 
 
-Build this readme file wth
-```
-pandoc -s README.md > README.html
-```
-
-(Using the [Modest style](https://github.com/markdowncss/modest).)
\ No newline at end of file
+(Using the [Modest style](https://github.com/markdowncss/modest).)
index 19ce815b155992baa691b663b67a5587a46bf7a3..d6b3810e525c3357c12b674aadde6cbd15581fa1 100644 (file)
@@ -63,6 +63,30 @@ executable advent11ps
                      , unordered-containers
   default-language:    Haskell2010
 
+executable advent11psm
+  hs-source-dirs:      app
+  main-is:             advent11psm.hs
+  ghc-options:         -O2 -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , adventofcode16
+                     , pqueue
+                     , hashable
+                     , containers
+                     , unordered-containers
+  default-language:    Haskell2010
+
+executable advent11psmh
+  hs-source-dirs:      app
+  main-is:             advent11psmh.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
index 349c8a55b2546693a9f7f4e70547016fc30ac50e..cccf02f25db72bc0671f6fdf5aa9d9f1ed8ad786 100644 (file)
@@ -12,7 +12,7 @@ module Main(main) where
 import GHC.Generics (Generic)
 
 -- import Prelude hiding (length, take, drop)
-import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices)
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices, intercalate)
 import Data.Ord (comparing)
 import Data.Char (isDigit)
 import Data.Maybe (fromMaybe)
@@ -22,19 +22,25 @@ import qualified Data.HashSet as S
 import qualified Data.Sequence as Q
 import Data.Sequence ((<|), (|>), (><))
 import Data.Foldable (toList, foldr')
+import Debug.Trace
 
 
-data Item = Generator String | Microchip String deriving (Show, Eq, Generic)
+data Item = Generator String | Microchip String deriving (Eq, Generic)
 instance Hashable Item
 type Floor = [Item]
-data Building = Building Int [Floor] deriving (Show, Eq, Generic)
+data Building = Building Int [Floor] deriving (Eq, Ord, Generic)
 instance Hashable Building
 data CBuilding = CBuilding Int Integer deriving (Show, Eq, Generic)
 instance Hashable CBuilding
+-- instance Hashable CBuilding where
+--     hashWithSalt s (CBuilding f fs) =
+--         s `hashWithSalt`
+--         f `hashWithSalt` fs
+
 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)
+-- type Candidates = S.HashSet (Int, Agendum)
 
 instance Ord Item where
     compare (Generator a) (Generator b) = compare a b
@@ -42,8 +48,17 @@ instance Ord Item where
     compare (Generator _) (Microchip _) = LT
     compare (Microchip _) (Generator _) = GT
 
-instance Ord Building where
-    compare b1 b2 = comparing estimateCost b1 b2
+instance Show Item where
+    show (Generator a) = "G" ++ take 2 a
+    show (Microchip a) = "M" ++ take 2 a
+
+-- instance Ord Building where
+--     compare b1 b2 = comparing estimateCost b1 b2
+
+instance Show Building where
+    show (Building f floors) = (show f) ++ "<* " ++ (intercalate "; " $ map (showFloor) floors)
+        where showFloor fl = intercalate ", " $ map (show) fl
+
 
 building1 = Building 0 [
     (sort [Generator "polonium", Generator "thulium", 
@@ -94,9 +109,13 @@ canonical (Building f floors) = CBuilding f (read $ filter (isDigit) $ show $ so
 
 main :: IO ()
 main = do 
+    -- part0
     part1 
     part2 
 
+part0 :: IO ()
+part0 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda buildingTest) S.empty
+
 part1 :: IO ()
 part1 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda building1) S.empty
 
@@ -109,6 +128,7 @@ initAgenda b = P.singleton (estimateCost b) Agendum {current = b, trail = Q.empt
 aStar :: Agenda -> CBuildings -> Maybe Agendum
 -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
 aStar agenda closed 
+    -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " :: " ++ (show newAgenda)) False = undefined
     | P.null agenda = Nothing
     | otherwise = 
         if isGoal reached then Just currentAgendum
diff --git a/adventofcode1611/app/advent11psm.hs b/adventofcode1611/app/advent11psm.hs
new file mode 100644 (file)
index 0000000..5a29bf1
--- /dev/null
@@ -0,0 +1,194 @@
+-- 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,
+-- Sets for various collecions, and a Map to store the floors in the
+-- building.
+
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main(main) where
+
+import GHC.Generics (Generic)
+
+-- import Prelude hiding (length, take, drop)
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices, intercalate)
+import Data.Ord (comparing)
+import Data.Char (isDigit)
+import Data.Maybe (fromMaybe, fromJust)
+import qualified Data.PQueue.Prio.Min as P
+import qualified Data.Set as S
+import qualified Data.Sequence as Q
+import qualified Data.Map.Strict as M
+import Data.Hashable
+import Data.Sequence ((<|), (|>), (><))
+import Data.Foldable (toList, foldr', foldl', all)
+import Debug.Trace
+
+data Item = Generator String | Microchip String deriving (Eq, Generic)
+type Floor = S.Set Item
+type Floors = M.Map Int Floor
+data Building = Building Int Floors deriving (Eq, Ord, Generic)
+type Buildings = S.Set 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 Building, cost :: Int} deriving (Show, Eq)
+type Agenda = P.MinPQueue Int Agendum 
+type Candidates = S.Set (Int, Agendum)
+
+instance Show Item where
+    show (Generator a) = "G" ++ take 2 a
+    show (Microchip a) = "M" ++ take 2 a
+
+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
+
+instance Show Building where
+    show (Building f floors) = (show f) ++ "<* " ++ (intercalate "; " $ toList $ M.map (showFloor) floors)
+        where showFloor fl = intercalate ", " $ toList $ S.map (show) fl
+
+
+-- 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"]),
+--     [],
+--     []
+--     ]
+
+building1 = Building 0 (M.fromList 
+        [ (0, S.fromList [Generator "polonium", Generator "thulium", 
+                          Microchip "thulium", Generator "promethium", Generator "ruthenium",
+                          Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"])
+        , (1, S.fromList [Microchip "polonium", Microchip "promethium"])
+        , (2, S.empty )
+        , (3, S.empty )
+        ])
+
+
+
+building0 = Building 0 (M.fromList 
+        [ (0, S.fromList [Generator "polonium", Generator "thulium", Microchip "thulium", Generator "promethium"])
+        , (1, S.fromList [Microchip "polonium", Microchip "promethium"])
+        , (2, S.empty )
+        , (3, S.empty )
+        ])
+
+building2 = Building 0 (M.fromList 
+        [ (0, S.fromList [Generator "polonium", Generator "thulium", 
+                          Microchip "thulium", Generator "promethium", Generator "ruthenium",
+                          Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
+                          Generator "dilithium", Microchip "dilithium"])
+        , (1, S.fromList [Microchip "polonium", Microchip "promethium"])
+        , (2, S.empty )
+        , (3, S.empty )
+        ])
+
+buildingTest = Building 0 (M.fromList 
+        [ (0, S.fromList [Microchip "hydrogen", Microchip "lithium"])
+        , (1, S.fromList [Generator "hydrogen"])
+        , (2, S.fromList [Generator "lithium"])
+        , (3, S.empty )
+        ])
+
+
+main :: IO ()
+main = do 
+    -- part0
+    part1 
+    part2 
+
+part0 :: IO ()
+part0 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda buildingTest) S.empty
+
+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 -> Buildings -> Maybe Agendum
+-- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
+aStar agenda closed 
+    -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
+    | P.null agenda = Nothing
+    | otherwise = 
+        if isGoal reached then Just currentAgendum
+        else if reached `S.member` closed 
+            then aStar (P.deleteMin agenda) closed
+            else aStar newAgenda (S.insert reached closed)
+        where 
+            (_, currentAgendum) = P.findMin agenda
+            reached = current currentAgendum
+            newAgenda = foldl' (\q a -> P.insert (cost a) a q) (P.deleteMin agenda) $ candidates currentAgendum closed
+
+
+
+candidates :: Agendum -> Buildings -> Q.Seq Agendum
+candidates agendum closed = newCandidates
+    where
+        candidate = current agendum
+        previous = trail agendum
+        succs = legalSuccessors $ successors candidate
+        nonloops = Q.filter (\s -> not $ s `S.member` closed) succs
+        newCandidates = fmap (\n -> makeAgendum n) nonloops
+        makeAgendum new = Agendum {current = new, 
+                                    trail = candidate <| previous, 
+                                    cost = estimateCost new + length previous + 1}
+
+isGoal :: Building -> Bool
+isGoal (Building f floors) =
+    f+1 == height && (all (S.null) $ M.filterWithKey (\k _ -> k < f) floors)
+    where height = M.size floors
+
+isLegal :: Building -> Bool
+isLegal (Building f floors) = 
+    null floor 
+    ||
+    not (any (isGenerator) floor)
+    ||
+    any (safePair) pairs
+    where floor = fromJust $ M.lookup f floors
+          pairs = [(i, j) | i <- (S.toList floor), j <- (S.toList 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 b@(Building f floors) = Q.fromList [updateBuilding b nf is | nf <- nextFloors, is <- items]
+    where 
+        floor = fromJust $ M.lookup f floors
+        items = map (S.fromList) $ filter (\is -> length is == 1 || length is == 2) $ subsequences $ toList 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 :: Building -> Int -> Floor -> Building
+updateBuilding (Building oldF oldFloors) newF items = Building newF newFloors
+    where newFloors = M.adjust (\f -> f `S.union` items) newF $ M.adjust (\f -> f `S.difference` items) oldF oldFloors 
+
+
+estimateCost :: Building -> Int
+estimateCost (Building _ floors) = 
+    sum $ map (\(c, f) -> c * S.size f) $ zip [0..] $ reverse $ M.elems floors
+
diff --git a/adventofcode1611/app/advent11psmh.hs b/adventofcode1611/app/advent11psmh.hs
new file mode 100644 (file)
index 0000000..e2427a8
--- /dev/null
@@ -0,0 +1,202 @@
+-- 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,
+-- Sets for various collecions, and a Map to store the floors in the
+-- building.
+
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main(main) where
+
+import GHC.Generics (Generic)
+
+-- import Prelude hiding (length, take, drop)
+import Data.List (subsequences, (\\), sort, sortOn, nub, findIndices, intercalate)
+import Data.Ord (comparing)
+import Data.Char (isDigit)
+import Data.Maybe (fromMaybe, fromJust)
+import qualified Data.PQueue.Prio.Min as P
+import qualified Data.HashSet as S
+import qualified Data.Sequence as Q
+import qualified Data.HashMap.Strict as M
+import Data.Hashable
+import Data.Sequence ((<|), (|>), (><))
+import Data.Foldable (toList, foldr', foldl', all)
+import Debug.Trace
+
+data Item = Generator String | Microchip String deriving (Eq, Generic)
+instance Hashable Item
+data Floor = Floor (S.HashSet Item) deriving (Eq, Generic)
+instance Hashable Floor
+unFloor :: Floor -> S.HashSet Item
+unFloor (Floor f) = f
+data Floors = Floors (M.HashMap Int Floor) deriving (Eq, Generic)
+instance Hashable Floors
+data Building = Building Int Floors deriving (Eq, Generic)
+instance Hashable Building
+type Buildings = S.HashSet 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 Building, cost :: Int} deriving (Show, Eq)
+type Agenda = P.MinPQueue Int Agendum 
+type Candidates = S.HashSet (Int, Agendum)
+
+instance Show Item where
+    show (Generator a) = "G" ++ take 2 a
+    show (Microchip a) = "M" ++ take 2 a
+
+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
+
+instance Show Building where
+    show (Building f (Floors floors)) = (show f) ++ "<* " ++ (intercalate "; " $ toList $ M.map (showFloor. unFloor) floors)
+        where showFloor fl = intercalate ", " $ toList $ S.map (show) fl
+
+
+-- 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"]),
+--     [],
+--     []
+--     ]
+
+building1 = Building 0 (Floors $ M.fromList 
+        [ (0, Floor $ S.fromList [Generator "polonium", Generator "thulium", 
+                          Microchip "thulium", Generator "promethium", Generator "ruthenium",
+                          Microchip "ruthenium", Generator "cobalt", Microchip "cobalt"])
+        , (1, Floor $ S.fromList [Microchip "polonium", Microchip "promethium"])
+        , (2, Floor $ S.empty )
+        , (3, Floor $ S.empty )
+        ])
+
+
+
+building0 = Building 0 (Floors $ M.fromList 
+        [ (0, Floor $ S.fromList [Generator "polonium", Generator "thulium", Microchip "thulium", Generator "promethium"])
+        , (1, Floor $ S.fromList [Microchip "polonium", Microchip "promethium"])
+        , (2, Floor $ S.empty )
+        , (3, Floor $ S.empty )
+        ])
+
+building2 = Building 0 (Floors $ M.fromList 
+        [ (0, Floor $ S.fromList [Generator "polonium", Generator "thulium", 
+                          Microchip "thulium", Generator "promethium", Generator "ruthenium",
+                          Microchip "ruthenium", Generator "cobalt", Microchip "cobalt",
+                          Generator "dilithium", Microchip "dilithium"])
+        , (1, Floor $ S.fromList [Microchip "polonium", Microchip "promethium"])
+        , (2, Floor $ S.empty )
+        , (3, Floor $ S.empty )
+        ])
+
+buildingTest = Building 0 (Floors $ M.fromList 
+        [ (0, Floor $ S.fromList [Microchip "hydrogen", Microchip "lithium"])
+        , (1, Floor $ S.fromList [Generator "hydrogen"])
+        , (2, Floor $ S.fromList [Generator "lithium"])
+        , (3, Floor $ S.empty )
+        ])
+
+
+main :: IO ()
+main = do 
+    -- part0
+    part1 
+    part2 
+
+part0 :: IO ()
+part0 = print $ length $ trail $ fromMaybe (snd $ P.findMin $ initAgenda buildingTest) $ aStar (initAgenda buildingTest) S.empty
+
+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 -> Buildings -> Maybe Agendum
+-- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
+aStar agenda closed 
+    -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
+    | P.null agenda = Nothing
+    | otherwise = 
+        if isGoal reached then Just currentAgendum
+        else if reached `S.member` closed 
+            then aStar (P.deleteMin agenda) closed
+            else aStar newAgenda (S.insert reached closed)
+        where 
+            (_, currentAgendum) = P.findMin agenda
+            reached = current currentAgendum
+            newAgenda = foldl' (\q a -> P.insert (cost a) a q) (P.deleteMin agenda) $ candidates currentAgendum closed
+
+
+
+candidates :: Agendum -> Buildings -> Q.Seq Agendum
+candidates agendum closed = newCandidates
+    where
+        candidate = current agendum
+        previous = trail agendum
+        succs = legalSuccessors $ successors candidate
+        nonloops = Q.filter (\s -> not $ s `S.member` closed) succs
+        newCandidates = fmap (\n -> makeAgendum n) nonloops
+        makeAgendum new = Agendum {current = new, 
+                                    trail = candidate <| previous, 
+                                    cost = estimateCost new + length previous + 1}
+
+isGoal :: Building -> Bool
+isGoal (Building f (Floors floors)) =
+    f+1 == height && (all (\fl -> S.null $ unFloor fl) $ M.filterWithKey (\k _ -> k < f) floors)
+    where height = M.size floors
+
+isLegal :: Building -> Bool
+isLegal (Building f (Floors floors)) = 
+    null floor 
+    ||
+    not (any (isGenerator) floor)
+    ||
+    any (safePair) pairs
+    where floor = unFloor $ fromJust $ M.lookup f floors
+          pairs = [(i, j) | i <- (S.toList floor), j <- (S.toList 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 b@(Building f (Floors floors)) = Q.fromList [updateBuilding b nf is | nf <- nextFloors, is <- items]
+    where 
+        floor = unFloor $ fromJust $ M.lookup f floors
+        items = map (S.fromList) $ filter (\is -> length is == 1 || length is == 2) $ subsequences $ toList 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 :: Building -> Int -> S.HashSet Item -> Building
+updateBuilding (Building oldF (Floors oldFloors)) newF items = Building newF (Floors newFloors)
+    where oldFloorsE = fmap (unFloor) oldFloors
+          newFloorsE = M.adjust (\f -> f `S.union` items) newF $ M.adjust (\f -> f `S.difference` items) oldF oldFloorsE
+          newFloors = fmap (Floor) newFloorsE
+
+
+estimateCost :: Building -> Int
+estimateCost (Building _ (Floors floors)) = 
+    sum $ map (\(c, f) -> c * S.size f) $ zip [0..] $ reverse $ M.elems $ fmap (unFloor) floors
+
index d3fc84937c8b5c5986c06b30bf60073898a7f48d..bc4f778d9024cefb0a39caa2eb47f338df353231 100644 (file)
@@ -32,4 +32,4 @@ extra-deps:
 - astar-0.3.0.0
 - parsec-numbers-0.1.0
 - pqueue-1.3.2
-resolver: lts-6.25
+resolver: lts-6.27