Submission #140275

---

Source Code Expand

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns, ViewPatterns, OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MagicHash, UnboxedTuples #-}

import Control.Applicative
import Control.Arrow
import Data.Function
import qualified Data.ByteString.Char8 as S
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as UM
import qualified Data.IntMap as IM
import Control.Monad
import Data.Tuple

--import Debug.Trace


import GHC.ST (ST(..))
import GHC.Exts (Int(..), MutableByteArray#, newByteArray#, readIntArray#)
import GHC.Exts (writeIntArray#)

-- | Untyped byte array.
data MBA s = MBA (MutableByteArray# s)

newMBA :: Int -> ST s (MBA s)
newMBA (I# bytes) = ST $ \s -> let
  !(# s1, mba #) = newByteArray# bytes s
  in (# s1, MBA mba #)

readIntMBA :: MBA s -> Int -> ST s Int
readIntMBA (MBA mba) (I# ofs) = ST $ \s -> let
  !(# s1, val #) = readIntArray# mba ofs s
  in (# s1, I# val #)
{-# INLINE readIntMBA #-}

writeIntMBA :: MBA s -> Int -> Int -> ST s ()
writeIntMBA (MBA mba) (I# ofs) (I# val) = ST $ \s -> let
  !s1 = writeIntArray# mba ofs val s
  in (# s1, () #)
{-# INLINE writeIntMBA #-}


data MQueue s a = MQueue
  { mqSzV :: !(MBA s) -- raedp, writep
  , mqVals :: !(UM.MVector s a)
  }

newMQ :: (UM.Unbox a) => Int -> ST s (MQueue s a)
newMQ cap = MQueue
  <$> do
    r <- newMBA 16
    writeIntMBA r 0 0
    writeIntMBA r 1 0
    return r
  <*> UM.new cap

pushMQ :: (UM.Unbox a) => MQueue s a -> a -> ST s ()
pushMQ MQueue{..} (forceU -> !val) = do
  readp <- readIntMBA mqSzV 0
  writep <- readIntMBA mqSzV 1
  let !writep' = rem (writep + 1) $ UM.length mqVals
  when (writep' == readp) $ fail $
    "pushMQ: overflow (cap=" ++ show (UM.length mqVals) ++ ")"
  UM.unsafeWrite mqVals writep val
  writeIntMBA mqSzV 1 writep'
{-# INLINE pushMQ #-}

popMQ :: (UM.Unbox a) => MQueue s a -> ST s (Maybe a)
popMQ MQueue{..} = do
  readp <- readIntMBA mqSzV 0
  writep <- readIntMBA mqSzV 1
  if readp == writep
    then return Nothing
    else do
      writeIntMBA mqSzV 0 $ (readp + 1) `rem` UM.length mqVals
      Just <$> UM.unsafeRead mqVals readp
{-# INLINE popMQ #-}

forceU :: (U.Unbox a) => a -> a
forceU x = G.elemseq (vec x) x x
  where
    vec :: a -> U.Vector a
    vec = undefined
{-# INLINE forceU #-}

trace :: a -> b -> b
trace = const id

data Graph = Graph
  { gV :: !Int
  , gE :: !(V.Vector (U.Vector Int))
  }
  deriving (Show)

type GMat = [U.Vector Int]

tr :: (Show a) => String -> a -> a
tr hdr val = trace (hdr++": "++show val) val

solve :: Graph -> Graph -> (Int, Int)
solve gx gy = (max (U.maximum mdx) $ max (U.maximum mdy) $ U.minimum mdx + U.minimum mdy + 1, U.maximum mdx + U.maximum mdy + 1)
  where
    mdx = calc gx
    mdy = calc gy
    calc = maxDists . bfs

maxDists :: GMat -> U.Vector Int
maxDists = U.convert . V.map U.maximum . V.fromList

bfs :: Graph -> GMat
bfs g@Graph{..} = tr ("bfs:" ++ show g) $ map bfs1 [0..gV - 1]
  where
    bfs1 i = U.create $ do
      !mv <- UM.replicate gV inf
      !q <- newMQ 1000
      UM.unsafeWrite mv i 0
      pushMQ q i
      fix $ \fill -> do
        top <- popMQ q
        case top of
          Nothing -> return ()
          Just !x -> do
            dist <- UM.unsafeRead mv x
            let !dist' = dist + 1
            flip U.mapM_  (gE `V.unsafeIndex` x) $ \other -> do
              old' <- UM.unsafeRead mv other
              when (old' == inf) $ do
                UM.unsafeWrite mv other dist'
                pushMQ q other
            fill
      return mv

inf :: Int
inf = 1000000

main :: IO ()
main = do
  (a, b) <- solve <$> readGraph <*> readGraph
  putStrLn $ unwords $ map show [a, b]

readGraph :: IO Graph
readGraph = do
  [n,m] <- map readInt . S.words <$> S.getLine
  pairs <- replicateM m $ readPair <$> S.getLine
  let !edges = fmap (U.fromList . ($[])) $
        IM.fromListWith (.) $ map (second (:)) $
          pairs ++ map swap pairs
  return Graph{ gV=n, gE=V.fromList $ map (\i -> IM.findWithDefault U.empty i edges) [0..n-1]}

readPair :: S.ByteString -> (Int, Int)
readPair ln = 
    let ![from, to] = map readInt $ S.words ln
    in (from, to)

readInt :: S.ByteString -> Int
readInt s = case S.readInt s of
  Just (r, "") -> r
  _ -> error $ "not an integer: " ++ show s

Submission Info

Judge Result