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