Submission #44235183 - AtCoder Beginner Contest 180

Contest Duration: 2020-10-17 20:00:00+0900 - 2020-10-17 21:40:00+0900 (local time) (100 minutes) Back to Home

Submission #44235183

Source Code Expand

#!/usr/bin/env stack
{- stack script --resolver lts-16.31 --package array --package bytestring --package containers --package extra --package hashable --package unordered-containers --package heaps --package utility-ht --package vector --package vector-th-unbox --package vector-algorithms --package primitive --package transformers --ghc-options "-D DEBUG" -}

{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-top-binds #-}

-- {{{ toy-lib: https://github.com/toyboot4e/toy-lib
{- ORMOLU_DISABLE -}
{-# LANGUAGE BangPatterns, BlockArguments, CPP, DefaultSignatures, FlexibleContexts, FlexibleInstances, InstanceSigs, LambdaCase, MultiParamTypeClasses, MultiWayIf, NamedFieldPuns, NumDecimals, NumericUnderscores, PatternGuards, QuantifiedConstraints, RankNTypes, RecordWildCards, ScopedTypeVariables, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies #-}
import Control.Applicative;import Control.Exception (assert);import Control.Monad;import Control.Monad.Fix;import Control.Monad.Primitive;import Control.Monad.ST;import Control.Monad.Trans.State.Strict;import Data.Bifunctor;import Data.Bits;import Data.Bool (bool);import Data.Char;import Data.Coerce;import Data.Either;import Data.Foldable;import Data.Function (on);import Data.Functor;import Data.Functor.Identity;import Data.IORef;import Data.List;import Data.Maybe;import Data.Ord;import Data.Proxy;import Data.STRef;import Data.Semigroup;import Data.Word;import Debug.Trace;import GHC.Exts;import GHC.Float (int2Float);import System.Exit (exitSuccess);import System.IO;import Text.Printf;import qualified Data.Ratio as Ratio;import Data.Array.IArray;import Data.Array.IO;import Data.Array.MArray;import Data.Array.ST;import Data.Array.Unboxed (UArray);import Data.Array.Unsafe;import qualified Data.Array as A;import qualified Data.ByteString.Builder as BSB;import qualified Data.ByteString.Char8 as BS;import Control.Monad.Extra hiding (loop);import Data.IORef.Extra;import Data.List.Extra hiding (merge);import Data.Tuple.Extra hiding (first, second);import Numeric.Extra;import Data.Bool.HT;import qualified Data.Ix.Enum as HT;import qualified Data.List.HT as HT;import qualified Data.Vector.Fusion.Bundle as VFB;import qualified Data.Vector.Generic as VG;import qualified Data.Vector.Generic.Mutable as VGM;import qualified Data.Vector.Unboxed as VU;import qualified Data.Vector.Unboxed.Mutable as VUM;import qualified Data.Vector as V;import qualified Data.Vector.Mutable as VM;import qualified Data.Vector.Fusion.Bundle.Monadic as MB;import qualified Data.Vector.Fusion.Bundle.Size as MB;import qualified Data.Vector.Fusion.Stream.Monadic as MS;import qualified Data.Vector.Algorithms.Intro as VAI;import qualified Data.Vector.Algorithms.Search as VAS;import Data.Vector.Unboxed.Deriving (derivingUnbox);import qualified Data.Graph as G;import qualified Data.IntMap.Strict as IM;import qualified Data.Map.Strict as M;import qualified Data.IntSet as IS;import qualified Data.Set as S;import qualified Data.Sequence as Seq;import qualified Data.Heap as H;import Data.Hashable;import qualified Data.HashMap.Strict as HM;import qualified Data.HashSet as HS

#ifdef DEBUG
dbg :: Show a => a -> () ; dbg !x = let !_ = traceShow x () in () ; dbgAssert :: Bool -> String -> () ; dbgAssert False !s = error $ "assertion failed!: " ++ s ; dbgAssert True _ = () ; dbgS :: String -> () ; dbgS !s = let !_ = trace s () in () ;
#else
dbg :: Show a => a -> () ; dbg _ = () ; dbgAssert :: Bool -> a -> a ; dbgAssert = flip const ; dbgS :: String -> () ; dbgS _ = () ;
#endif

type SparseUnionFind = IM.IntMap Int;newSUF :: SparseUnionFind;newSUF = IM.empty;fromListSUF :: [(Int, Int)] -> SparseUnionFind;fromListSUF = foldl' (uncurry . uniteSUF) newSUF;rootSUF :: SparseUnionFind -> Int -> (Int, Int);rootSUF !uf !i | IM.notMember i uf = (i, 1) | j < 0 = (i, -j) | otherwise = rootSUF uf j where { j = uf IM.! i};sameSUF :: SparseUnionFind -> Int -> Int -> Bool;sameSUF !uf !i !j = fst (rootSUF uf i) == fst (rootSUF uf j);uniteSUF :: SparseUnionFind -> Int -> Int -> SparseUnionFind;uniteSUF !uf !i !j | a == b = uf | r >= s = IM.insert a (negate $! r + s) $ IM.insert b a uf | otherwise = IM.insert b (negate $! r + s) $ IM.insert a b uf where { (!a, !r) = rootSUF uf i; (!b, !s) = rootSUF uf j};newtype MUnionFind s = MUnionFind (VUM.MVector s MUFNode);type IOUnionFind = MUnionFind RealWorld;type STUnionFind s = MUnionFind s;data MUFNode = MUFChild {-# UNPACK #-} !Int | MUFRoot {-# UNPACK #-} !Int;derivingUnbox "MUFNode" [t| MUFNode -> (Bool, Int) |] [| \case { (MUFChild !x) -> (True, x); (MUFRoot !x) -> (False, x)} |] [| \case { (True, !x) -> MUFChild x; (False, !x) -> MUFRoot x} |];{-# INLINE newMUF #-};newMUF :: (PrimMonad m) => Int -> m (MUnionFind (PrimState m));newMUF !n = MUnionFind <$> VUM.replicate n (MUFRoot 1);{-# INLINE rootMUF #-};rootMUF :: (PrimMonad m) => MUnionFind (PrimState m) -> Int -> m Int;rootMUF uf@(MUnionFind !vec) i = do { !node <- VUM.unsafeRead vec i; case node of { MUFRoot _ -> return i; MUFChild p -> do { !r <- rootMUF uf p; VUM.unsafeWrite vec i (MUFChild r); return r}}};{-# INLINE groupsMUF #-};groupsMUF :: (PrimMonad m) => MUnionFind (PrimState m) -> m IS.IntSet;groupsMUF uf@(MUnionFind !vec) = foldM step IS.empty [0 .. pred (VGM.length vec)] where { step !is !i = do { !root <- rootMUF uf i; return $ IS.insert root is}};{-# INLINE sameMUF #-};sameMUF :: (PrimMonad m) => MUnionFind (PrimState m) -> Int -> Int -> m Bool;sameMUF !uf !x !y = liftM2 (==) (rootMUF uf x) (rootMUF uf y);_unwrapMUFRoot :: MUFNode -> Int;_unwrapMUFRoot (MUFRoot !s) = s; _unwrapMUFRoot (MUFChild !_) = error "tried to unwrap child as UF root";{-# INLINE uniteMUF #-};uniteMUF :: (PrimMonad m) => MUnionFind (PrimState m) -> Int -> Int -> m ();uniteMUF uf@(MUnionFind !vec) !x !y = do { !px <- rootMUF uf x; !py <- rootMUF uf y; when (px /= py) $ do { !sx <- _unwrapMUFRoot <$> VUM.unsafeRead vec px; !sy <- _unwrapMUFRoot <$> VUM.unsafeRead vec py; let { (!par, !chld) = if sx < sy then (px, py) else (py, px)}; VUM.unsafeWrite vec chld (MUFChild par); VUM.unsafeWrite vec par (MUFRoot $! sx + sy)}};{-# INLINE sizeMUF #-};sizeMUF :: (PrimMonad m) => MUnionFind (PrimState m) -> Int -> m Int;sizeMUF uf@(MUnionFind !vec) !x = do { !px <- rootMUF uf x; _unwrapMUFRoot <$> VUM.unsafeRead vec px};data SegmentTree v s a = SegmentTree (a -> a -> a) (v s a);{-# INLINE newSTreeVG #-};newSTreeVG :: (VGM.MVector v a, PrimMonad m) => (a -> a -> a) -> Int -> a -> m (SegmentTree v (PrimState m) a);newSTreeVG !f !n !zero = SegmentTree f <$> VGM.replicate n' zero where { !n' = until (>= 2 * n) (* 2) 2};{-# INLINE newSTreeV #-};newSTreeV :: PrimMonad m => (a -> a -> a) -> Int -> a -> m (SegmentTree VM.MVector (PrimState m) a);newSTreeV = newSTreeVG;{-# INLINE newSTreeVU #-};newSTreeVU :: (VU.Unbox a, PrimMonad m) => (a -> a -> a) -> Int -> a -> m (SegmentTree VUM.MVector (PrimState m) a);newSTreeVU = newSTreeVG;resetSTree :: (VGM.MVector v a, PrimMonad m) => (SegmentTree v (PrimState m) a) -> a -> m ();resetSTree (SegmentTree !_ !vec) !zero = VGM.set vec zero;{-# INLINE insertSTree #-};insertSTree :: (VGM.MVector v a, PrimMonad m) => SegmentTree v (PrimState m) a -> Int -> a -> m ();insertSTree tree@(SegmentTree !_ !vec) !i !value = _updateElement tree i' value where { !offset = VGM.length vec `div` 2 - 1; !i' = i + offset};{-# INLINE modifySTree #-};modifySTree :: (VGM.MVector v a, PrimMonad m) => SegmentTree v (PrimState m) a -> (a -> a) -> Int -> m ();modifySTree tree@(SegmentTree !_ !vec) !f !i = do { !v <- f <$> VGM.unsafeRead vec i'; _updateElement tree i' v} where { !offset = VGM.length vec `div` 2 - 1; !i' = i + offset};_updateElement :: (VGM.MVector v a, PrimMonad m) => SegmentTree v (PrimState m) a -> Int -> a -> m ();_updateElement (SegmentTree !_ !vec) 0 !value = do { VGM.unsafeWrite vec 0 value}; _updateElement tree@(SegmentTree !f !vec) !i !value = do { VGM.unsafeWrite vec i value; case ((i - 1) `div` 2) of { (-1) -> return (); !iParent -> do { !c1 <- VGM.unsafeRead vec $! iParent * 2 + 1; !c2 <- VGM.unsafeRead vec $! iParent * 2 + 2; _updateElement tree iParent $! f c1 c2}}};{-# INLINE querySTree #-};querySTree :: forall v a m . (VGM.MVector v a, PrimMonad m) => SegmentTree v (PrimState m) a -> (Int, Int) -> m (Maybe a);querySTree (SegmentTree !f !vec) (!lo, !hi) | lo > hi = return Nothing | otherwise = inner 0 (0, initialHi) where { !initialHi = VGM.length vec `div` 2 - 1; inner :: Int -> (Int, Int) -> m (Maybe a); inner !i (!l, !h) | lo <= l && h <= hi = Just <$> VGM.unsafeRead vec i | h < lo || hi < l = return Nothing | otherwise = do { let { !d = (h - l) `div` 2}; !ansL <- inner (2 * i + 1) (l, l + d); !ansH <- inner (2 * i + 2) (l + d + 1, h); pure . Just $ case (ansL, ansH) of { (Just !a, Just !b) -> f a b; (Just !a, _) -> a; (_, Just !b) -> b; (_, _) -> error $ "query error (segment tree): " ++ show (i, (l, h), (lo, hi))}}};topSort :: Array Int [Int] -> [Int];topSort !graph = runST $ do { let { !bounds_ = bounds graph}; !vis <- VUM.replicate (succ $ rangeSize bounds_) False; let { dfsM !acc !v = do { !b <- VUM.unsafeRead vis (index bounds_ v); if b then return acc else do { VUM.unsafeWrite vis (index bounds_ v) True; !vs <- filterM (fmap not . VUM.unsafeRead vis . index bounds_) $ graph ! v; (v :) <$> foldM dfsM acc vs}}}; foldM dfsM [] $ range bounds_};topScc1 :: forall m . (PrimMonad m) => Array Int [Int] -> VUM.MVector (PrimState m) Bool -> Int -> m [Int];topScc1 !graph' !vis !v0 = do { let { !bounds_ = bounds graph'}; let { dfsM !acc !v = do { !b <- VUM.unsafeRead vis (index bounds_ v); if b then return acc else do { VUM.unsafeWrite vis (index bounds_ v) True; !vs <- filterM (fmap not . VUM.unsafeRead vis . index bounds_) $ graph' ! v; (v :) <$> foldM dfsM acc vs}}}; dfsM [] v0};revGraph :: Array Int [Int] -> Array Int [Int];revGraph graph = accumArray (flip (:)) [] (bounds graph) input where { input :: [(Int, Int)]; input = foldl' (\ !acc (!v2, !v1s) -> foldl' (\ !acc' !v1 -> (v1, v2) : acc') acc v1s) [] $ assocs graph};topScc :: Array Int [Int] -> [[Int]];topScc graph = collectSccPreorder $ topSort graph where { graph' = revGraph graph; collectSccPreorder :: [Int] -> [[Int]]; collectSccPreorder !topVerts = runST $ do { let { !bounds_ = bounds graph'}; !vis <- VUM.replicate (succ $ rangeSize bounds_) False; filter (not . null) <$> mapM (topScc1 graph' vis) topVerts}};topSccCycles :: Array Int [Int] -> [[Int]];topSccCycles graph = filter f $ topScc graph where { f [!v] = [v] == graph ! v; f !_ = True};downScc :: Array Int [Int] -> [[Int]];downScc = reverse . map reverse . topScc;data IxVector i v = IxVector{boundsIV :: !(i, i), vecIV :: !v} deriving (Show, Eq);(@!) :: (Ix i, VG.Vector v a) => IxVector i (v a) -> i -> a;(@!) IxVector{..} i = vecIV VG.! index boundsIV i;(@!?) :: (Ix i, VG.Vector v a) => IxVector i (v a) -> i -> Maybe a;(@!?) IxVector{..} i | inRange boundsIV i = Just (vecIV VG.! (index boundsIV i)) | otherwise = Nothing;{-# INLINE readIV #-};readIV :: (Ix i, PrimMonad m, VGM.MVector v a) => IxVector i (v (PrimState m) a) -> i -> m a;readIV IxVector{..} i = VGM.read vecIV (index boundsIV i);{-# INLINE writeIV #-};writeIV :: (Ix i, PrimMonad m, VGM.MVector v a) => IxVector i (v (PrimState m) a) -> i -> a -> m ();writeIV IxVector{..} i a = VGM.write vecIV (index boundsIV i) a;{-# INLINE modifyIV #-};modifyIV :: (Ix i, PrimMonad m, VGM.MVector v a) => IxVector i (v (PrimState m) a) -> (a -> a) -> i -> m ();modifyIV IxVector{..} !alter i = VGM.modify vecIV alter (index boundsIV i);{-# INLINE swapIV #-};swapIV :: (Ix i, PrimMonad m, VGM.MVector v a) => IxVector i (v (PrimState m) a) -> i -> i -> m ();swapIV IxVector{..} !i1 !i2 = VGM.swap vecIV (index boundsIV i1) (index boundsIV i2);imos2DIV :: IxVector (Int, Int) (VU.Vector Int) -> IxVector (Int, Int) (VU.Vector Int);imos2DIV !seeds@IxVector{boundsIV} = IxVector boundsIV $ VU.create $ do { !vec <- IxVector boundsIV <$> VU.thaw (vecIV seeds); let { (!minY, !minX) = fst boundsIV}; forM_ (range boundsIV) $ \ (!y, !x) -> do { !v <- if x == minX then return 0 else readIV vec (y, x - 1); modifyIV vec (+ v) (y, x)}; forM_ (range boundsIV) $ \ (!x, !y) -> do { !v <- if y == minY then return 0 else readIV vec (y - 1, x); modifyIV vec (+ v) (y, x)}; return $ vecIV vec};class SemigroupAction s a where { sact :: s -> a -> a};class (SemigroupAction m a, Monoid m) => MonoidAction m a where { mact :: m -> a -> a; mact = sact};instance SemigroupAction (Product Int) Int where { sact (Product !x1) !x2 = x1 * x2};newtype Permutation = Permutation (VU.Vector Int) deriving (Show, Eq);instance Semigroup Permutation where { (Permutation vec1) <> (Permutation vec2) = Permutation $! VU.map (vec1 VU.!) vec2 where { !_ = dbgAssert (VG.length vec1 == VG.length vec2)}};instance SemigroupAction Permutation Int where { sact (Permutation !vec) !i = vec VU.! i};powersetM_ :: (Bits a, Num a, Monad m) => a -> (a -> m ()) -> m ();powersetM_ !is0 !act = act2 is0 where { act2 !is = do { act is; unless (is == 0) (act2 (is0 .&. (is - 1)))}};powerset :: (Bits a, Num a) => a -> [a];powerset !a = a : unfoldr f a where { f 0 = Nothing; f !x = Just . dupe $! a .&. (x - 1)};powersetVU :: (Bits a, Num a, VU.Unbox a) => a -> VU.Vector a;powersetVU !a = VU.unfoldr f a where { f (-1) = Nothing; f 0 = Just (0, -1); f !x = let { !x' = a .&. (x - 1)} in Just (x, x')};type MultiSet = (Int, IM.IntMap Int);emptyMS :: MultiSet;emptyMS = (0, IM.empty);singletonMS :: Int -> MultiSet;singletonMS !x = (1, IM.singleton x 1);fromListMS :: [Int] -> MultiSet;fromListMS = foldl' (flip incMS) emptyMS;incMS :: Int -> MultiSet -> MultiSet;incMS !k (!n, !im) = if IM.member k im then (n, IM.insertWith (+) k 1 im) else (n + 1, IM.insert k 1 im);decMS :: Int -> MultiSet -> MultiSet;decMS !k (!n, !im) = case IM.lookup k im of { Just 1 -> (n - 1, IM.delete k im); Just _ -> (n, IM.insertWith (+) k (-1) im); Nothing -> (n, im)};memberMS :: Int -> MultiSet -> Bool;memberMS !k (!_, !im) = IM.member k im;notMemberMS :: Int -> MultiSet -> Bool;notMemberMS !k (!_, !im) = IM.notMember k im;deleteFindMinMS :: MultiSet -> (Int, MultiSet);deleteFindMinMS ms@(!_, !im) = let { !key = fst $ IM.findMin im} in (key, decMS key ms);innerMS :: MultiSet -> IM.IntMap Int;innerMS (!_, !im) = im;data Buffer s a = Buffer{bufferVars :: !(VUM.MVector s Int), internalBuffer :: !(VUM.MVector s a), internalBufferSize :: !Int};_bufferFrontPos :: Int;_bufferFrontPos = 0;_bufferBackPos :: Int;_bufferBackPos = 1;newBuffer :: (VU.Unbox a, PrimMonad m) => Int -> m (Buffer (PrimState m) a);newBuffer n = Buffer <$> VUM.replicate 2 0 <*> VUM.unsafeNew n <*> pure n;type Stack s a = Buffer s a;newBufferAsStack :: (VU.Unbox a, PrimMonad m) => Int -> m (Buffer (PrimState m) a);newBufferAsStack n = Buffer <$> VUM.replicate 2 0 <*> VUM.unsafeNew n <*> pure n;type Queue s a = Buffer s a;newBufferAsQueue :: (VU.Unbox a, PrimMonad m) => Int -> m (Buffer (PrimState m) a);newBufferAsQueue n = Buffer <$> VUM.replicate 2 0 <*> VUM.unsafeNew n <*> pure n;type Deque s a = Buffer s a;newBufferAsDeque :: (VU.Unbox a, PrimMonad m) => Int -> m (Buffer (PrimState m) a);newBufferAsDeque n = Buffer <$> VUM.replicate 2 n <*> VUM.unsafeNew (2 * n) <*> pure (2 * n);lengthBuffer :: (PrimMonad m) => Buffer (PrimState m) a -> m Int;lengthBuffer Buffer{bufferVars} = liftA2 (-) (VUM.unsafeRead bufferVars _bufferBackPos) (VUM.unsafeRead bufferVars _bufferFrontPos);{-# INLINE lengthBuffer #-};clearBuffer :: (PrimMonad m) => Buffer (PrimState m) a -> m ();clearBuffer Buffer{bufferVars} = do { VUM.unsafeWrite bufferVars _bufferFrontPos 0; VUM.unsafeWrite bufferVars _bufferBackPos 0};freezeBuffer :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (VU.Vector a);freezeBuffer Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; b <- VUM.unsafeRead bufferVars _bufferBackPos; VU.freeze $ VUM.unsafeSlice f (b - f) internalBuffer};unsafeFreezeBuffer :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (VU.Vector a);unsafeFreezeBuffer Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; b <- VUM.unsafeRead bufferVars _bufferBackPos; VU.unsafeFreeze $ VUM.unsafeSlice f (b - f) internalBuffer};freezeInternalBuffer :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (VU.Vector a);freezeInternalBuffer Buffer{bufferVars, internalBuffer} = do { b <- VUM.unsafeRead bufferVars _bufferBackPos; VU.freeze $ VUM.unsafeSlice 0 b internalBuffer};unsafeFreezeInternalBuffer :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (VU.Vector a);unsafeFreezeInternalBuffer Buffer{bufferVars, internalBuffer} = do { b <- VUM.unsafeRead bufferVars _bufferBackPos; VU.unsafeFreeze $ VUM.unsafeSlice 0 b internalBuffer};popFront :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (Maybe a);popFront Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; b <- VUM.unsafeRead bufferVars _bufferBackPos; if f < b then do { VUM.unsafeWrite bufferVars _bufferFrontPos (f + 1); pure <$> VUM.unsafeRead internalBuffer f} else return Nothing};{-# INLINE popFront #-};viewFront :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (Maybe a);viewFront Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; b <- VUM.unsafeRead bufferVars _bufferBackPos; if f < b then pure <$> VUM.unsafeRead internalBuffer f else return Nothing};{-# INLINE viewFront #-};popBack :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (Maybe a);popBack Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; b <- VUM.unsafeRead bufferVars _bufferBackPos; if f < b then do { VUM.unsafeWrite bufferVars _bufferBackPos (b - 1); pure <$> VUM.unsafeRead internalBuffer (b - 1)} else return Nothing};{-# INLINE popBack #-};viewBack :: (VU.Unbox a, PrimMonad m) => Buffer (PrimState m) a -> m (Maybe a);viewBack Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; b <- VUM.unsafeRead bufferVars _bufferBackPos; if f < b then pure <$> VUM.unsafeRead internalBuffer (b - 1) else return Nothing};{-# INLINE viewBack #-};pushFront :: (VU.Unbox a, PrimMonad m) => a -> Buffer (PrimState m) a -> m ();pushFront x Buffer{bufferVars, internalBuffer} = do { f <- VUM.unsafeRead bufferVars _bufferFrontPos; VUM.unsafeWrite bufferVars _bufferFrontPos (f - 1); assert (f > 0) $ do { VUM.unsafeWrite internalBuffer (f - 1) x}};{-# INLINE pushFront #-};pushBack :: (VU.Unbox a, PrimMonad m) => a -> Buffer (PrimState m) a -> m ();pushBack x Buffer{bufferVars, internalBuffer, internalBufferSize} = do { b <- VUM.unsafeRead bufferVars _bufferBackPos; VUM.unsafeWrite bufferVars _bufferBackPos (b + 1); assert (b < internalBufferSize) $ do { VUM.unsafeWrite internalBuffer b x}};{-# INLINE pushBack #-};pushFronts :: (VU.Unbox a, PrimMonad m) => VU.Vector a -> Buffer (PrimState m) a -> m ();pushFronts vec Buffer{bufferVars, internalBuffer} = do { let { n = VU.length vec}; f <- VUM.unsafeRead bufferVars _bufferFrontPos; VUM.unsafeWrite bufferVars _bufferFrontPos (f - n); assert (n <= f) $ do { VU.unsafeCopy (VUM.unsafeSlice (f - n) n internalBuffer) vec}};{-# INLINE pushFronts #-};pushBacks :: (VU.Unbox a, PrimMonad m) => VU.Vector a -> Buffer (PrimState m) a -> m ();pushBacks vec Buffer{bufferVars, internalBuffer, internalBufferSize} = do { let { n = VU.length vec}; b <- VUM.unsafeRead bufferVars _bufferBackPos; VUM.unsafeWrite bufferVars _bufferBackPos (b + n); assert (b + n - 1 < internalBufferSize) $ do { VU.unsafeCopy (VUM.unsafeSlice b n internalBuffer) vec}};{-# INLINE pushBacks #-};class ShowGrid a where { showGrid :: a -> String};instance (VG.Vector v a, Show a) => ShowGrid (IxVector (Int, Int) (v a)) where { showGrid !grid = unlines $ map f [y0 .. y1] where { ((!y0, !x0), (!y1, !x1)) = boundsIV grid; f !y = unwords $ map (show . (grid @!) . (y,)) [x0 .. x1]}};clamp :: (Ord a) => (a, a) -> a -> a;clamp (!low, !high) !a = min high (max a low);flipOrder :: Ordering -> Ordering;flipOrder = \case { GT -> LT; LT -> GT; EQ -> EQ};square :: Num a => a -> a;square !x = x * x;chunks :: Int -> [a] -> [[a]];chunks n = inner where { inner [] = []; inner xs = let { (!g, !rest) = splitAt n xs} in g : inner rest};(.:) :: (b -> c) -> (a1 -> a2 -> b) -> (a1 -> a2 -> c);(.:) = (.) . (.);(.:.) :: (b -> c) -> (a1 -> a2 -> a3 -> b) -> (a1 -> a2 -> a3 -> c);(.:.) = (.) . (.) . (.);{-# INLINE (.!) #-};(.!) :: (b -> c) -> (a -> b) -> a -> c;(.!) = (.) . ($!);infixr 9 .!;foldFor :: (Foldable t) => b -> t a -> (b -> a -> b) -> b;foldFor !s0 !xs !f = foldl' f s0 xs;foldForVG :: (VG.Vector v a) => b -> v a -> (b -> a -> b) -> b;foldForVG !s0 !xs !f = VG.foldl' f s0 xs;foldForM :: (Foldable t, Monad m) => b -> t a -> (b -> a -> m b) -> m b;foldForM !s0 !xs !m = foldM m s0 xs;foldForMVG :: (PrimMonad m, VG.Vector v a) => b -> v a -> (b -> a -> m b) -> m b;foldForMVG !s0 !xs !m = VG.foldM' m s0 xs;foldForMMS :: Monad m => a -> MS.Stream m b -> (a -> b -> m a) -> m a;foldForMMS !s0 !xs !f = MS.foldM' f s0 xs;minimumOr :: (Ord a, VU.Unbox a) => a -> VU.Vector a -> a;minimumOr !orValue !xs = if VU.null xs then orValue else VU.minimum xs;maximumOr :: (Ord a, VU.Unbox a) => a -> VU.Vector a -> a;maximumOr !orValue !xs = if VU.null xs then orValue else VU.maximum xs;{-# INLINE unconsVG #-};unconsVG :: VG.Vector v a => v a -> Maybe (a, v a);unconsVG v | VG.null v = Nothing | otherwise = Just (VG.unsafeHead v, VG.unsafeTail v);{-# INLINE groupByVG #-};groupByVG :: (VG.Vector v a) => (a -> a -> Bool) -> v a -> [v a];groupByVG _ !v | VG.null v = []; groupByVG !f !v = let { !h = VG.unsafeHead v; !tl = VG.unsafeTail v} in case VG.findIndex (not . f h) tl of { Nothing -> [v]; Just !n -> VG.unsafeTake (n + 1) v : groupByVG f (VG.unsafeDrop (n + 1) v)};{-# INLINE groupVG #-};groupVG :: (VG.Vector v a, Eq a) => v a -> [v a];groupVG = groupByVG (==);safeHead :: (VU.Unbox a) => VU.Vector a -> Maybe a;safeHead vec = if VU.null vec then Nothing else Just $! VU.head vec;safeLast :: (VU.Unbox a) => VU.Vector a -> Maybe a;safeLast vec = if VU.null vec then Nothing else Just $! VU.last vec;{-# INLINE modifyArray #-};modifyArray :: (MArray a e m, Ix i) => a i e -> (e -> e) -> i -> m ();modifyArray !ary !f !i = do { !v <- f <$> readArray ary i; writeArray ary i v};{-# INLINE vLength #-};vLength :: (VG.Vector v e) => v e -> Int;vLength = VFB.length . VG.stream;{-# INLINE rangeVG #-};rangeVG :: (VG.Vector v Int) => Int -> Int -> v Int;rangeVG !i !j = VG.enumFromN i (succ j - i);{-# INLINE rangeV #-};rangeV :: Int -> Int -> V.Vector Int;rangeV = rangeVG;{-# INLINE rangeVU #-};rangeVU :: Int -> Int -> VU.Vector Int;rangeVU = rangeVG;{-# INLINE rangeVGR #-};rangeVGR :: (VG.Vector v Int) => Int -> Int -> v Int;rangeVGR !i !j = VG.enumFromStepN (pred j) (-1) (succ j - i);{-# INLINE rangeVR #-};rangeVR :: Int -> Int -> V.Vector Int;rangeVR = rangeVGR;{-# INLINE rangeVUR #-};rangeVUR :: Int -> Int -> VU.Vector Int;rangeVUR = rangeVGR;{-# INLINE [1] rangeMS #-};rangeMS :: (Monad m) => Int -> Int -> MS.Stream m Int;rangeMS !l !r = MS.Stream step l where { {-# INLINE [0] step #-}; step x | x <= r = return $ MS.Yield x (x + 1) | otherwise = return MS.Done};{-# INLINE [1] rangeMSR #-};rangeMSR :: (Monad m) => Int -> Int -> MS.Stream m Int;rangeMSR !l !r = MS.Stream step r where { {-# INLINE [0] step #-}; step x | x >= l = return $ MS.Yield x (x - 1) | otherwise = return MS.Done};{-# INLINE forMS_ #-};forMS_ :: (Monad m) => MS.Stream m Int -> (Int -> m ()) -> m ();forMS_ = flip MS.mapM_;{-# INLINE repM_ #-};repM_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ();repM_ !l !r !act = inner l where { inner !i | i > r = return () | otherwise = act i >> inner (succ i)};{-# INLINE repRM_ #-};repRM_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ();repRM_ !l !r !act = inner r where { inner !i | i < l = return () | otherwise = act i >> inner (pred i)};constructN0 :: (VU.Unbox a) => a -> Int -> (VU.Vector a -> a) -> VU.Vector a;constructN0 !x0 !n !f = VU.constructN n $ \ vec -> if VU.null vec then x0 else f vec;compress :: Eq a => [a] -> [a];compress [] = []; compress (x : xs) = x : compress (dropWhile (== x) xs);{-# INLINE times #-};times :: Int -> (a -> a) -> a -> a;times !n !f !s0 = snd $! until ((== n) . fst) (bimap succ f) (0 :: Int, s0);combs :: Int -> [a] -> [[a]];combs _ [] = error "given empty list"; combs k as@(!(x : xs)) | k == 0 = [[]] | k == 1 = map pure as | k == l = pure as | k > l = [] | otherwise = run (l - 1) (k - 1) as $ combs (k - 1) xs where { l = length as; run :: Int -> Int -> [a] -> [[a]] -> [[a]]; run n k ys cs | n == k = map (ys ++) cs | otherwise = map (q :) cs ++ run (n - 1) k qs (drop dc cs) where { (!(q : qs)) = take (n - k + 1) ys; dc = product [(n - k + 1) .. (n - 1)] `div` product [1 .. (k - 1)]}};twoPointers :: Int -> ((Int, Int) -> Bool) -> [(Int, Int)];twoPointers !n !check = inner (0, 0) where { inner (!l, !_) | l >= n = []; inner (!l, !r) | check (l, r) = let { (!l', !r') = until (not . peekCheck) (second succ) (l, r)} in (l', r') : inner (succ l', max l' r') | otherwise = inner (succ l, max (succ l) r); peekCheck (!_, !r) | r == pred n = False; peekCheck (!l, !r) = check (l, succ r)};tuple2 :: [a] -> (a, a);tuple2 [!a1, !a2] = (a1, a2); tuple2 _ = error "not a two-item list";tuple3 :: [a] -> (a, a, a);tuple3 [!a1, !a2, !a3] = (a1, a2, a3); tuple3 _ = error "not a three-item list";tuple4 :: [a] -> (a, a, a, a);tuple4 [!a1, !a2, !a3, !a4] = (a1, a2, a3, a4); tuple4 _ = error "not a four-item list";tuple5 :: [a] -> (a, a, a, a, a);tuple5 [!a1, !a2, !a3, !a4, !a5] = (a1, a2, a3, a4, a5); tuple5 _ = error "not a five-item list";tuple6 :: [a] -> (a, a, a, a, a, a);tuple6 [!a1, !a2, !a3, !a4, !a5, !a6] = (a1, a2, a3, a4, a5, a6); tuple6 _ = error "not a six-item list";ints2 :: IO (Int, Int);ints2 = tuple2 <$> ints;ints3 :: IO (Int, Int, Int);ints3 = tuple3 <$> ints;ints4 :: IO (Int, Int, Int, Int);ints4 = tuple4 <$> ints;ints5 :: IO (Int, Int, Int, Int, Int);ints5 = tuple5 <$> ints;ints6 :: IO (Int, Int, Int, Int, Int, Int);ints6 = tuple6 <$> ints;yn :: Bool -> String;yn b = if b then "Yes" else "No";printYn :: Bool -> IO ();printYn = putStrLn . yn;concat2 :: [(a, a)] -> [a];concat2 [] = []; concat2 ((!x, !y) : xys) = x : y : concat2 xys;concatMap2 :: (a -> (b, b)) -> [a] -> [b];concatMap2 !f = concat2 . map f;swapDupe :: (a, a) -> ((a, a), (a, a));swapDupe = second swap . dupe;add2 :: (Int, Int) -> (Int, Int) -> (Int, Int);add2 (!y, !x) = bimap (y +) (x +);sub2 :: (Int, Int) -> (Int, Int) -> (Int, Int);sub2 (!y, !x) = bimap (y -) (x -);mul2 :: Int -> (Int, Int) -> (Int, Int);mul2 !m = both (m *);add3 :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int);add3 (!z1, !y1, !x1) (!z2, !y2, !x2) = (z1 + z2, y1 + y2, x1 + x2);sub3 :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int);sub3 (!z1, !y1, !x1) (!z2, !y2, !x2) = (z1 - z2, y1 - y2, x1 - x2);mul3 :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int);mul3 (!z1, !y1, !x1) (!z2, !y2, !x2) = (z1 - z2, y1 - y2, x1 - x2);toRadian :: Double -> Double;toRadian degree = degree / 180.0 * pi;toDegree :: Double -> Double;toDegree rad = rad / pi * 180.0;fst4 :: (a, b, c, d) -> a;fst4 (!a, !_, !_, !_) = a;snd4 :: (a, b, c, d) -> b;snd4 (!_, !b, !_, !_) = b;thd4 :: (a, b, c, d) -> c;thd4 (!_, !_, !c, !_) = c;fth4 :: (a, b, c, d) -> d;fth4 (!_, !_, !_, !d) = d;int :: IO Int;int = readLn;ints :: IO [Int];ints = unfoldr (BS.readInt . BS.dropWhile isSpace) <$> BS.getLine;intsVG :: VG.Vector v Int => IO (v Int);intsVG = VG.unfoldr (BS.readInt . BS.dropWhile isSpace) <$> BS.getLine;intsV :: IO (V.Vector Int);intsV = intsVG;intsVU :: IO (VU.Vector Int);intsVU = intsVG;digitsVU :: IO (VU.Vector Int);digitsVU = VU.unfoldr (fmap (first digitToInt) . BS.uncons) <$> BS.getLine;intsN :: Int -> IO [Int];intsN n = concat <$> replicateM n ints;intsNVU :: Int -> IO (VU.Vector Int);intsNVU n = VU.fromList . concat <$> replicateM n ints;intsGrid :: Int -> Int -> IO (IxVector (Int, Int) (VU.Vector Int));intsGrid h w = IxVector ((0, 0), (h - 1, w - 1)) <$> intsNVU h;intsRestVG :: VG.Vector v Int => IO (v Int);intsRestVG = VG.unfoldr (BS.readInt . BS.dropWhile isSpace) <$> BS.getContents;intsRestVU :: IO (VU.Vector Int);intsRestVU = intsRestVG;getGraph :: Int -> Int -> IO (Array Int [Int]);getGraph !nVerts !nEdges = accGraph . toInput <$> replicateM nEdges ints where { accGraph = accumArray @Array (flip (:)) [] (1, nVerts); toInput = concatMap2 $ second swap . dupe . tuple2};getWGraph :: Int -> Int -> IO (Array Int [H.Entry Int Int]);getWGraph !nVerts !nEdges = accGraph . toInput <$> replicateM nEdges ints where { accGraph = accumArray @Array (flip (:)) [] (1, nVerts); toInput = concatMap2 $ \ [!a, !b, !cost] -> ((a, H.Entry cost b), (b, H.Entry cost a))};getWGraph0 :: Int -> Int -> IO (Array Int [H.Entry Int Int]);getWGraph0 !nVerts !nEdges = accGraph . toInput <$> replicateM nEdges ints where { accGraph = accumArray @Array (flip (:)) [] (0, pred nVerts); toInput = concatMap2 $ \ [!a, !b, !cost] -> ((pred a, H.Entry cost (pred b)), (pred b, H.Entry cost (pred a)))};{-# INLINE endlBSB #-};endlBSB :: BSB.Builder;endlBSB = BSB.char7 '\n';putBSB :: BSB.Builder -> IO ();putBSB = BSB.hPutBuilder stdout;putLnBSB :: BSB.Builder -> IO ();putLnBSB = BSB.hPutBuilder stdout . (<> endlBSB);class ShowBSB a where { showBSB :: a -> BSB.Builder; default showBSB :: (Show a) => a -> BSB.Builder; showBSB = BSB.string8 . show};instance ShowBSB Int where { showBSB = BSB.intDec};instance ShowBSB Integer where { showBSB = BSB.integerDec};instance ShowBSB Float where { showBSB = BSB.floatDec};instance ShowBSB Double where { showBSB = BSB.doubleDec};showLnBSB :: ShowBSB a => a -> BSB.Builder;showLnBSB = (<> endlBSB) . showBSB;printBSB :: ShowBSB a => a -> IO ();printBSB = putBSB . showBSB;concatBSB :: (VG.Vector v a) => (a -> BSB.Builder) -> v a -> BSB.Builder;concatBSB f = VG.foldr' ((<>) . f) mempty;unwordsBSB :: (ShowBSB a, VG.Vector v a) => v a -> BSB.Builder;unwordsBSB = concatBSB ((<> BSB.string7 " ") . showBSB);unlinesBSB :: (ShowBSB a, VG.Vector v a) => v a -> BSB.Builder;unlinesBSB = concatBSB showLnBSB;traceMat2D :: (IArray a e, Ix i, Show e) => a (i, i) e -> ();traceMat2D !mat = traceSubMat2D mat (bounds mat);traceSubMat2D :: (IArray a e, Ix i, Show e) => a (i, i) e -> ((i, i), (i, i)) -> ();traceSubMat2D !mat ((!y0, !x0), (!yEnd, !xEnd)) = let { !_ = foldl' step () (range ys)} in () where { !xs = (y0, yEnd); !ys = (x0, xEnd); step !_ !y = traceShow (map (\ !x -> mat ! (y, x)) (range xs)) ()};isqrt :: Int -> Int;isqrt = round @Double . sqrt . fromIntegral;data LazySegmentTree v a op s = LazySegmentTree !(v s a) !(VUM.MVector s op) !Int;newLazySTree :: forall v a op m . (VGM.MVector v a, Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => Int -> m (LazySegmentTree v a op (PrimState m));newLazySTree !n = do { !as <- VGM.replicate n2 mempty; !ops <- VUM.replicate n2 mempty; return $ LazySegmentTree as ops h} where { (!h, !n2) = until ((>= 2 * n) . snd) (bimap succ (* 2)) (0 :: Int, 1 :: Int)};newLazySTreeV :: forall a op m . (Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => Int -> m (LazySegmentTree VM.MVector a op (PrimState m));newLazySTreeV = newLazySTree;newLazySTreeVU :: forall a op m . (VU.Unbox a, Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => Int -> m (LazySegmentTree VUM.MVector a op (PrimState m));newLazySTreeVU = newLazySTree;generateLazySTree :: forall v a op m . (VGM.MVector v a, Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => Int -> (Int -> a) -> m (LazySegmentTree v a op (PrimState m));generateLazySTree !n !f = do { !as <- VGM.unsafeNew n2; forMS_ (rangeMS 1 nLeaves) $ \ i -> do { VGM.write as (nLeaves + i - 1) $ f (pred i)}; forMS_ (rangeMSR 1 (pred nLeaves)) $ \ i -> do { !l <- VGM.read as (childL i); !r <- VGM.read as (childR i); VGM.write as i (l <> r)}; !ops <- VUM.replicate n2 mempty; return $ LazySegmentTree as ops h} where { (!h, !n2) = until ((>= 2 * n) . snd) (bimap succ (* 2)) (0 :: Int, 1 :: Int); !nLeaves = n2 `div` 2; childL !vertex = shiftL vertex 1; childR !vertex = shiftL vertex 1 .|. 1};generateLazySTreeV :: forall a op m . (Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => Int -> (Int -> a) -> m (LazySegmentTree VM.MVector a op (PrimState m));generateLazySTreeV = generateLazySTree;generateLazySTreeVU :: forall a op m . (VU.Unbox a, Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => Int -> (Int -> a) -> m (LazySegmentTree VUM.MVector a op (PrimState m));generateLazySTreeVU = generateLazySTree;updateLazySTree :: forall v a op m . (VGM.MVector v a, Monoid a, MonoidAction op a, Eq op, VU.Unbox op, PrimMonad m) => LazySegmentTree v a op (PrimState m) -> Int -> Int -> op -> m ();updateLazySTree stree@(LazySegmentTree !_ !ops !_) !iLLeaf !iRLeaf !op = do { _propOpMonoidsToLeaf stree iLLeaf; _propOpMonoidsToLeaf stree iRLeaf; let { !lVertex = iLLeaf + nVerts `div` 2; !rVertex = iRLeaf + nVerts `div` 2}; glitchLoopUpdate lVertex rVertex; _evalToRoot stree iLLeaf; _evalToRoot stree iRLeaf; return ()} where { !nVerts = VUM.length ops; isLeftChild = not . (`testBit` 0); isRightChild = (`testBit` 0); glitchLoopUpdate :: Int -> Int -> m (); glitchLoopUpdate !l !r | l > r = return () | otherwise = do { !l' <- if isRightChild l then do { VUM.modify ops (<> op) l; return $ succ l} else return l; !r' <- if isLeftChild r then do { VUM.modify ops (<> op) r; return $ pred r} else return r; glitchLoopUpdate (shiftR l' 1) (shiftR r' 1)}};queryLazySTree :: forall v a m op . (VGM.MVector v a, Monoid a, MonoidAction op a, Eq op, VU.Unbox op, PrimMonad m) => LazySegmentTree v a op (PrimState m) -> Int -> Int -> m a;queryLazySTree stree@(LazySegmentTree !as !ops !_) !iLLeaf !iRLeaf = do { _propOpMonoidsToLeaf stree iLLeaf; _propOpMonoidsToLeaf stree iRLeaf; let { !lVertex = iLLeaf + nVerts `div` 2; !rVertex = iRLeaf + nVerts `div` 2}; glitchLoopQuery lVertex rVertex mempty mempty} where { !nVerts = VGM.length as; isLeftChild = not . (`testBit` 0); isRightChild = (`testBit` 0); glitchLoopQuery :: Int -> Int -> a -> a -> m a; glitchLoopQuery !l !r !lAcc !rAcc | l > r = return $! lAcc <> rAcc | otherwise = do { (!l', !lAcc') <- if isRightChild l then do { !la' <- mact <$!> VUM.read ops l <*> VGM.read as l; return (succ l, lAcc <> la')} else return (l, lAcc); (!r', !rAcc') <- if isLeftChild r then do { !ra' <- mact <$!> VUM.read ops r <*> VGM.read as r; return (pred r, ra' <> rAcc)} else return (r, rAcc); glitchLoopQuery (shiftR l' 1) (shiftR r' 1) lAcc' rAcc'}};_propOpMonoidsToLeaf :: (VGM.MVector v a, MonoidAction op a, Eq op, VU.Unbox op, PrimMonad m) => LazySegmentTree v a op (PrimState m) -> Int -> m ();_propOpMonoidsToLeaf (LazySegmentTree !as !ops !height) !iLeaf = do { let { !leafVertex = iLeaf + nVerts `div` 2}; forMS_ (rangeMSR 1 (pred height)) $ \ iParent -> do { let { !vertex = nthParent leafVertex iParent}; !op <- VUM.read ops vertex; when (op /= mempty) $ do { VUM.modify ops (<> op) $! childL vertex; VUM.modify ops (<> op) $! childR vertex; VGM.modify as (mact op) vertex; VUM.write ops vertex mempty}}} where { !nVerts = VGM.length as; nthParent !leafVertex !nth = shiftR leafVertex nth; childL !vertex = shiftL vertex 1; childR !vertex = shiftL vertex 1 .|. 1};_evalToRoot :: (VGM.MVector v a, Monoid a, MonoidAction op a, VU.Unbox op, PrimMonad m) => LazySegmentTree v a op (PrimState m) -> Int -> m ();_evalToRoot (LazySegmentTree !as !ops !height) !iLeaf = do { let { !leafVertex = iLeaf + nVerts `div` 2}; forMS_ (rangeMS 1 (pred height)) $ \ iParent -> do { let { !vertex = nthParent leafVertex iParent}; let { !_ = dbgAssert (vertex > 0) "_evalToRoot"}; !aL' <- mact <$> VUM.read ops (childL vertex) <*> VGM.read as (childL vertex); !aR' <- mact <$> VUM.read ops (childR vertex) <*> VGM.read as (childR vertex); VGM.write as vertex $! aL' <> aR'}} where { !nVerts = VGM.length as; nthParent !leafVertex !nth = shiftR leafVertex nth; childL !vertex = shiftL vertex 1; childR !vertex = shiftL vertex 1 .|. 1};type Graph a = Array Int [a];type Vertex = Int;type WGraph a = Array Int [H.Entry a Vertex];bfsVec :: Graph Int -> Int -> VU.Vector Int;bfsVec graph start = VU.create $ do { let { !undef = -1 :: Int}; !vis <- VUM.replicate (rangeSize $ bounds graph) undef; let { inner !depth !vs | IS.null vs = return () | otherwise = do { let { vs' = IS.toList vs}; forM_ vs' $ \ v -> do { VUM.unsafeWrite vis v depth}; !next <- fmap (IS.fromList . concat) $ forM vs' $ \ v -> do { filterM (fmap (== undef) . VUM.unsafeRead vis) $ graph ! v}; inner (succ depth) next}}; !_ <- inner (0 :: Int) (IS.singleton start); return vis};bfsPath :: Graph Int -> Int -> Int -> Maybe Int;bfsPath !graph !start !end = inner (-1) IS.empty (IS.singleton start) where { inner :: Int -> IS.IntSet -> IS.IntSet -> Maybe Int; inner !depth !vis !vs | IS.member end vis = Just depth | IS.null vs = Nothing | otherwise = inner (succ depth) vis' vs' where { vis' = vis `IS.union` vs; vs' = IS.fromList $! filter (`IS.notMember` vis') $! concatMap (graph !) (IS.toList vs)}};bfsVerts :: Graph Int -> Int -> IM.IntMap Int;bfsVerts graph start = inner 0 IM.empty (IS.singleton start) where { inner :: Int -> IM.IntMap Int -> IS.IntSet -> IM.IntMap Int; inner !depth !vis !vs | IS.null vs = vis | otherwise = inner (succ depth) vis' vs' where { vis' = IM.union vis $! IM.fromSet (const depth) vs; vs' = IS.fromList $! filter (`IM.notMember` vis') $! concatMap (graph !) (IS.toList vs)}};bfsGrid :: UArray (Int, Int) Char -> (Int, Int) -> UArray (Int, Int) Int;bfsGrid !grid !start = runSTUArray $ do { let { !bounds_ = bounds grid}; let { (!_, !w) = both succ $! snd bounds_}; let { isBlock !yx = grid ! yx == '#'}; let { ix = index bounds_}; let { unIndex !i = i `divMod` w}; let { !undef = -1 :: Int}; !vis <- newArray bounds_ undef; let { nexts !yx0 = filter (\ yx -> inRange bounds_ yx && not (isBlock yx)) $! map (add2 yx0) dyxs where { dyxs = [(1, 0), (-1, 0), (0, 1), (0, -1)]}}; let { inner !depth !vs | IS.null vs = return () | otherwise = do { let { yxs = map unIndex $! IS.toList vs}; forM_ yxs $ \ yx -> do { writeArray vis yx depth}; !vss <- forM yxs $ \ yx -> do { filterM (fmap (== undef) . readArray vis) $ nexts yx}; inner (succ depth) $! IS.fromList . map ix $! concat vss}}; !_ <- inner (0 :: Int) (IS.singleton $ ix start); return vis};solve01BFS :: (Int, Int) -> UArray (Int, Int) Char -> UArray (Int, Int) Int;solve01BFS !start !grid = runSTUArray $ do { !dp <- newArray (bounds grid) undef; let { popLoop Seq.Empty = return (); popLoop ((!v1, !d1) Seq.:<| seq0) = do { !lastD <- readArray dp v1; if lastD /= undef then popLoop seq0 else do { writeArray dp v1 d1; popLoop <=< foldForM seq0 (grid `adjW` v1) $ \ seq (!v2, !w2) -> do { !d2 <- readArray dp v2; if d2 /= undef then return seq else do { if w2 == 0 then return ((v2, d1) Seq.<| seq) else return (seq Seq.|> (v2, succ d1))}}}}}; popLoop $ Seq.singleton (start, 0 :: Int); return dp} where { !undef = -1 :: Int; adjW :: UArray (Int, Int) Char -> (Int, Int) -> [((Int, Int), Int)]; adjW !grid !yx0 = let { !adjs1 = map (, 0 :: Int) $ filter ((&&) <$> inRange (bounds grid) <*> ((== '.') . (grid !))) $ map (add2 yx0) dir4; !adjs2 = map (, 1 :: Int) $ filter ((&&) <$> inRange (bounds grid) <*> ((== '.') . (grid !))) $ map (add2 yx0) bombs} in adjs1 ++ adjs2 where { !dir4 = [(0, 1), (0, -1), (1, 0), (-1, 0)]; !bombs = [(y, x) | y <- [-2 .. 2], x <- [-2 .. 2], abs x + abs y >= 2]}};bfsGrid01 :: (Int, Int) -> UArray (Int, Int) Bool -> UArray (Int, Int, Int) Int;bfsGrid01 !start !isBlock = runSTUArray $ do { !dp <- newArray ((0, 0, 0), (pred h, pred w, pred 4)) undef; forM_ [0 .. 3] $ \ iDir -> do { writeArray dp (fst start, snd start, iDir) 0}; let { popLoop Seq.Empty = return (); popLoop (((!y0, !x0, !iDir0), d0) Seq.:<| seq0) = foldM step seq0 [0 .. 3] >>= popLoop where { step !acc !iDir | not (inRange bounds_ (y, x)) || isBlock ! (y, x) = return acc | otherwise = do { !lastD <- readArray dp (y, x, iDir); if lastD /= undef && lastD <= d' then return acc else do { writeArray dp (y, x, iDir) d'; if iDir == iDir0 then return $ nextItem Seq.<| acc else return $ acc Seq.|> nextItem}} where { (!y, !x) = add2 (y0, x0) (dyxs VU.! iDir); !d' | iDir == iDir0 = d0 | otherwise = succ d0; !nextItem = ((y, x, iDir), d')}}}; popLoop . Seq.fromList $ map (\ iDir -> ((fst start, snd start, iDir), 0)) [0 .. 3]; return dp} where { !undef = -1 :: Int; !bounds_ = bounds isBlock; (!h, !w) = both succ . snd $! bounds isBlock; !dyxs = VU.fromList [(1, 0), (-1, 0), (0, 1), (0, -1)]};components :: Graph Int -> Int -> IS.IntSet;components !graph !start = inner (IS.singleton start) start where { inner vis v | null vs = vis' | otherwise = foldl' inner vis' vs where { vs = filter (`IS.notMember` vis) $! graph ! v; vis' = IS.union vis $! IS.fromList vs}};dfsEveryPathT072 :: UArray (Int, Int) Char -> (Int, Int) -> Int;dfsEveryPathT072 !gr !start | gr ! start == '#' = 0; dfsEveryPathT072 !gr !start = runST $ do { !vis <- newArray (bounds gr) False :: ST s (STUArray s (Int, Int) Bool); let { nexts v = filterM (fmap not . readArray vis) . filter ((&&) <$> inRange (bounds gr) <*> ((/= '#') . (gr !))) $! map (add2 v) [(0, 1), (0, -1), (1, 0), (-1, 0)]}; flip fix (0 :: Int, start) $ \ loop (!d1, !v1) -> do { when (v1 /= start) $ do { writeArray vis v1 True}; !v2s <- nexts v1; !maxDistance <- fmap (foldl' max (0 :: Int)) . forM v2s $ \ v2 -> do { if v2 == start then return (succ d1) else loop (succ d1, v2)}; writeArray vis v1 False; return maxDistance}};cyclesSUG :: Array Vertex [Vertex] -> VU.Vector Bool;cyclesSUG !graph = VU.create $ do { !degs <- VUM.replicate nVerts (0 :: Int); forM_ (assocs graph) $ \ (!v1, !v2s) -> do { forM_ v2s $ \ v2 -> do { VUM.modify degs succ v1; VUM.modify degs succ v2}}; !heap0 <- H.fromList <$> filterM (fmap (== 1) . VUM.read degs) [0 .. pred nVerts]; !isCycleVert <- VUM.replicate nVerts True; flip fix heap0 $ \ loop !heap -> case H.uncons heap of { Nothing -> return (); Just (!v1, !heap') -> do { VUM.write degs 0 v1; VUM.write isCycleVert v1 False; loop <=< foldForM heap' (graph ! v1) $ \ heap'' v2 -> do { !deg <- VUM.read degs v2; case deg of { 0 -> return heap''; 1 -> error "cycleSUD: degree 1 to degree 1?"; 2 -> do { VUM.modify degs pred v2; return $ H.insert v2 heap''}; _ -> do { VUM.modify degs pred v2; return heap''}}}}}; return isCycleVert} where { !nVerts = rangeSize (bounds graph)};dj :: forall a . (Num a, Ord a) => WGraph a -> Int -> IM.IntMap a;dj !graph !start = inner (H.singleton $! H.Entry 0 start) IM.empty where { merge :: H.Entry a Int -> H.Entry a Int -> H.Entry a Int; merge (H.Entry !cost1 !_v1) (H.Entry !cost2 !v2) = H.Entry (cost1 + cost2) v2; inner :: H.Heap (H.Entry a Int) -> IM.IntMap a -> IM.IntMap a; inner !heap !vis | H.null heap = vis | IM.member v vis = inner heap' vis | otherwise = inner heap'' vis' where { (entry@(H.Entry cost v), heap') = fromJust $! H.uncons heap; vis' = IM.insert v cost vis; vs = map (merge entry) $! filter ((`IM.notMember` vis') . H.payload) $! graph ! v; heap'' = foldl' (flip H.insert) heap' vs}};revDj :: WGraph Int -> Int -> IM.IntMap Int;revDj !graph !start = dj (revWGraph graph) start;revWGraph :: WGraph Int -> WGraph Int;revWGraph !graph = accumArray @Array (flip (:)) [] (bounds graph) $ concatMap revF $ assocs graph where { revF (!v1, !v2s) = map (\ (H.Entry !priority !v2) -> (v2, H.Entry priority v1)) v2s};djVec :: forall a . (Num a, Ord a, VU.Unbox a) => WGraph a -> Int -> a -> VU.Vector a;djVec !graph !start !undef = VU.create $ do { !vis <- VUM.replicate nVerts undef; let { inner !heap = case H.uncons heap of { Nothing -> return (); Just (entry@(H.Entry cost v), heap') -> do { !isNew <- (== undef) <$> VUM.read vis v; if not isNew then inner heap' else do { VUM.write vis v cost; !vs <- map (merge entry) <$> filterM (fmap (== undef) . VUM.read vis . H.payload) (graph ! v); inner $! foldl' (flip H.insert) heap' vs}}}}; inner (H.singleton $ H.Entry 0 start); return vis} where { !nVerts = rangeSize $! bounds graph; merge :: H.Entry a Int -> H.Entry a Int -> H.Entry a Int; merge (H.Entry !cost1 !_v1) (H.Entry !cost2 !v2) = H.Entry (cost1 + cost2) v2};revDjVec :: WGraph Int -> Int -> VU.Vector Int;revDjVec !graph !start = djVec (revWGraph graph) start (-1);{-# INLINE newFW #-};newFW :: (PrimMonad m, VU.Unbox cost) => (Vertex -> cost, cost, cost) -> Int -> [(Int, Int)] -> m (VUM.MVector (PrimState m) cost);newFW (!getCost, !zeroCost, !maxCost) !nVerts !edges = do { !dp <- VUM.replicate (nVerts * nVerts) maxCost; forMS_ (rangeMS 0 (pred nVerts)) $ \ !v -> VUM.unsafeWrite dp (ix (v, v)) zeroCost; forM_ edges $ \ (!v1, !v2) -> do { let { !cost = getCost v2}; VUM.unsafeWrite dp (ix (v1, v2)) cost}; return dp} where { ix :: (Int, Int) -> Int; ix = index ((0, 0), (nVerts - 1, nVerts - 1))};{-# INLINE runFW #-};runFW :: (PrimMonad m, VU.Unbox cost) => (cost -> cost -> cost, cost -> cost -> cost) -> Int -> VUM.MVector (PrimState m) cost -> m ();runFW (!mergeCost, !minCost) !nVerts !dp = do { let { !ve = pred nVerts}; forM_ (range ((0, 0, 0), (ve, ve, ve))) $ \ (!v3, !v1, !v2) -> do { !cost1 <- VUM.unsafeRead dp (ix (v1, v2)); !cost2 <- mergeCost <$> VUM.unsafeRead dp (ix (v1, v3)) <*> VUM.unsafeRead dp (ix (v3, v2)); VUM.unsafeWrite dp (ix (v1, v2)) $ minCost cost1 cost2}} where { ix :: (Int, Int) -> Int; ix = index ((0, 0), (nVerts - 1, nVerts - 1))};{-# INLINE newFW_ABC286E #-};newFW_ABC286E :: (PrimMonad m) => (Vertex -> (Int, Int)) -> Int -> [(Int, Int)] -> m (VUM.MVector (PrimState m) (Int, Int));newFW_ABC286E !getCost = newFW (getCost, (0, 0), (maxBound @Int, maxBound @Int));{-# INLINE runFW_ABC286E #-};runFW_ABC286E :: (PrimMonad m) => Int -> VUM.MVector (PrimState m) (Int, Int) -> m ();runFW_ABC286E = runFW (mergeCost, minCost) where { mergeCost :: (Int, Int) -> (Int, Int) -> (Int, Int); mergeCost (!d1, !v1) (!d2, !v2) | d1 == maxBound = (d1, v1) | d2 == maxBound = (d2, v2) | d1 == maxBound = (d1, v1) | otherwise = (d1 + d2, v1 + v2); minCost :: (Int, Int) -> (Int, Int) -> (Int, Int); minCost (!d1, !v1) (!d2, !v2) = case compare d1 d2 of { EQ -> (d1, max v1 v2); LT -> (d1, v1); GT -> (d2, v2)}};data RNEdge = RNEdge{to :: {-# UNPACK #-} !Vertex, cap :: {-# UNPACK #-} !Int, rev :: {-# UNPACK #-} !Int} deriving (Show);derivingUnbox "RNEdge" [t| RNEdge -> (Vertex, Int, Int) |] [| \ (RNEdge !x1 !x2 !x3) -> (x1, x2, x3) |] [| \ (!x1, !x2, !x3) -> RNEdge x1 x2 x3 |];type ResidualNetwork = VM.IOVector (IM.IntMap RNEdge);buildRN :: Int -> [(Int, (Int, Int))] -> IO ResidualNetwork;buildRN !nVerts !edges = do { !rn <- VM.replicate nVerts IM.empty; forM_ edges $ \ (!v1, (!v2, !cap_)) -> do { addEdgeRN rn v1 v2 cap_}; return rn} where { addEdgeRN :: ResidualNetwork -> Int -> Int -> Int -> IO (); addEdgeRN !rn !v1 !v2 !maxFlow = do { !edges1 <- VM.read rn v1; !edges2 <- VM.read rn v2; VM.write rn v1 $ IM.insertWith mergeEdge v2 (RNEdge v2 maxFlow v1) edges1; VM.write rn v2 $ IM.insertWith mergeEdge v1 (RNEdge v1 0 v2) edges2}; mergeEdge :: RNEdge -> RNEdge -> RNEdge; mergeEdge (RNEdge !to_ !flow !cap_) (RNEdge !_ !flow' !_) = RNEdge to_ (flow + flow') cap_};{-# INLINE maxFlowRN #-};maxFlowRN :: Int -> ResidualNetwork -> Int -> Int -> IO Int;maxFlowRN !nVerts !rn !v0 !ve = do { !vis <- VM.replicate nVerts False; inner vis} where { inner :: VM.IOVector Bool -> IO Int; inner !vis = augumentPath rn vis v0 ve >>= \case { Nothing -> return 0; Just (!flow, !path) -> do { updateFlow rn flow path; VM.set vis False; (flow +) <$> inner vis}}};{-# INLINE augumentPath #-};augumentPath :: ResidualNetwork -> VM.IOVector Bool -> Vertex -> Int -> IO (Maybe (Int, [(Vertex, Vertex)]));augumentPath !rn !vis !v0 !goal = visitVertex v0 (maxBound @Int) where { visitVertex :: Vertex -> Int -> IO (Maybe (Int, [(Vertex, Vertex)])); visitVertex !v !flow | v == goal = return $ Just (flow, []) | otherwise = do { VM.write vis v True; !edges <- VM.read rn v; foldM (step v flow) Nothing edges}; step :: Vertex -> Int -> Maybe (Int, [(Vertex, Vertex)]) -> RNEdge -> IO (Maybe (Int, [(Vertex, Vertex)])); step !_ !_ r@(Just _) _ = return r; step !from !flow !_ !edge = do { !visited <- VM.read vis (to edge); if visited || flow' == 0 then return Nothing else visitVertex (to edge) flow' >>= \case { Nothing -> return Nothing; Just (!f, !path) -> return $ Just (f, p : path)}} where { flow' = min flow (cap edge); p = (from, to edge)}};{-# INLINE updateFlow #-};updateFlow :: ResidualNetwork -> Int -> [(Vertex, Vertex)] -> IO ();updateFlow !rn !flow !path = forM_ path $ \ (!v1, !v2) -> addFlowRNEdge rn v1 v2 flow;{-# INLINE addFlowRNEdge #-};addFlowRNEdge :: ResidualNetwork -> Vertex -> Vertex -> Int -> IO ();addFlowRNEdge !rn !v1 !v2 !flow = do { (!edges1, !edge12) <- second (IM.! v2) . dupe <$> VM.read rn v1; (!edges2, !edge21) <- second (IM.! v1) . dupe <$> VM.read rn v2; VM.write rn v1 $ IM.insert v2 (RNEdge (to edge12) (cap edge12 - flow) (rev edge12)) edges1; VM.write rn v2 $ IM.insert v1 (RNEdge (to edge21) (cap edge21 + flow) (rev edge21)) edges2};type Color = Bool;type ColorInfo = ([Int], [Int]);colorize :: Graph Int -> IM.IntMap Color -> Vertex -> (IM.IntMap Color, Maybe ColorInfo);colorize !graph !colors0 = dfs True (colors0, Just ([], [])) where { dfs :: Color -> (IM.IntMap Color, Maybe ColorInfo) -> Vertex -> (IM.IntMap Color, Maybe ColorInfo); dfs !color (!colors, !acc) !v = let { (!colors', !acc') = setColor color (colors, acc) v} in if IM.member v colors then (colors', acc') else foldl' (dfs (not color)) (colors', acc') $ graph ! v; setColor :: Color -> (IM.IntMap Color, Maybe ColorInfo) -> Vertex -> (IM.IntMap Color, Maybe ColorInfo); setColor !color (!colors, !acc) !v = case IM.lookup v colors of { Just c | c == color -> (colors, acc) | otherwise -> (colors, Nothing); Nothing -> (IM.insert v color colors, applyColor color v acc)}; applyColor :: Color -> Vertex -> Maybe ColorInfo -> Maybe ColorInfo; applyColor !_ !_ Nothing = Nothing; applyColor !color !v (Just !acc) | color = Just $ first (v :) acc | otherwise = Just $ second (v :) acc};foldTree :: forall m a . Array Vertex [Vertex] -> Vertex -> (m -> a -> a) -> (Vertex -> a) -> (a -> m) -> a;foldTree !tree !root !sact !acc0At !toM = inner (-1) root where { inner :: Vertex -> Vertex -> a; inner !parent !v1 = let { !v2s = filter (/= parent) $ tree ! v1} in foldl' (\ acc v2 -> (toM $! inner v1 v2) `sact` acc) (acc0At v1) v2s};scanTreeVG :: (VG.Vector v a) => Array Vertex [Vertex] -> Vertex -> (m -> a -> a) -> (Vertex -> a) -> (a -> m) -> v a;scanTreeVG !tree !root !sact !acc0At !toM = VG.create $ do { !dp <- VGM.unsafeNew nVerts; !_ <- flip fix (-1, root) $ \ runTreeDp (!parent, !v1) -> do { let { !v2s = filter (/= parent) $! tree ! v1}; !x1 <- foldM (\ acc v2 -> (`sact` acc) . toM <$> runTreeDp (v1, v2)) (acc0At v1) v2s; VGM.write dp v1 x1; return x1}; return dp} where { !nVerts = rangeSize $! bounds tree};scanTreeVU :: VU.Unbox a => Array Vertex [Vertex] -> Vertex -> (m -> a -> a) -> (Vertex -> a) -> (a -> m) -> VU.Vector a;scanTreeVU = scanTreeVG;scanTreeV :: Array Vertex [Vertex] -> Vertex -> (m -> a -> a) -> (Vertex -> a) -> (a -> m) -> V.Vector a;scanTreeV = scanTreeVG;foldTreeAll :: (VU.Unbox a, VU.Unbox m, MonoidAction m a) => Array Vertex [Vertex] -> (Vertex -> a) -> (a -> m) -> VU.Vector a;foldTreeAll !tree !acc0At !toM = let { !treeDp = scanTreeVG tree root0 mact acc0At toM; !rootDp = VU.create $ do { !dp <- VUM.unsafeNew nVerts; flip fix (-1, op0, root0) $ \ runRootDp (!parent, !parentOp, !v1) -> do { let { !children = VU.fromList . filter (/= parent) $! tree ! v1}; let { !opL = VU.scanl' (\ op v2 -> (op <>) . toM $! treeDp VU.! v2) op0 children}; let { !opR = VU.scanr' (\ v2 op -> (<> op) . toM $! treeDp VU.! v2) op0 children}; let { !x1 = (parentOp <> VU.last opL) `mact` acc0At v1}; VUM.write dp v1 x1; flip VU.imapM_ children $ \ !i2 !v2 -> do { let { !lrOp = (opL VU.! i2) <> (opR VU.! succ i2)}; let { !v1Acc = (parentOp <> lrOp) `mact` acc0At v2}; runRootDp (v1, toM v1Acc, v2)}}; return dp}} in rootDp where { !nVerts = rangeSize $ bounds tree; !root0 = 0 :: Int; !op0 = mempty};newtype BinaryLifting v m = BinaryLifting (v m) deriving (Show, Eq);newBinLift :: (VG.Vector v s, Semigroup s) => s -> BinaryLifting v s;newBinLift !op0 = BinaryLifting ops where { !ops = VG.iterateN (pred 63) (\ !op -> op <> op) op0};newBinLiftV :: Semigroup s => s -> BinaryLifting V.Vector s;newBinLiftV = newBinLift;newBinLiftVU :: (Semigroup s, VU.Unbox s) => s -> BinaryLifting VU.Vector s;newBinLiftVU = newBinLift;stimesBL :: (Semigroup s, VG.Vector v s) => (BinaryLifting v s) -> s -> Int -> s;stimesBL (BinaryLifting !ops) !s0 !n = VU.foldl' step s0 (VU.enumFromN 0 62) where { step !m !i | testBit n i = m <> ops VG.! i | otherwise = m};mtimesBL :: (Monoid m, VG.Vector v m) => (BinaryLifting v m) -> Int -> m;mtimesBL !bin !n = stimesBL bin mempty n;sactBL :: (SemigroupAction s a, VG.Vector v s) => (BinaryLifting v s) -> a -> Int -> a;sactBL (BinaryLifting !ops) !acc0 !nAct = VU.foldl' step acc0 (rangeVG 0 62) where { step !acc !nBit | testBit nAct nBit = (ops VG.! nBit) `sact` acc | otherwise = acc};mactBL :: (MonoidAction m a, VG.Vector v m) => (BinaryLifting v m) -> a -> Int -> a;mactBL = sactBL;newDoubling :: (VG.Vector v a, VG.Vector v Int) => a -> (a -> a) -> v a;newDoubling !oper0 !squareCompositeF = VG.scanl' step oper0 $! VG.enumFromN (1 :: Int) 62 where { step !oper !_ = squareCompositeF oper};newDoublingV :: a -> (a -> a) -> V.Vector a;newDoublingV = newDoubling;applyDoubling :: (VG.Vector v op) => v op -> a -> (a -> op -> a) -> Int -> a;applyDoubling !opers !x0 !act !n = foldl' step x0 [0 .. 62] where { !_ = dbgAssert $ VG.length opers == 63; step !acc !nBit = if testBit n nBit then acc `act` (opers VG.! nBit) else acc};class RangeMS a where { rangeMS2 :: Monad m => (a, a) -> MS.Stream m a};instance RangeMS Int where { rangeMS2 (!l, !r) = rangeMS l r};instance RangeMS (Int, Int) where { rangeMS2 ((!y0, !x0), (!y1, !x1)) = MS.Stream step (y0, x0) where { {-# INLINE [0] step #-}; step (!y, !x) | x <= x1 = return $! MS.Yield (y, x) (y, x + 1) | y <= y1 = return $! MS.Yield (y, x) (y + 1, x0) | otherwise = return MS.Done}};class (Ix i, VU.Unbox i) => Unindex i where { unindex :: (i, i) -> Int -> i};instance Unindex Int where { unindex _ !v = v};instance Unindex (Int, Int) where { unindex ((!y0, !x0), (!_, !x1)) !yx = let { !w = x1 - x0 + 1; (!dy, !dx) = yx `quotRem` w} in (y0 + dy, x0 + dx)};instance Unindex (Int, Int, Int) where { unindex ((!z0, !y0, !x0), (!_, !y1, !x1)) !zyx = let { !h = y1 - y0 + 1; !w = x1 - x0 + 1; (!dz, !yx) = zyx `quotRem` (h * w); (!dy, !dx) = yx `quotRem` w} in (z0 + dz, y0 + dy, x0 + dx)};type Edge = (Vertex, Vertex);type WEdgeWith w = (Vertex, Vertex, w);type EdgeId = Int;data SparseGraph i w = SparseGraph{boundsSG :: !(i, i), nVertsSG :: !Int, nEdgesSG :: !Int, offsetsSG :: !(VU.Vector Int), adjacentsSG :: !(VU.Vector Vertex), edgeWeightsSG :: !(VU.Vector w)} deriving (Show);{-# INLINE buildUSG #-};buildUSG :: (Unindex i) => (i, i) -> VU.Vector (i, i) -> SparseGraph i ();buildUSG !boundsSG !edges = buildRawSG boundsSG $ VU.map (\ (!i1, !i2) -> (ix i1, ix i2, ())) edges where { ix = index boundsSG};{-# INLINE buildWSG #-};buildWSG :: (Unindex i, VUM.Unbox w) => (i, i) -> VU.Vector (i, i, w) -> SparseGraph i w;buildWSG !boundsSG !edges = buildRawSG boundsSG $ VU.map (\ (!i1, !i2, !w) -> (ix i1, ix i2, w)) edges where { ix = index boundsSG};{-# INLINE buildRawSG #-};buildRawSG :: (Unindex i, VUM.Unbox w) => (i, i) -> VU.Vector (Vertex, Vertex, w) -> SparseGraph i w;buildRawSG !boundsSG !edges = let { !nEdgesSG = VU.length edges; !nVertsSG = rangeSize boundsSG; !offsetsSG = VU.scanl' (+) 0 $ VU.create $ do { !outDegs <- VUM.replicate nVertsSG (0 :: Int); VU.forM_ edges $ \ (!v1, !_, !_) -> do { VUM.modify outDegs succ v1}; return outDegs}; !_ = dbgAssert (VU.last offsetsSG == nEdgesSG); (!adjacentsSG, !edgeWeightsSG) = runST $ do { !mOffsets <- VU.thaw offsetsSG; !mAdjacents <- VUM.unsafeNew nEdgesSG; !mWeights <- VUM.unsafeNew nEdgesSG; VU.forM_ edges $ \ (!v1, !v2, !w) -> do { !iEdgeFlatten <- VUM.unsafeRead mOffsets v1; VUM.unsafeWrite mOffsets v1 (iEdgeFlatten + 1); VUM.unsafeWrite mAdjacents iEdgeFlatten v2; VUM.unsafeWrite mWeights iEdgeFlatten w}; (,) <$> VU.unsafeFreeze mAdjacents <*> VU.unsafeFreeze mWeights}} in SparseGraph{..};{-# INLINE adj #-};adj :: SparseGraph i w -> Vertex -> VU.Vector Vertex;adj SparseGraph{..} v = VU.unsafeSlice o1 (o2 - o1) adjacentsSG where { !o1 = VU.unsafeIndex offsetsSG v; !o2 = VU.unsafeIndex offsetsSG (v + 1)};{-# INLINE eAdj #-};eAdj :: SparseGraph i w -> Vertex -> VU.Vector (EdgeId, Vertex);eAdj SparseGraph{..} v = VU.imap ((,) . (+ o1)) vs where { !o1 = VU.unsafeIndex offsetsSG v; !o2 = VU.unsafeIndex offsetsSG (v + 1); !vs = VU.unsafeSlice o1 (o2 - o1) adjacentsSG};{-# INLINE adjIx #-};adjIx :: (Unindex i) => SparseGraph i w -> i -> VU.Vector i;adjIx gr i = VU.map (unindex (boundsSG gr)) $ adj gr v where { !v = index (boundsSG gr) i};{-# INLINE adjW #-};adjW :: (VU.Unbox w) => SparseGraph i w -> Vertex -> VU.Vector (Vertex, w);adjW SparseGraph{..} v = VU.zip vs ws where { !o1 = VU.unsafeIndex offsetsSG v; !o2 = VU.unsafeIndex offsetsSG (v + 1); !vs = VU.unsafeSlice o1 (o2 - o1) adjacentsSG; !ws = VU.unsafeSlice o1 (o2 - o1) edgeWeightsSG};{-# INLINE adjWIx #-};adjWIx :: (Unindex i, VU.Unbox w) => SparseGraph i w -> i -> VU.Vector (i, w);adjWIx gr i = VU.map (first (unindex (boundsSG gr))) $ adjW gr v where { !v = index (boundsSG gr) i};dfsSG :: (Unindex i) => SparseGraph i w -> i -> IxVector i (VU.Vector Int);dfsSG gr@SparseGraph{..} !startIx = IxVector boundsSG $ VU.create $ do { let { !undef = -1 :: Int}; !dist <- VUM.replicate nVertsSG undef; flip fix (0 :: Int, index boundsSG startIx) $ \ loop (!depth, !v1) -> do { VUM.write dist v1 depth; VU.forM_ (gr `adj` v1) $ \ v2 -> do { !d <- VUM.read dist v2; when (d == undef) $ do { loop (succ depth, v2)}}}; return dist};componentsVecSG :: (Ix i) => SparseGraph i w -> i -> IxVector i (VU.Vector Bool);componentsVecSG !gr@SparseGraph{..} !startIx = IxVector boundsSG $ VU.create $ do { !vis <- VUM.replicate nVertsSG False; flip fix start $ \ loop v1 -> do { VUM.write vis v1 True; let { !v2s = gr `adj` v1}; VU.forM_ v2s $ \ v2 -> do { !visited <- VUM.read vis v2; when (not visited) $ do { loop v2}}}; return vis} where { !start = index boundsSG startIx :: Vertex};bfsSG :: (Unindex i) => SparseGraph i w -> i -> IxVector i (VU.Vector Int);bfsSG gr@SparseGraph{..} !startIx = IxVector boundsSG $ VU.create $ do { let { !undef = -1 :: Int}; !dist <- VUM.replicate nVertsSG undef; let { inner !depth !vs1 | IS.null vs1 = return () | otherwise = do { let { vs1' = IS.toList vs1}; forM_ vs1' $ \ v1 -> do { VUM.unsafeWrite dist v1 depth}; !vs2 <- foldForM [] vs1' $ \ acc v1 -> do { foldForMVG acc (gr `adj` v1) $ \ acc' v2 -> do { !d <- VUM.unsafeRead dist v2; if d == undef then return (v2 : acc') else return acc'}}; inner (succ depth) $ IS.fromList vs2}}; !_ <- inner (0 :: Int) (IS.singleton (index boundsSG startIx)); return dist};djSG :: forall i w . (Unindex i, Num w, Ord w, VU.Unbox w) => SparseGraph i w -> w -> i -> VU.Vector w;djSG gr@SparseGraph{..} !undef !startIx = VU.create $ do { !dist <- VUM.replicate nVertsSG undef; let { !heap0 = H.singleton $ H.Entry 0 (index boundsSG startIx)}; flip fix heap0 $ \ loop heap -> case H.uncons heap of { Nothing -> return (); Just (entry@(H.Entry cost v), heap') -> do { (== undef) <$> VUM.read dist v >>= \case { False -> loop heap'; True -> do { VUM.write dist v cost; !vws <- VU.filterM (fmap (== undef) . VUM.read dist . fst) $ gr `adjW` v; loop $ VU.foldl' (\ h (!v, !w) -> H.insert (merge entry (H.Entry w v)) h) heap' vws}}}}; return dist} where { merge :: H.Entry w Vertex -> H.Entry w Vertex -> H.Entry w Vertex; merge (H.Entry !cost1 !_v1) (H.Entry !cost2 !v2) = H.Entry (cost1 + cost2) v2};dfsPathSG :: (Unindex i) => SparseGraph i w -> i -> i -> Maybe [Edge];dfsPathSG gr@SparseGraph{..} !startIx !endIx = runST $ do { let { !undef = -1 :: Int}; !dist <- VUM.replicate nVertsSG undef; flip fix (0 :: Int, start, []) $ \ loop (!depth, !v1, !stack) -> do { !lastD1 <- VUM.read dist v1; when (lastD1 == undef) $ do { VUM.write dist v1 depth}; if lastD1 /= undef then return Nothing else if v1 == end then return $ Just stack else do { flip fix (gr `adj` v1) $ \ visitNeighbors v2s -> case unconsVG v2s of { Nothing -> return Nothing; Just (!v2, !v2s') -> do { (<|>) <$> loop (succ depth, v2, (v1, v2) : stack) <*> visitNeighbors v2s'}}}}} where { !start = index boundsSG startIx; !end = index boundsSG endIx};treeDfsPathSG :: (Unindex i) => SparseGraph i w -> i -> i -> [Edge];treeDfsPathSG gr@SparseGraph{..} !startIx !endIx = fromJust $ runST $ do { let { !undef = -1 :: Int}; flip fix (0 :: Int, undef, start, []) $ \ loop (!depth, !parent, !v1, !stack) -> do { if v1 == end then return $ Just stack else do { flip fix (VU.filter (/= parent) $ gr `adj` v1) $ \ visitNeighbors v2s -> case unconsVG v2s of { Nothing -> return Nothing; Just (!v2, !v2s') -> do { (<|>) <$> loop (succ depth, v1, v2, (v1, v2) : stack) <*> visitNeighbors v2s'}}}}} where { !start = index boundsSG startIx; !end = index boundsSG endIx};topSortSG :: SparseGraph i w -> [Vertex];topSortSG gr@SparseGraph{..} = runST $ do { !vis <- VUM.replicate nVertsSG False; let { dfsM !acc !v = do { VUM.unsafeRead vis v >>= \case { True -> return acc; False -> do { VUM.unsafeWrite vis v True; !vs <- VU.filterM (fmap not . VUM.unsafeRead vis) $ gr `adj` v; (v :) <$> VU.foldM' dfsM acc vs}}}}; MS.foldM' dfsM [] (rangeMS 0 (pred nVertsSG))};topScc1SG :: forall i w m . (PrimMonad m) => SparseGraph i w -> VUM.MVector (PrimState m) Bool -> Vertex -> m [Vertex];topScc1SG !gr' !vis !v0 = do { flip fix ([], v0) $ \ loop (!acc, !v) -> do { VUM.unsafeRead vis v >>= \case { False -> return acc; True -> do { VUM.unsafeWrite vis v True; !vs <- VU.filterM (fmap not . VUM.unsafeRead vis) $ gr' `adj` v; (v :) <$> VU.foldM' (curry loop) acc vs}}}};revSG :: (Unindex i, VU.Unbox w) => SparseGraph i w -> SparseGraph i w;revSG SparseGraph{..} = buildRawSG boundsSG edges' where { !vws = VU.zip adjacentsSG edgeWeightsSG; !edges' = flip VU.concatMap (rangeVU 0 (pred nVertsSG)) $ \ v1 -> let { !o1 = VU.unsafeIndex offsetsSG v1; !o2 = VU.unsafeIndex offsetsSG (v1 + 1); !vw2s = VU.unsafeSlice o1 (o2 - o1) vws} in VU.map (\ (v2, !w2) -> (v2, v1, w2)) vw2s};topSccSG :: (Unindex i, VU.Unbox w) => SparseGraph i w -> [[Int]];topSccSG gr = collectSccPreorderSG $ topSortSG gr where { !gr' = revSG gr; collectSccPreorderSG :: [Int] -> [[Int]]; collectSccPreorderSG !topVerts = runST $ do { !vis <- VUM.replicate (nVertsSG gr) False; filter (not . null) <$> mapM (topScc1SG gr' vis) topVerts}};{-# INLINE bsearch #-};bsearch :: (Int, Int) -> (Int -> Bool) -> (Maybe Int, Maybe Int);bsearch !rng = runIdentity . bsearchM rng . (return .);{-# INLINE bsearchL #-};bsearchL :: (Int, Int) -> (Int -> Bool) -> Maybe Int;bsearchL !a !b = fst $! bsearch a b;{-# INLINE bsearchR #-};bsearchR :: (Int, Int) -> (Int -> Bool) -> Maybe Int;bsearchR !a !b = snd $! bsearch a b;{-# INLINE bsearchM #-};bsearchM :: forall m . (Monad m) => (Int, Int) -> (Int -> m Bool) -> m (Maybe Int, Maybe Int);bsearchM (!low, !high) !isOk = both wrap <$> inner (low - 1, high + 1) where { inner :: (Int, Int) -> m (Int, Int); inner (!ok, !ng) | abs (ok - ng) == 1 = return (ok, ng); inner (!ok, !ng) = isOk m >>= \case { True -> inner (m, ng); False -> inner (ok, m)} where { !m = (ok + ng) `div` 2}; wrap :: Int -> Maybe Int; wrap !x | inRange (low, high) x = Just x | otherwise = Nothing};{-# INLINE bsearchML #-};bsearchML :: forall m . (Monad m) => (Int, Int) -> (Int -> m Bool) -> m (Maybe Int);bsearchML = fmap fst .: bsearchM;{-# INLINE bsearchMR #-};bsearchMR :: forall m . (Monad m) => (Int, Int) -> (Int -> m Bool) -> m (Maybe Int);bsearchMR = fmap snd .: bsearchM;{-# INLINE bsearchF32 #-};bsearchF32 :: (Float, Float) -> Float -> (Float -> Bool) -> (Maybe Float, Maybe Float);bsearchF32 (!low, !high) !diff !isOk = both wrap (inner (low - diff, high + diff)) where { inner :: (Float, Float) -> (Float, Float); inner (!ok, !ng) | abs (ok - ng) <= diff = (ok, ng); inner (!ok, !ng) | isOk m = inner (m, ng) | otherwise = inner (ok, m) where { !m = (ok + ng) / 2}; wrap :: Float -> Maybe Float; wrap !x | x == (low - diff) || x == (high + diff) = Nothing | otherwise = Just x};{-# INLINE bsearchF32L #-};bsearchF32L :: (Float, Float) -> Float -> (Float -> Bool) -> Maybe Float;bsearchF32L !a !b !c = fst $! bsearchF32 a b c;{-# INLINE bsearchF32R #-};bsearchF32R :: (Float, Float) -> Float -> (Float -> Bool) -> Maybe Float;bsearchF32R !a !b !c = fst $! bsearchF32 a b c;{-# INLINE bsearchF64 #-};bsearchF64 :: (Double, Double) -> Double -> (Double -> Bool) -> (Maybe Double, Maybe Double);bsearchF64 (!low, !high) !diff !isOk = both wrap (inner (low - diff, high + diff)) where { inner :: (Double, Double) -> (Double, Double); inner (!ok, !ng) | abs (ok - ng) < diff = (ok, ng); inner (!ok, !ng) | isOk m = inner (m, ng) | otherwise = inner (ok, m) where { !m = (ok + ng) / 2}; wrap :: Double -> Maybe Double; wrap !x | x == (low - diff) || x == (high + diff) = Nothing | otherwise = Just x};{-# INLINE bsearchF64L #-};bsearchF64L :: (Double, Double) -> Double -> (Double -> Bool) -> Maybe Double;bsearchF64L !a !b !c = fst $! bsearchF64 a b c;{-# INLINE bsearchF64R #-};bsearchF64R :: (Double, Double) -> Double -> (Double -> Bool) -> Maybe Double;bsearchF64R !a !b !c = fst $! bsearchF64 a b c;compressList :: [Int] -> (VU.Vector Int, [Int]);compressList xs = (indices, map (fromJust . fst . f) xs) where { !indices = VU.fromList $ nubSort xs; f !x = bsearch (0, pred (vLength indices)) $ \ i -> indices VU.! i <= x};isqrtSlow :: Int -> Int;isqrtSlow n = fromJust $ bsearchR (0, n) ((< n) . (^ (2 :: Int)));newtype ToParent = ToParent (VU.Vector Vertex);instance Semigroup ToParent where { (ToParent !vec1) <> (ToParent !vec2) = ToParent $ VU.map f vec2 where { !_ = dbgAssert (VG.length vec1 == VG.length vec2); f (-1) = (-1); f i = vec1 VU.! i}};instance SemigroupAction ToParent Vertex where { sact (ToParent !vec) !i = vec VU.! i};type LcaCache = (ToParent, VU.Vector Int, BinaryLifting V.Vector ToParent);treeDepthInfo :: Int -> (Int -> [Int]) -> Int -> (ToParent, VU.Vector Int);treeDepthInfo !nVerts !graph !root = runST $ do { !parents <- VUM.replicate nVerts (-1 :: Int); !depths <- VUM.replicate nVerts (-1 :: Int); flip fix (0 :: Int, -1 :: Int, [root]) $ \ loop (!depth, !parent, !vs) -> do { forM_ vs $ \ v -> do { VUM.unsafeWrite depths v depth; VUM.unsafeWrite parents v parent; let { !vs' = filter (/= parent) $ graph v}; loop (succ depth, v, vs')}}; (,) <$> (ToParent <$> VU.unsafeFreeze parents) <*> VU.unsafeFreeze depths};lcaCache :: Int -> (Vertex -> [Vertex]) -> Vertex -> LcaCache;lcaCache !nVerts !graph !root = (toParent, depths, toParentN) where { (!toParent, !depths) = treeDepthInfo nVerts graph root; !toParentN = newBinLift toParent};lca :: LcaCache -> Int -> Int -> (Int, Int);lca (!_, !depths, !toParentN) !v1 !v2 = (vLCA, depths VU.! vLCA) where { !d1 = depths VU.! v1; !d2 = depths VU.! v2; parentN = sactBL toParentN; !v1' = if d1 <= d2 then v1 else v2; !v2' = parentN (if d1 > d2 then v1 else v2) (abs $ d1 - d2); !dLCA = fromJust . snd $ bsearch (0, min d1 d2) $ \ d -> parentN v1' d /= parentN v2' d; !vLCA = parentN v1' dLCA};lcaLen :: LcaCache -> Int -> Int -> Int;lcaLen cache@(!_, !depths, !_) !v1 !v2 = let { (!_, !d) = lca cache v1 v2; !d1 = depths VU.! v1; !d2 = depths VU.! v2} in (d1 - d) + (d2 - d);newtype ToParentM m = ToParentM (Int, VU.Vector m);type FoldLcaCache m = (LcaCache, V.Vector (VU.Vector m));foldLcaCache :: forall m . (Monoid m, VU.Unbox m) => Int -> (Vertex -> [Vertex]) -> Vertex -> (Vertex -> Vertex -> m) -> FoldLcaCache m;foldLcaCache !nVerts !graph !root !edgeValueOf = (cache, foldCache) where { !cache@(!parents, !_, BinaryLifting !parents') = lcaCache nVerts graph root; foldCache :: V.Vector (VU.Vector m); !foldCache = V.map snd $! newDoubling toParent appendArray where { !toParent = (0, VU.map f (rangeVG 0 (pred nVerts))) where { f v = case parents `sact` v of { (-1) -> mempty; p -> edgeValueOf v p}}; appendArray (!iBit, !ops) = (succ iBit, VU.imap f ops) where { f !v0 !op = case (parents' V.! iBit) `sact` v0 of { (-1) -> op; p -> op <> (ops VU.! p)}}}};foldLcaCache2 :: forall a m . (Monoid m, VU.Unbox m) => Array Int [(Vertex, a)] -> (a -> m) -> FoldLcaCache m;foldLcaCache2 !tree !toMonoid = foldLcaCache nVerts adj root getValue where { !root = 0 :: Vertex; !nVerts = rangeSize $ bounds tree; adj = map fst . (tree !); getValue !v !p = toMonoid . snd . fromJust . find ((== p) . fst) $ tree ! v};foldViaLca :: forall m . (Monoid m, VU.Unbox m) => FoldLcaCache m -> Int -> Int -> m;foldViaLca (cache@(!_, !depths, BinaryLifting !parents'), !ops') !v1 !v2 = let { (!_, !d) = lca cache v1 v2; !d1 = depths VU.! v1; !d2 = depths VU.! v2; !a1 = foldParentN v1 (d1 - d); !a2 = foldParentN v2 (d2 - d)} in a1 <> a2 where { foldParentN :: Vertex -> Int -> m; foldParentN !v0 !nthParent = snd $ V.foldl' step (v0, mempty) input where { !input = V.zip3 (rangeVG 0 62) parents' ops'; step :: (Vertex, m) -> (Int, ToParent, VU.Vector m) -> (Vertex, m); step (!v, !acc) (!iBit, !parents, !ops) | testBit nthParent iBit = (parents `sact` v, acc <> (ops VU.! v)) | otherwise = (v, acc)}};compressVU :: VU.Vector Int -> (VU.Vector Int, VU.Vector Int);compressVU xs = (indexer, VU.map (fromJust . fst . f) xs) where { !indexer = VU.fromList $ nubSort $ VU.toList xs; f !x = bsearch (0, pred $ vLength indexer) $ \ i -> indexer VU.! i <= x};invNumVG :: Int -> (VG.Vector v Int) => v Int -> Int;invNumVG xMax xs = runST $ do { !stree <- newSTreeVU (+) (xMax + 1) (0 :: Int); foldForMVG (0 :: Int) xs $ \ acc x -> do { !s <- if x == xMax then return 0 else fromJust <$> querySTree stree (succ x, xMax); modifySTree stree succ x; return $! acc + s}};compressInvNumVG :: VU.Vector Int -> Int;compressInvNumVG xs = invNumVG (pred (VU.length xs')) xs' where { !xs' = snd $ compressVU xs};imos2D :: ((Int, Int), (Int, Int)) -> UArray (Int, Int) Int -> UArray (Int, Int) Int;imos2D !bounds_ !seeds = runSTUArray $ do { !arr <- newArray bounds_ (0 :: Int); let { (!minY, !minX) = fst bounds_}; forM_ (range bounds_) $ \ (!y, !x) -> do { !v <- if x == minX then return 0 else readArray arr (y, x - 1); let { !diff = seeds ! (y, x)}; writeArray arr (y, x) $! v + diff}; forM_ (range bounds_) $ \ (!x, !y) -> do { !v <- if y == minY then return 0 else readArray arr (y - 1, x); !diff <- readArray arr (y, x); writeArray arr (y, x) $! v + diff}; return arr};imos2DRev :: ((Int, Int), (Int, Int)) -> UArray (Int, Int) Int -> UArray (Int, Int) Int;imos2DRev !bounds_ !seeds = runSTUArray $ do { !arr <- newArray bounds_ (0 :: Int); let { (!minY, !minX) = fst bounds_}; let { (!maxY, !maxX) = snd bounds_}; forMS_ (rangeMSR minX maxX) $ \ x -> do { forMS_ (rangeMSR minY maxY) $ \ y -> do { !v <- if x == maxX then return 0 else readArray arr (y, x + 1); let { !diff = seeds ! (y, x)}; writeArray arr (y, x) $! v + diff}}; forMS_ (rangeMSR minX maxX) $ \ x -> do { forMS_ (rangeMSR minY maxY) $ \ y -> do { !v <- if y == maxY then return 0 else readArray arr (y + 1, x); !diff <- readArray arr (y, x); writeArray arr (y, x) $! v + diff}}; return arr};log2 :: (FiniteBits b) => b -> Int;log2 !x = finiteBitSize x - 1 - countLeadingZeros x;log2CeilInt :: Int -> Int;log2CeilInt !x = msb + ceiling_ where { !msb = log2 x; !ceiling_ = if clearBit x msb > 0 then 1 else 0};bitCeil :: Int -> Int;bitCeil = bit . log2CeilInt;addMod, subMod, mulMod :: Int -> Int -> Int -> Int;addMod !x !a !modulo = (x + a) `mod` modulo;subMod !x !s !modulo = (x - s) `mod` modulo;mulMod !b !p !modulo = (b * p) `mod` modulo;factMod :: Int -> Int -> Int;factMod 0 _ = 1; factMod 1 _ = 1; factMod !n !m = n * factMod (n - 1) m `rem` m;powModConst :: Int -> Int -> Int -> Int;powModConst !base !power !modulo = powModByCache power (powModCache (base `mod` modulo) modulo);invModF :: Int -> Int -> Int;invModF !d !modulo = invModFC modulo (powModCache d modulo);divModF :: Int -> Int -> Int -> Int;divModF !x !d !modulo = divModFC x (powModCache d modulo) `rem` modulo;powModCache :: Int -> Int -> (Int, VU.Vector Int);powModCache !base !modulo = (modulo, doubling) where { doubling = newDoubling base (\ x -> x * x `rem` modulo)};powModByCache :: Int -> (Int, VU.Vector Int) -> Int;powModByCache !power (!modulo, !cache) = foldl' step 1 [0 .. 62] where { step !acc !nBit = if testBit power nBit then acc * (cache VU.! nBit) `rem` modulo else acc};invModFC :: Int -> (Int, VU.Vector Int) -> Int;invModFC !primeModulo = powModByCache (primeModulo - 2);divModFC :: Int -> (Int, VU.Vector Int) -> Int;divModFC !x context@(!modulo, !_) = x * invModFC modulo context `rem` modulo;factMods :: Int -> Int -> VU.Vector Int;factMods !n !modulo = VU.scanl' (\ !x !y -> x * y `rem` modulo) (1 :: Int) $ VU.fromList [(1 :: Int) .. n];bcMod :: Int -> Int -> Int -> Int;bcMod !n !r !modulo = foldl' (\ !x !y -> divModF x y modulo) (facts VU.! n) [facts VU.! r, facts VU.! (n - r)] where { facts = factMods n modulo};prevPermutationVec :: (Ord e, VG.Vector v e, VG.Vector v (Down e)) => v e -> v e;prevPermutationVec = VG.map (\case { Down !x -> x}) . VG.modify (void . VGM.nextPermutation) . VG.map Down;dictOrderModuloVec :: (VG.Vector v Int) => v Int -> Int -> Int;dictOrderModuloVec xs modulo = runST $ do { !stree <- newSTreeVU (+) (VG.length xs + 1) (0 :: Int); let { !facts = factMods (VG.length xs) modulo}; !counts <- flip VG.imapM xs $ \ i x -> do { !nUsed <- fromJust <$> querySTree stree (0, x); let { !nUnused = x - nUsed}; let { !factMod = facts VG.! (VG.length xs - (i + 1))}; let { !inc = nUnused * factMod `rem` modulo}; insertSTree stree x 1; return inc}; return $! succ $! VG.foldl1' (\ !acc x -> (acc + x) `rem` modulo) counts};class TypeInt a where { typeInt :: Proxy a -> Int};newtype ModInt p = ModInt{toInt :: Int} deriving (Eq);instance Show (ModInt p) where { show = show . toInt};instance TypeInt p => Num (ModInt p) where { (ModInt !x1) + (ModInt !x2) = ModInt $! (x1 + x2) `mod` typeInt (Proxy @p); (ModInt !x1) * (ModInt !x2) = ModInt $! (x1 * x2) `mod` typeInt (Proxy @p); negate (ModInt !v) = ModInt $ (-v) `mod` typeInt (Proxy @p); abs = id; signum _ = 1; fromInteger = ModInt . fromInteger};instance TypeInt p => Fractional (ModInt p) where { recip (ModInt !x) = ModInt $! invModF x (typeInt (Proxy @p)); fromRational !r = ModInt n / ModInt d where { n = fromInteger $! Ratio.numerator r; d = fromInteger $! Ratio.denominator r}};instance (TypeInt p) => Enum (ModInt p) where { toEnum = ModInt . (`mod` typeInt (Proxy @p)); fromEnum = coerce};instance TypeInt p => SemigroupAction (Product (ModInt p)) (ModInt p) where { sact (Product !x1) !x2 = x1 * x2};newtype instance  VUM.MVector s (ModInt p) = MV_ModInt (VUM.MVector s Int);newtype instance  VU.Vector (ModInt p) = V_ModInt (VU.Vector Int);instance VU.Unbox (ModInt p);instance VGM.MVector VUM.MVector (ModInt p) where { basicLength (MV_ModInt v) = VGM.basicLength v; {-# INLINE basicLength #-}; basicUnsafeSlice i n (MV_ModInt v) = MV_ModInt $ VGM.basicUnsafeSlice i n v; {-# INLINE basicUnsafeSlice #-}; basicOverlaps (MV_ModInt v1) (MV_ModInt v2) = VGM.basicOverlaps v1 v2; {-# INLINE basicOverlaps #-}; basicUnsafeNew n = MV_ModInt <$> VGM.basicUnsafeNew n; {-# INLINE basicUnsafeNew #-}; basicInitialize (MV_ModInt v) = VGM.basicInitialize v; {-# INLINE basicInitialize #-}; basicUnsafeReplicate n x = MV_ModInt <$> VGM.basicUnsafeReplicate n (coerce x); {-# INLINE basicUnsafeReplicate #-}; basicUnsafeRead (MV_ModInt v) i = coerce <$> VGM.basicUnsafeRead v i; {-# INLINE basicUnsafeRead #-}; basicUnsafeWrite (MV_ModInt v) i x = VGM.basicUnsafeWrite v i (coerce x); {-# INLINE basicUnsafeWrite #-}; basicClear (MV_ModInt v) = VGM.basicClear v; {-# INLINE basicClear #-}; basicSet (MV_ModInt v) x = VGM.basicSet v (coerce x); {-# INLINE basicSet #-}; basicUnsafeCopy (MV_ModInt v1) (MV_ModInt v2) = VGM.basicUnsafeCopy v1 v2; {-# INLINE basicUnsafeCopy #-}; basicUnsafeMove (MV_ModInt v1) (MV_ModInt v2) = VGM.basicUnsafeMove v1 v2; {-# INLINE basicUnsafeMove #-}; basicUnsafeGrow (MV_ModInt v) n = MV_ModInt <$> VGM.basicUnsafeGrow v n; {-# INLINE basicUnsafeGrow #-}};instance VG.Vector VU.Vector (ModInt p) where { basicUnsafeFreeze (MV_ModInt v) = V_ModInt <$> VG.basicUnsafeFreeze v; {-# INLINE basicUnsafeFreeze #-}; basicUnsafeThaw (V_ModInt v) = MV_ModInt <$> VG.basicUnsafeThaw v; {-# INLINE basicUnsafeThaw #-}; basicLength (V_ModInt v) = VG.basicLength v; {-# INLINE basicLength #-}; basicUnsafeSlice i n (V_ModInt v) = V_ModInt $ VG.basicUnsafeSlice i n v; {-# INLINE basicUnsafeSlice #-}; basicUnsafeIndexM (V_ModInt v) i = coerce <$> VG.basicUnsafeIndexM v i; {-# INLINE basicUnsafeIndexM #-}; basicUnsafeCopy (MV_ModInt mv) (V_ModInt v) = VG.basicUnsafeCopy mv v; elemseq _ = seq; {-# INLINE elemseq #-}};data RollingHash b p = RollingHash{sourceLength :: !Int, dimensions :: !(VU.Vector Int), hashSum :: !(VU.Vector Int)} deriving (Show, Eq);data HashInt = HashInt;instance TypeInt HashInt where { typeInt _ = 100};newRH :: forall p . TypeInt p => String -> RollingHash HashInt p;newRH !source = RollingHash n bn hashSum_ where { !p = typeInt (Proxy @p); !b = typeInt (Proxy @HashInt); !n = length source; !bn = VU.iterateN (succ n) (\ lastB -> b * lastB `mod` p) (1 :: Int); !hashSum_ = evalState (VU.mapM (\ !ch -> state $ \ !acc -> f ch acc) $ VU.fromList source) (0 :: Int) where { f :: Char -> Int -> (Int, Int); f !ch !lastX = dupe $! (lastX * b + ord ch) `mod` p}};lengthRH :: RollingHash b p -> Int;lengthRH (RollingHash !len !_ !_) = len;data HashSlice p = HashSlice{hashValue :: {-# UNPACK #-} !Int, hashLength :: {-# UNPACK #-} !Int} deriving (Show, Eq);sliceRH :: forall b p . (TypeInt p) => RollingHash b p -> Int -> Int -> HashSlice p;sliceRH (RollingHash !_ !bn !s) !i0 !i1 | i0 > i1 = emptyHS | otherwise = let { !len = i1 - i0 + 1; !s1 = s VU.! i1; !s0 = fromMaybe 0 $ s VU.!? pred i0; !value = (s1 - (bn VU.! len) * s0) `mod` p} in HashSlice value len where { !p = typeInt (Proxy @p)};consHS :: forall b p . (TypeInt p) => RollingHash b p -> HashSlice p -> HashSlice p -> HashSlice p;consHS (RollingHash !_ !bn !_) (HashSlice !v0 !l0) (HashSlice !v1 !l1) = HashSlice value len where { !p = typeInt (Proxy @p); !value = ((bn VU.! l1) * v0 + v1) `mod` p; !len = l0 + l1};emptyHS :: HashSlice p;emptyHS = HashSlice 0 0;concatHS :: forall b p t . (TypeInt p, Foldable t) => RollingHash b p -> t (HashSlice p) -> HashSlice p;concatHS !rhash !slices = foldl' (consHS rhash) emptyHS slices;mulMatToCol :: (Num e, IArray UArray e) => UArray (Int, Int) e -> [e] -> [e];mulMatToCol !mat !col = let { !rows = chunksOf n (elems mat)} in map (sum . zipWith (*) col) rows where { !n = length col; !_ = dbgAssert $ (== n) . succ . fst . snd $ bounds mat};mulMat :: (Num e, IArray UArray e) => UArray (Int, Int) e -> UArray (Int, Int) e -> UArray (Int, Int) e;mulMat !a !b = listArray @UArray ((i0, k0), (ix, kx)) [sum [a ! (i, j) * b ! (j', k) | (j, j') <- zip (range (j0, jx)) (range (j'0, j'x))] | i <- range (i0, ix), k <- range (k0, kx)] where { ((!i0, !j0), (!ix, !jx)) = bounds a; ((!j'0, !k0), (!j'x, !kx)) = bounds b; !_ = dbgAssert (jx - j0 == j'x - j'0)};mulMatMod :: Int -> UArray (Int, Int) Int -> UArray (Int, Int) Int -> UArray (Int, Int) Int;mulMatMod m a b = listArray @UArray ((i0, k0), (ix, kx)) [sum [a ! (i, j) * b ! (j', k) `mod` m | (j, j') <- zip (range (j0, jx)) (range (j'0, j'x))] `mod` m | i <- range (i0, ix), k <- range (k0, kx)] where { ((!i0, !j0), (!ix, !jx)) = bounds a; ((!j'0, !k0), (!j'x, !kx)) = bounds b; !_ = dbgAssert (jx - j0 == j'x - j'0)};unitMat :: Int -> UArray (Int, Int) Int;unitMat !n = accumArray @UArray (+) (0 :: Int) ((0, 0), (pred n, pred n)) $ map ((, 1) . dupe) [0 .. pred n];newtype MulMatMod a = MulMatMod (UArray (Int, Int) Int) deriving (Eq, Show);instance forall p . TypeInt p => Semigroup (MulMatMod p) where { (MulMatMod !m1) <> (MulMatMod !m2) = MulMatMod $ mulMatMod (typeInt (Proxy @p)) m1 m2};rot45 :: (Int, Int) -> (Int, Int);rot45 (!x, !y) = (x - y, x + y);mDigitsRev :: Integral n => n -> n -> Maybe [n];mDigitsRev !base !i = if base < 1 then Nothing else Just $ dr base i where { dr _ 0 = []; dr !b !x = case base of { 1 -> genericTake x $ repeat 1; _ -> let { (!rest, !lastDigit) = quotRem x b} in lastDigit : dr b rest}};mDigits :: Integral n => n -> n -> Maybe [n];mDigits !base !i = reverse <$> mDigitsRev base i;digitsRev :: Integral n => n -> n -> [n];digitsRev !base = fromJust . mDigitsRev base;digits :: (Integral n) => n -> n -> [n];digits _ 0 = [0]; digits !base !x = reverse $ digitsRev base x;unDigits :: Integral n => n -> [n] -> n;unDigits !base = foldl' (\ !a !b -> a * base + b) 0;convertBase :: Integral a => a -> a -> [a] -> [a];convertBase !from !to = digits to . unDigits from;primes :: [Int];primes = 2 : 3 : minus [5, 7 ..] (unionAll [[p * p, p * p + 2 * p ..] | p <- tail primes]) where { minus (x : xs) (y : ys) = case compare x y of { LT -> x : minus xs (y : ys); EQ -> minus xs ys; GT -> minus (x : xs) ys}; minus xs _ = xs; union (x : xs) (y : ys) = case compare x y of { LT -> x : union xs (y : ys); EQ -> x : union xs ys; GT -> y : union (x : xs) ys}; union xs [] = xs; union [] ys = ys; unionAll :: Ord a => [[a]] -> [a]; unionAll ((x : xs) : t) = x : union xs (unionAll $ pairs t) where { pairs ((x : xs) : (ys : t)) = (x : union xs ys) : pairs t}; unionAll _ = error "unionAll: unreachable"};primeFactors :: Int -> [(Int, Int)];primeFactors !n_ = map (\ !xs -> (head xs, length xs)) . group $ inner n_ input where { input = 2 : 3 : [y | x <- [5, 11 ..], y <- [x, x + 2]]; inner n pps@(p : ps) | n == 1 = [] | n < p * p = [n] | r == 0 = p : inner q pps | otherwise = inner n ps where { (q, r) = divMod n p}; inner _ _ = error "unreachable"};divisorsOf :: Int -> [Int];divisorsOf n = sort $ inner 1 where { inner k | k * k > n = [] | k * k == n = [k] | r == 0 = k : d : inner (succ k) | otherwise = inner (succ k) where { (!d, !r) = n `divMod` k}}
{- ORMOLU_ENABLE -}
-- }}}

data MyModulo = MyModulo

instance TypeInt MyModulo where
  -- typeInt _ = 1_000_000_007
  typeInt _ = 998244353

type MyModInt = ModInt MyModulo

modInt :: Int -> MyModInt
modInt = ModInt . (`mod` typeInt (Proxy @MyModulo))

undef :: Int
undef = -1

main :: IO ()
main = do
  !n <- int
  !input <- VU.replicateM n ints3

  -- edges @! (vTo, vFrom) -> cost
  let !edges = IxVector (both dupe (0, n - 1)) . VU.generate (n * n) $ \i ->
        let (!v2, !v1) = i `divMod` n
            (!x1, !y1, !z1) = input VU.! v1
            (!x2, !y2, !z2) = input VU.! v2
            !w = abs (x1 - x2) + abs (y1 - y2) + max 0 (z2 - z1)
         in w

  let !undefCost = maxBound @Int

  -- N' = 2^17 = 131072 ~ 10^5. N * N' seems to be safe.
  let !nSets = bit n :: Int

  -- TODO: Refactor
  let !tsp = VU.constructN (n * nSets) f
        where
          f !vec
            -- initially at vertex zero
            | VU.length vec < 2 * n =
                if VU.length vec == n then 0 else undefCost
            -- unvisitable
            | not (testBit s v2) = undefCost
            -- relax
            | otherwise =
                let !s' = clearBit s v2
                    g !v1 !acc
                      | not (testBit s v1) || acc == undefCost = undefCost
                      | otherwise = acc + (edges @! (v2, v1))
                 in VU.minimum $ VU.imap g (VU.slice (n * s') n vec)
            where
              (!s, !v2) = (vLength vec) `divMod` n

  let !_ = dbg (tsp)

  let !finals = VU.slice (n * pred nSets) n tsp
  let !results = flip VU.imap finals \v2 acc -> acc + edges @! (0, v2)

  print $ VU.minimum results

Submission Info

Submission Time	2023-08-04 23:29:18+0900
Task	E - Traveling Salesman among Aerial Cities
User	toyboot4e
Language	Haskell (GHC 8.8.3)
Score	500
Code Size	83680 Byte
Status	AC
Exec Time	194 ms
Memory	23052 KiB

Compile Error

Loaded package environment from /home/contestant/.ghc/x86_64-linux-8.8.3/environments/default

Judge Result

Set Name

Sample

All

Score / Max Score

0 / 0

500 / 500

Status

× 3

× 23

Set Name	Test Cases
Sample	sample_01.txt, sample_02.txt, sample_03.txt
All	random_01.txt, random_02.txt, random_03.txt, random_04.txt, random_05.txt, random_06.txt, random_07.txt, random_08.txt, random_09.txt, random_10.txt, random_11.txt, random_12.txt, random_13.txt, random_14.txt, random_15.txt, random_16.txt, random_17.txt, random_18.txt, random_19.txt, random_20.txt, sample_01.txt, sample_02.txt, sample_03.txt

Case Name	Status	Exec Time	Memory
random_01.txt	AC	193 ms	22812 KiB
random_02.txt	AC	2 ms	4288 KiB
random_03.txt	AC	193 ms	22932 KiB
random_04.txt	AC	189 ms	22928 KiB
random_05.txt	AC	188 ms	22940 KiB
random_06.txt	AC	3 ms	4132 KiB
random_07.txt	AC	193 ms	22824 KiB
random_08.txt	AC	24 ms	7272 KiB
random_09.txt	AC	191 ms	23052 KiB
random_10.txt	AC	3 ms	4304 KiB
random_11.txt	AC	194 ms	22928 KiB
random_12.txt	AC	6 ms	4580 KiB
random_13.txt	AC	194 ms	22932 KiB
random_14.txt	AC	2 ms	4292 KiB
random_15.txt	AC	191 ms	22812 KiB
random_16.txt	AC	15 ms	6196 KiB
random_17.txt	AC	192 ms	22892 KiB
random_18.txt	AC	15 ms	6068 KiB
random_19.txt	AC	189 ms	22908 KiB
random_20.txt	AC	27 ms	7424 KiB
sample_01.txt	AC	2 ms	4316 KiB
sample_02.txt	AC	2 ms	4356 KiB
sample_03.txt	AC	191 ms	22840 KiB