[Haskell-cafe] [Open Kattis Problem] How can I speed up my A* algorithm and/or binomial heaps?

[Dominik Bollmann]

Hi Brent,

Thanks for your answer and hint! You gave me the clue how to approach the
problem from a different angle, thereby not needing search nor a
binomial heap anymore. I hope to implement it soon. :-)

Cheers, Dominik.

Brent Yorgey <byorgey at gmail.com> writes:

> Hi Dominik,
>
> Although optimizing your A* and binomial heap implementations is certainly
> a worthwhile challenge, I suspect it is not the real issue.  The input can
> be a grid of size 1000 by 1000, and you have to answer up to 1000 queries.
> In the worst case, the path between the two query points could pass through
> about half the cells (imagine a path of 1's snaking back and forth).  This
> suggests that even if your search algorithm took time linear in the number
> of cells it explored, it would still be too slow (a good rule of thumb is
> 10^8 operations per second, and we're looking at 10^3 * 10^3 * 10^3), and
> of course A* search is not even linear time.
>
> Hint: can you think of a way to preprocess the input so that queries can
> subsequently be answered very quickly, without doing any search?
>
> -Brent
>
> On Sat, May 23, 2020 at 3:42 PM Dominik Bollmann <dominikbollmann at gmail.com>
> wrote:
>
>>
>> Hi Haskell-Cafe,
>>
>> I've been trying to solve the Problem "10 Kinds Of People" at
>> https://open.kattis.com/problems/10kindsofpeople. My idea was to use the
>> A* algorithm to check whether the destination can be reached from the
>> source. To model the A* algorithm's priority queue, I also wrote a naive
>> implementation of a binomial heap. I've attached the code snippet below.
>>
>> Unfortunately, my solution doesn't pass all of Open Kattis' test cases.
>> In particular, it times out on the 22nd test case. Therefore I'm
>> wondering how to speed up my solution. Did I make any obvious, silly
>> mistakes?
>>
>> According to my time-profiling it seems that most of the time is spent
>> in the binomial heap's deleteMin function. Maybe I should therefore not
>> model the Heap as a list of trees, but rather as a vector of trees?
>>
>> Any hints on how to make the below snippet run faster is highly
>> appreciated! :-)
>>
>> Thanks!
>>
>> Dominik
>>
>> =============================================
>>
>> import Control.Monad
>> import Data.Function
>> import Data.Foldable (foldl')
>> import Data.List (minimumBy, delete)
>> import Data.Maybe
>> import qualified Data.Set as S
>> import qualified Data.Vector as V
>>
>> data Tree a = Node Int a [Tree a] deriving (Eq, Show)
>> type Heap a = [Tree a]
>>
>> rank :: Tree a -> Int
>> rank (Node k _ _) = k
>>
>> root :: Tree a -> a
>> root (Node _ x _) = x
>>
>> children :: Tree a -> [Tree a]
>> children (Node _ _ cs) = cs
>>
>> findMin :: Ord a => Heap a -> Maybe a
>> findMin []     = Nothing
>> findMin (t:ts) = Just . root $ foldl' selectMin t ts
>>   where
>>     selectMin e a
>>       | root e <= root a = e
>>       | otherwise        = a
>>
>> empty :: Heap a
>> empty = []
>>
>> singleton :: Ord a => a -> Heap a
>> singleton x = insert x empty
>>
>> insert :: Ord a => a -> Heap a -> Heap a
>> insert x ts = foldr increment singleton ts
>>   where
>>     singleton = [Node 0 x []]
>>     increment t (h:hs)
>>       | rank t > rank h  = t:h:hs
>>       | rank t == rank h = linkTrees t h : hs
>>       | rank t < rank h  = error "insert: invalid case!"
>>
>> linkTrees :: Ord a => Tree a -> Tree a -> Tree a
>> linkTrees t1 t2@(Node r x ts)
>>   | root t1 < root t2 = linkTrees t2 t1
>>   | otherwise         = Node (r+1) x (t1:ts)
>>
>> fromList :: Ord a => [a] -> Heap a
>> fromList = foldr insert empty
>>
>> union :: Ord a => Heap a -> Heap a -> Heap a
>> union h1 h2 = reverse $ reverse h1 `add` reverse h2
>>   where
>>     add (t1:t2:t1s) t2s -- take care of the carry bit
>>       | rank t1 == rank t2 = add (linkTrees t1 t2 : t1s) t2s
>>     add [] t2s = t2s
>>     add t1s [] = t1s
>>     add (t1:t1s) (t2:t2s)
>>       | rank t1 == rank t2 = add (linkTrees t1 t2 : t1s) t2s
>>       | rank t1 < rank t2  = t1 : add t1s (t2:t2s)
>>       | rank t1 > rank t2  = t2 : add (t1:t1s) t2s
>>
>> deleteMin :: Ord a => Heap a -> Heap a
>> deleteMin h = delete minTree h `union` children minTree
>>   where minTree = minimumBy (compare `on` root) h
>>
>> uncons :: Ord a => Heap a -> Maybe (a, Heap a)
>> uncons h = do
>>   min <- findMin h
>>   pure (min, deleteMin h)
>>
>> data Entry p a = Entry { priority :: p, payload :: a } deriving Show
>>
>> instance Eq p => Eq (Entry p a) where
>>   (Entry p1 _) == (Entry p2 _) = p1 == p2
>> instance Ord p => Ord (Entry p a) where
>>   (Entry p1 _) <= (Entry p2 _) = p1 <= p2
>>
>> data Point = Point { y :: !Int, x :: !Int } deriving (Eq, Ord, Show)
>> data PeopleKind = Binary | Decimal deriving Eq
>> newtype Map = Map { getMap :: (V.Vector (V.Vector PeopleKind)) } deriving
>> Show
>>
>> instance Show PeopleKind where
>>   show Binary = "binary"
>>   show Decimal = "decimal"
>>
>> readMap :: Int -> Int -> IO Map
>> readMap r c = do
>>   rows <- forM [1..r] $ \_ -> do
>>     row <- map readCell <$> getLine
>>     pure (V.fromListN c row)
>>   pure $ Map (V.fromList rows)
>>   where
>>     readCell :: Char -> PeopleKind
>>     readCell c = case c of
>>       '0' -> Binary
>>       '1' -> Decimal
>>       _   -> error "Map invalid!"
>>
>> readFromTo :: IO (Point, Point)
>> readFromTo = do
>>   [fy, fx, ty, tx] <- map read . words <$> getLine
>>   pure (Point (fy-1) (fx-1), Point (ty-1) (tx-1))
>>
>> reachable :: PeopleKind -> Map -> Point -> Point -> Bool
>> reachable kind grid from to = go S.empty (singleton entry0)
>>   where
>>     entry0 = Entry (0 + estimate from to, 0) from
>>     go explored frontier = case uncons frontier of
>>       Nothing -> False
>>       Just (Entry (_, cost) point, frontier')
>>         | point == to -> True
>>         | point `S.member` explored -> go explored frontier'
>>         | otherwise ->
>>             let successors = map (mkEntry cost) $ neighbors kind grid point
>>             in go (S.insert point explored) (frontier' `union` fromList
>> successors)
>>     mkEntry c s = Entry (c+1 + estimate s to, c+1) s
>>
>> estimate :: Point -> Point -> Double
>> estimate (Point y1 x1) (Point y2 x2) =
>>   sqrt . fromIntegral $ (y2 - y1)^2 + (x2 - x1)^2
>>
>> neighbors :: PeopleKind -> Map -> Point -> [Point]
>> neighbors k (Map m) (Point y x) =
>>   catMaybes [left, right, top, bottom]
>>   where
>>     left   = kindOk y (x-1)
>>     right  = kindOk y (x+1)
>>     top    = kindOk (y-1) x
>>     bottom = kindOk (y+1) x
>>     kindOk y x = do
>>       kind <- m V.!? y >>= (V.!? x)
>>       guard (kind == k)
>>       pure (Point y x)
>>
>> main :: IO ()
>> main = do
>>   [rows, cols] <- map read . words <$> getLine
>>   grid <- readMap rows cols
>>   queries <- read <$> getLine
>>   forM_ [1..queries] $ \_ -> do
>>     (from, to) <- readFromTo
>>     let kind = kindAt grid from
>>     if reachable kind grid from to
>>       then print kind
>>       else putStrLn "neither"
>>   where
>>     kindAt (Map m) (Point y x) = m V.! y V.! x
>> _______________________________________________
>> Haskell-Cafe mailing list
>> To (un)subscribe, modify options or view archives go to:
>> http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe
>> Only members subscribed via the mailman list are allowed to post.