https://torus711.hatenablog.com/entry/2025/03/13/205008

実装中心で．テンプレは別記事．

A

　問題文 : https://atcoder.jp/contests/abc396/tasks/abc396_a
　group でリスト内で隣接する等価な要素を一つのリストにまとめたリストを作れる（Run Length 符号化みたいなこと．型で言うと [a] -> [[a]]）ので，この中に長さ $3$ 以上のリストがあるかどうかを調べればよいです．

main = getLine >> readInts >>= putStrLn . yesno . not . null . filter ( 3 <= ) . map length . group

B

　問題文 : https://atcoder.jp/contests/abc396/tasks/abc396_b
　スタックをシミュレートしろという問題ですが，先頭への操作が高速であればよいということで，リストをスタック代わりにできます．クエリの読み出しとリストの読み出しはパターンマッチで．

main = readInt >>= flip replicateM readInts >>= mapM_ print . reverse . snd . foldl' solve ( ( replicate 100 0 ), [] )

solve ( stack, res ) [ 1, x ] = ( ( x : stack ), res )
solve ( ( x : stack ), res ) [ 2 ] = ( stack, ( x : res ) )

C

　問題文 : https://atcoder.jp/contests/abc396/tasks/abc396_c
　どちらの色のボールも価値の降順に採用する方が損しないので最初にソートします．黒いボールの内で価値が非負なものの個数を $k$ とすると，白いボールを $j$ 個採用したときの黒いボールの個数は $\max( k, j )$ 個にするのがよい（$j \leq k$ なら価値が非負の黒いボールを追加できて，そうでないなら価値が負の黒いボールしか余ってない）です．
　それぞれ累積和を取ってから配列にしておけば，個数を決めたときの価値の和を $O( 1 )$ 時間で参照できるので，白いボールの個数をすべて試せます．

main = do
	[ n, m ] <- readInts
	[ bs, ws ] <- map ( reverse . sort ) <$> replicateM 2 readInts
	let
		k = length $ takeWhile ( 0 <= ) $ bs
		ps_b = listArray ( 0, n ) $ scanl' (+) 0 bs
		ps_w = listArray ( 0, m ) $ scanl' (+) 0 ws
	print $ maximum $ do
		j <- [ 0 .. m ]
		let i = max k j
		guard $ i <= n
		return $ ( ps_b ! i ) + ( ps_w ! j )

D

　問題文 : https://atcoder.jp/contests/abc396/tasks/abc396_d
　入力が小さいので，頂点 $1$ を始点とするパスすべてを DFS で探しても間に合います．
　accumArray で隣接リストを作ってから，訪問済み頂点をリストで管理（これも入力が小さいので雑なやり方でよい）しながら DFS します．ビット演算は Data.Bits にある~~見た目がキモい~~演算子で．

main = do
	[ n, m ] <- readInts
	es <- concatMap ( \[ u, v, w ] -> [ ( u, ( v, w ) ), ( v, ( u, w ) ) ] ) <$> replicateM m readInts
	let
		g = accumArray ( flip (:) ) [] ( 1, n ) es
	print $ minimum $ solve g [] 0 1

solve g visited s u
	| u `elem` visited = []
	| u == n = [s]
	| otherwise = concat $ do
		( v, w ) <- g ! u
		return $ solve g ( u : visited ) ( s .^. w ) v
	where
	( _, n ) = bounds g

E

　問題文 : https://atcoder.jp/contests/abc396/tasks/abc396_e
　XOR はビット毎に独立で，$Z_i$ が $1$ ビットの問題なら一つの頂点の値を決めるとそれに連結な頂点の値も自動で決まります．なので，連結成分毎に $2$ 通りある色の決め方の内最適な方を選び，最後に集計します（矛盾する場合は -1）．
　答えを [[Maybe Int]] にしておいて map foldl1 → sequence → fromMaybe すると集計部分はいい感じになりましたが，TLE を連発したので細かいところで遅くならないように色々直しました：

双方向の辺を張るために \x y z -> [ ( x, ( y, z ) ), ( y, ( x z ) ) ] を concatMap すると遅いので，片向きずつ accumArray と accum で作る
着目するビットごとにグラフを作ると遅いので，隣接頂点に塗る色を計算するときにビット演算
矛盾する頂点が発生したら（最悪時のオーダーは同じだが）やめる

main = do
	[ n, m ] <- readInts
	when ( m == 0 ) $ do
		printList $ replicate n 0
		exitSuccess
	[ xs, ys, zs ] <- transpose <$> replicateM m readInts
	let
		f = ( flip (:) )
		edges xs ys zs = do
			( x, y, z ) <- zip3 xs ys zs
			return $ ( x, ( y, z ) )
		g = let g' = accumArray f [] ( 1, n ) $ edges xs ys zs in accum f g' $ edges ys xs zs
	printList $ fromMaybe [-1] $ sequence $ map ( foldl1' ( liftM2 (.|.) ) ) $ transpose $ map elems $ map ( solve g ) [ 0 .. 30 ]

solve g b = runSTArray $ do
	res <- newArray ( 1, n ) Nothing :: ST s ( STArray s Int ( Maybe Int ) )
	color <- newArray ( 1, n ) (-1) :: ST s ( STUArray s Int Int )
	forM_ [ 1 .. n ] $ \u -> do
		c <- readArray color u
		when ( c == -1 ) $ do
			ok <- newSTRef True
			zeros <- newSTRef []
			ones <- newSTRef []
			let
				dfs u c = do
					ok' <- readSTRef ok
					when ( ok' ) $ do
						c' <- readArray color u
						if c' /= -1
							then -- do
								modifySTRef ok ( && ( c' == c ) )
							else do
								writeArray color u c
								modifySTRef ( if c == 0 then zeros else ones ) ( u : )
								forM_ ( g ! u ) $ \( v, w ) -> do
									let w' = ( 1 .&. ( w `shiftR` b ) ) in dfs v ( c .^. w' )
			dfs u 0
			ok' <- readSTRef ok
			when ( ok' ) $ do
				zeros' <- readSTRef zeros
				ones' <- readSTRef ones
				let ( l1, l0 ) = if length zeros' <= length ones' then ( zeros', ones' ) else ( ones', zeros' )
				forM_ l1 $ \v -> do
					writeArray res v ( Just $ 1 `shiftL` b )
				forM_ l0 $ \v -> do
					writeArray res v ( Just 0 )
	return res
	where
	( _, n ) = bounds g