fgl は versatile (たとえ TLE でも) その２

競プロ典型 90 問 77 日目 - Planes on a 2D Plane（★7）

import Control.Arrow
import Control.Monad
import qualified Data.ByteString.Char8 as C
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.Graph.Inductive.Query.MaxFlow
import Data.List
import Data.Maybe

main = ints >>= \[n,t] -> replicateM (2*n) ints >>= fmt . sol n t

ints = unfoldr (C.readInt . C.dropWhile (==' ')) <$> C.getLine

fmt Nothing   = putStrLn "No"
fmt (Just ds) = putStrLn "Yes" >> (putStrLn . unwords $ map show ds)

sol n t as = if ok then Just ds else Nothing
  where
  ns = (0,(-1,-1)):(2*n+1,(10^10+1,10^10+1)):zipWith (\i [x,y] -> (i,(x,y))) [1..2*n] as
  es = concatMap (\i -> [(0,i,1),(i+n,2*n+1,1)]) [1..n]
  g = mkGraph ns es :: Gr (Int,Int) Int
  dt = map ((* t) *** (* t)) [(1,0),(1,1),(0,1),(-1,1),(-1,0),(-1,-1),(0,-1),(1,-1)]
  es' = catMaybes $ mkEdge <$> [1..n] <*> [n+1..2*n]
  mkEdge i j = if any (\(dx,dy) -> dx==x'-x && dy==y'-y) dt then Just (i,j,1) else Nothing
    where
    (x,y) = (fromJust . lab g) i
    (x',y') = (fromJust . lab g) j
  g' = insEdges es' g
  g'' = maxFlowgraph g' 0 (2*n+1)
  ok = and . map ((==1) . fst . snd) $ lsuc g'' 0
  ds = map (f g'') [1..n]
  f g i = maybe 0 succ $ find ((==(x'-x,y'-y)) . (dt!!)) [0..7]
    where
    (x,y) = fromJust $ lab g i
    (x',y') = fromJust $ lab g j
    j = fst . fromJust . find ((==1) . fst . snd) $ lsuc g i