From: Neil Smith <neil.git@njae.me.uk>
Date: Tue, 18 Dec 2018 10:50:10 +0000 (+0000)
Subject: Interim
X-Git-Url: https://git.njae.me.uk/?a=commitdiff_plain;h=6b93af4a851d5ac7f4b76aab94ea9a5a149601e6;p=advent-of-code-18.git

Interim
---

diff --git a/advent-of-code.cabal b/advent-of-code.cabal
index f7c1757..78e84a1 100644
--- a/advent-of-code.cabal
+++ b/advent-of-code.cabal
@@ -181,4 +181,14 @@ executable advent14
   main-is:             advent14.hs
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
-                     , containers            
\ No newline at end of file
+                     , containers   
+
+executable advent15
+  hs-source-dirs:      src/advent15
+  main-is:             advent15.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , containers   
+                     , pqueue
+
+                                              
\ No newline at end of file
diff --git a/data/advent15.txt b/data/advent15.txt
new file mode 100644
index 0000000..0bd71e0
--- /dev/null
+++ b/data/advent15.txt
@@ -0,0 +1,32 @@
+################################
+#######################.########
+#######################.########
+########..#############.########
+#######.....#########....#..####
+#######.....##########......####
+######....#..########.......#..#
+#######.G...########...........#
+####..GG....G######..........###
+########....G..###..E.......#.E#
+########...G..#....G..G.....E..#
+########...G...G.G...........E.#
+####....G.....#####..E......#E.#
+####.####.#..#######....G.....##
+####.G#####.#########..........#
+####G#####..#########..........#
+####.####..E#########..........#
+####...#..#.#########.G........#
+####.....G..#########.........##
+####..G....E.#######........####
+####G.........#####...##....####
+#####G................###..E####
+#####..####...............######
+####..#####.............########
+#####.#######...........########
+#####.########.........#########
+#####.########.....E..##########
+#.....#########...#.############
+#..#############....############
+################....############
+##################.#############
+################################
diff --git a/src/advent15/advent15.hs b/src/advent15/advent15.hs
new file mode 100644
index 0000000..abe0426
--- /dev/null
+++ b/src/advent15/advent15.hs
@@ -0,0 +1,252 @@
+import Data.List
+-- import Data.Tuple (swap)
+import Data.Maybe
+import qualified Data.Foldable
+import Data.Foldable (forM_)
+import qualified Data.Map.Strict as M
+import Data.Map.Strict ((!))
+import qualified Data.Set as S
+import qualified Data.PQueue.Prio.Min as P
+import qualified Data.Sequence as Q
+import Data.Sequence ((|>), (<|), Seq (Empty, (:<|), (:|>)))
+
+import Debug.Trace
+
+type Coord = (Int, Int) -- row, column
+type HitPoints = Int
+data Species = Elf | Goblin deriving (Show, Eq)
+data Agent = Agent Species HitPoints deriving (Show, Eq)
+type Agents = M.Map Coord Agent
+type Layout = S.Set Coord
+type OrderedLayout = Q.Seq Coord
+
+type Closed = Layout
+data Agendum = Agendum {_current :: Coord, _trail :: OrderedLayout, _cost :: Int} deriving (Show, Eq)
+type Agenda = P.MinPQueue (Int, Int) Agendum 
+
+newGoblin = Agent Goblin 200
+newElf = Agent Elf 200
+
+isSpecies s (Agent s' _) = s == s'
+
+isElf = isSpecies Elf
+isGoblin = isSpecies Goblin
+
+otherSpecies Elf = Goblin
+otherSpecies Goblin = Elf
+
+elfs :: Agents -> Agents
+elfs agents = M.filter isElf agents
+
+goblins :: Agents -> Agents
+goblins agents = M.filter isGoblin agents
+
+
+
+test1 = "#######\n#E..G.#\n#...#.#\n#.G.#G#\n#######\n"
+test2 = "#########\n#G..G..G#\n#.......#\n#.......#\n#G..E..G#\n#.......#\n#.......#\n#G..G..G#\n#########\n"
+test3 = "#######\n#.G...#\n#...EG#\n#.#.#G#\n#..G#E#\n#.....#\n#######\n"
+
+main :: IO ()
+main = do 
+    text <- readFile "data/advent15.txt"
+    let (layout, agents) = parse test3
+    print layout
+    print agents
+    putStrLn $ showWorld layout agents
+    print $ pathsToEnemies (1, 1) layout agents
+    -- let (h, e) = M.findMin $ elfs agents
+    -- print (h, e)
+    -- forM_ (M.assocs agents) $ \(ah, a) -> do 
+    --     print (ah, a)
+    --     print $ pathsToEnemies ah layout agents
+    --     print $ bestMove ah layout agents     
+    let a1 = doRound layout agents
+    putStrLn $ showWorld layout a1
+    print a1
+    let a2 = doRound layout a1
+    putStrLn $ showWorld layout a2
+    print a2
+    let a3 = doRound layout a2
+    putStrLn $ showWorld layout a3
+    print a3
+    let a4 = doRound layout a3
+    putStrLn $ showWorld layout a4
+    print a4
+    let a5 = doRound layout a4
+    putStrLn $ showWorld layout a5
+    print a5
+    let a6 = doRound layout a5
+    putStrLn $ showWorld layout a6
+    print a6
+
+
+showWorld layout agents = unlines rows
+    where rows = map (showRow layout agents) [minRow..maxRow]
+          minRow = fst $ S.findMin layout'
+          maxRow = fst $ S.findMax layout'
+          layout' = S.union layout $ S.fromList $ M.keys agents
+
+showRow layout agents row = map (\col -> showCell (row, col) layout agents) [minCol..maxCol]
+    where minCol = minimum $ map snd $ S.toList layout'
+          maxCol = maximum $ map snd $ S.toList layout'
+          layout' = S.union layout $ S.fromList $ M.keys agents
+
+showCell c layout agents = 
+    if c `M.member` agents
+    then if isElf a then 'E' else 'G'
+    else if c `S.member` layout then '.' else '\x2593'
+    where a = agents!c
+
+
+-- Parsing
+parse :: String -> (Layout, Agents)
+parse text = foldl' parseRow (S.empty, M.empty) $ zip [0..] $ lines text
+
+parseRow :: (Layout, Agents) -> (Int, String) -> (Layout, Agents)
+parseRow (layout, agents) (r, row) = foldl' parseCellWithY (layout, agents) $ zip [0..] row
+    where parseCellWithY = parseCell r
+
+parseCell :: Int -> (Layout, Agents) -> (Int, Char) -> (Layout, Agents)
+parseCell r (layout, agents) (c, cell) = 
+    let here = (r, c)
+    in case cell of 
+            'G' -> (S.insert here layout, M.insert here newGoblin agents)
+            'E' -> (S.insert here layout, M.insert here newElf agents)
+            '.' -> (S.insert here layout, agents)
+            _   -> (layout, agents)
+
+-- Locations
+
+adjacent :: Coord -> Layout -> Layout
+adjacent (r, c) layout = S.intersection layout 
+                         $ S.fromList [(r+1, c), (r-1, c), (r, c+1), (r, c-1)]
+
+free :: Coord -> Layout -> Agents -> Bool
+free here layout agents = (here `S.member` layout) && (here `M.notMember` agents)
+
+adjacentFree :: Coord -> Layout -> Agents -> Layout
+adjacentFree here layout agents = S.filter (\c -> free c layout agents) (adjacent here layout)
+
+orderedAdjacentFree :: Coord -> Layout -> Agents -> OrderedLayout
+orderedAdjacentFree here layout agents = Q.sort $ S.foldl' (|>) Q.empty cells
+    where cells = adjacentFree here layout agents
+
+
+-- Searching
+
+initAgenda :: Coord -> Coord -> Agenda
+initAgenda start goal = P.singleton ((estimateCost start goal), (fst start * 100 + snd start)) Agendum {_current = start, _trail = Q.empty, _cost = 0}
+
+aStar :: Coord -> Layout -> Agents -> Agenda -> Closed -> Maybe Agendum
+aStar goal layout agents agenda closed 
+    -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
+    | P.null agenda = Nothing
+    | otherwise = 
+        if reached == goal then Just currentAgendum
+        else if reached `S.member` closed 
+            then aStar goal layout agents (P.deleteMin agenda) closed
+            else aStar goal layout agents newAgenda closed'
+        where 
+            (_, currentAgendum) = P.findMin agenda
+            reached = _current currentAgendum
+            closed' = S.insert reached closed
+            tieBreakerCost a = foldl' (\t (r, c) -> t + r * 100 + c) 0 ((_current a) <| (_trail a))
+            newAgenda = foldl' (\q a -> P.insert ((estimatedCost a), tieBreakerCost a) a q) (P.deleteMin agenda) $ candidates layout agents currentAgendum closed'
+            estimatedCost agendum = estimateCost reached goal + _cost agendum
+
+candidates :: Layout -> Agents -> Agendum -> Closed -> Q.Seq Agendum
+candidates layout agents agendum closed = newCandidates
+    where
+        candidate = _current agendum
+        previous = _trail agendum
+        succs = orderedAdjacentFree candidate layout agents
+        nonloops = Q.filter (\s -> s `S.notMember` closed) succs
+        newCandidates = fmap (\n -> makeAgendum n) nonloops
+        makeAgendum new = Agendum { _current = new, 
+                                    _trail = candidate <| previous, 
+                                    _cost = _cost agendum + 1}
+
+estimateCost :: Coord -> Coord -> Int
+estimateCost (r, c) (gr, gc) = abs (r - gr) + abs(c - gc)
+
+-- Move selection
+
+shortestDistanceTo :: Coord -> Coord -> Layout -> Agents -> Maybe (Int, OrderedLayout)
+shortestDistanceTo here there layout agents = 
+    if searchResult == Nothing 
+    then Nothing
+    else Just (_cost $ fromJust searchResult, (_current $ fromJust searchResult) <| (_trail $ fromJust searchResult))
+    where searchResult = aStar there layout agents (initAgenda here there) S.empty
+
+enemyLocations :: Coord -> Agents -> Layout
+enemyLocations here agents = S.fromList $ M.keys $ M.filter (isSpecies enemySpecies) agents
+    where Agent thisSpecies _ = agents!here
+          enemySpecies = otherSpecies thisSpecies
+
+agentTargets :: Coord -> Layout -> Agents -> Layout
+agentTargets here layout agents = S.foldl S.union S.empty enemyAdjacents
+    where enemies = enemyLocations here agents
+          enemyAdjacents = S.map (\l -> adjacentFree l layout agents) enemies
+
+pathsToEnemies :: Coord -> Layout -> Agents -> [(Int, OrderedLayout)]
+pathsToEnemies here layout agents = catMaybes $ map sdt $ S.toList targets
+    where sdt there = shortestDistanceTo here there layout agents
+          targets = agentTargets here layout agents
+
+closestEnemies :: Coord -> Layout -> Agents -> [OrderedLayout]
+closestEnemies here layout agents = possibles
+    where paths = pathsToEnemies here layout agents
+          closest = minimum $ map fst paths
+          possibles = map snd $ filter (\p -> fst p == closest) paths
+
+bestMove :: Coord -> Layout -> Agents -> Coord
+bestMove here layout agents = 
+    if null paths
+    then here
+    else head $ sort $ map pathStep paths
+    where paths = closestEnemies here layout agents
+          pathStep p = if Q.length p > 1 then Q.index p (Q.length p - 2) else Q.index p 1
+
+makeBestMove :: Coord -> Layout -> Agents -> Agents
+makeBestMove here layout agents = M.insert there agent $ M.delete here agents
+    where agent = agents!here
+          there = bestMove here layout agents
+
+-- Attacking
+
+bestTarget :: Coord -> Layout -> Agents -> Coord
+bestTarget here layout agents = keyOfMinHP $ M.filterWithKey (\c _ -> c `S.member` enemies) agents
+    where enemies = touchingEnemies here layout agents
+
+attack :: Coord -> Agents -> Agents
+attack target agents = M.insert target (Agent species (hp - 3)) agents
+    where Agent species hp = agents!target
+
+keyOfMinHP :: Agents -> Coord -- Ord b => M.Map a b -> a
+keyOfMinHP m = fst $ M.foldrWithKey mergeKV (M.findMin m) m
+    where mergeKV k (Agent s v) (bestK, (Agent sb bestV)) = 
+            if v < bestV then (k, (Agent s v)) else (bestK, (Agent sb bestV))
+
+makeAttack :: Coord -> Layout -> Agents -> Agents
+makeAttack here layout agents = attack target agents
+    where target = bestTarget here layout agents
+
+-- Game loop          
+
+doRound :: Layout -> Agents -> Agents
+doRound layout agents = agents'
+    -- where agents' = foldl' (\a h -> makeBestMove h layout a) agents $ M.keys agents
+    where agents' = foldl' (\a h -> agentAction h layout a) agents $ M.keys agents
+
+touchingEnemies :: Coord -> Layout -> Agents -> Layout
+touchingEnemies here layout agents = S.intersection neighbourhood enemies
+    where neighbourhood = adjacent here layout 
+          enemies = enemyLocations here agents
+
+agentAction :: Coord -> Layout -> Agents -> Agents
+agentAction here layout agents = 
+    if S.null targets
+    then makeBestMove here layout agents
+    else makeAttack here layout agents
+    where targets = touchingEnemies here layout agents