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