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

[Dominik Bollmann]

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