src/task8/task8-bounded.hs

   1 import Data.Maybe (fromMaybe)
   2 import qualified Data.PQueue.Prio.Min as P
   3 import qualified Data.HashSet as S
   4 import qualified Data.Sequence as Q
   5 import qualified Data.HashMap.Strict as M
   6 import Data.Sequence ((<|))
   7 import Data.Foldable (foldl')
   8 import Data.HashMap.Strict ((!))
   9
  10
  11 data Grass = Short | Long deriving (Show, Eq)
  12 type Location = (Int, Int)
  13 data Neighbour = Neighbour {stepLocation :: Location, stepCost :: Int} deriving (Show, Eq)
  14 type Lawn = M.HashMap Location Grass
  15 data BoundedLawn = BoundedLawn { lawnMap :: Lawn
  16                                , minRow :: Int , minCol :: Int
  17                                , maxRow :: Int , maxCol :: Int
  18                                }
  19 type Closed = S.HashSet Location
  20 data Agendum = Agendum {current :: Location, trail :: Q.Seq Location, cost :: Int} deriving (Show, Eq)
  21 type Agenda = P.MinPQueue Int Agendum
  22
  23
  24 main :: IO ()
  25 main = do
  26     lawnT <- readFile "data/08-maze.txt"
  27     let lawn = parseLawn lawnT
  28     let boundedLawn = boundify lawn
  29     let goal = goalLocation boundedLawn
  30     let start = startLocation boundedLawn
  31     print $ part1 boundedLawn start goal
  32     print $ part2 boundedLawn start goal
  33
  34 part1 :: BoundedLawn -> Location -> Location -> Int
  35 part1 lawn start goal = cost $ fromMaybe (snd $ P.findMin $ initAgenda start goal) $ aStar 999 goal lawn (initAgenda start goal) S.empty
  36
  37 part2 :: BoundedLawn -> Location -> Location -> Int
  38 part2 lawn start goal = cost $ fromMaybe (snd $ P.findMin $ initAgenda start goal) $ aStar 3 goal lawn (initAgenda start goal) S.empty
  39
  40
  41 parseLawn :: String -> Lawn
  42 parseLawn lawnT = M.fromList lawnCells
  43     where lawnLines = zip [1..] $ lines lawnT
  44           lawnCells = concatMap (\(r, row) -> zipWith (cellify r) [1..] row) lawnLines
  45           cellify r c cell
  46             | cell == '#' = ((r, c), Long)
  47             | otherwise   = ((r, c), Short)
  48
  49 boundify lawn = BoundedLawn { lawnMap = lawn
  50                             , minRow = minR, minCol = minC
  51                             , maxRow = maxR, maxCol = maxC
  52                             }
  53     where minR = minimum $ map fst $ M.keys lawn
  54           maxR = maximum $ map fst $ M.keys lawn
  55           minC = minimum $ map snd $ M.keys lawn
  56           maxC = maximum $ map snd $ M.keys lawn
  57
  58 goalLocation :: BoundedLawn -> Location
  59 goalLocation lawn = ( maxRow lawn, maxCol lawn )
  60
  61 startLocation :: BoundedLawn -> Location
  62 startLocation lawn = ( minRow lawn, minCol lawn )
  63
  64 initAgenda :: Location -> Location -> Agenda
  65 initAgenda start goal = P.singleton (estimateCost start goal) Agendum {current = start, trail = Q.empty, cost = 0}
  66
  67 aStar :: Int -> Location -> BoundedLawn -> Agenda -> Closed -> Maybe Agendum
  68 aStar longCost goal lawn agenda closed
  69     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
  70     | P.null agenda = Nothing
  71     | otherwise =
  72         if reached == goal then Just currentAgendum
  73         else if reached `S.member` closed
  74             then aStar longCost goal lawn (P.deleteMin agenda) closed
  75             else aStar longCost goal lawn newAgenda (S.insert reached closed)
  76         where
  77             (_, currentAgendum) = P.findMin agenda
  78             reached = current currentAgendum
  79             newAgenda = foldl' (\q a -> P.insert (estimatedCost a) a q) (P.deleteMin agenda) $ candidates longCost lawn currentAgendum closed
  80             estimatedCost agendum = estimateCost (current agendum) goal + cost agendum
  81
  82
  83
  84 candidates :: Int -> BoundedLawn -> Agendum -> Closed -> Q.Seq Agendum
  85 candidates longCost lawn agendum closed = newCandidates
  86     where
  87         candidate = current agendum
  88         previous = trail agendum
  89         succs = successors longCost lawn candidate
  90         nonloops = Q.filter (\s -> not $ (stepLocation s) `S.member` closed) succs
  91         newCandidates = fmap (\n -> makeAgendum n) nonloops
  92         makeAgendum new = Agendum {current = stepLocation new,
  93                                     trail = candidate <| previous,
  94                                     cost = cost agendum + stepCost new}
  95
  96
  97 successors :: Int -> BoundedLawn -> Location -> (Q.Seq Neighbour)
  98 successors longCost boundedLawn (row, column) = Q.fromList $ map neighbourify neighbours
  99     where lawn = lawnMap boundedLawn
 100           neighbours = filter (\l -> l `M.member` lawn)
 101                                 [(r, c) | r <- [(row - 1)..(row + 1)],
 102                                           c <- [(column - 1)..(column + 1)],
 103                                           r >= minR,
 104                                           r <= maxR,
 105                                           c >= minC,
 106                                           c <= maxC,
 107                                           ((r == row && c /= column) || (r /= row && c == column)) ]
 108           neighbourify neighbour = Neighbour {stepLocation = neighbour, stepCost = scCalc neighbour}
 109           minR = minRow boundedLawn
 110           maxR = maxRow boundedLawn
 111           minC = minCol boundedLawn
 112           maxC = maxCol boundedLawn
 113           scCalc location = if lawn!location == Long
 114                             then longCost
 115                             else 1
 116
 117
 118 estimateCost :: Location -> Location -> Int
 119 estimateCost (r, c) (gr, gc) = abs (r - gr) + abs(c - gc)
 120