Problem:
ペンキの色

問題

情報オリンピックの宣伝のために,長方形のベニヤ板にペンキを塗り看板を制作したい.ベニヤ板には色を塗りたくないところにあらかじめ何枚かの長方形のマスキングテープが貼られている.そこでマスキングテープで区切られた領域ごとに別々の色を使いペンキを塗ることにした.例えば,図 5-1 の場合は 5 色のペンキを使う.

入力としてマスキングテープを貼る位置が与えられた時,使うペンキの色の数を求めるプログラムを作成せよ.ただし,ベニヤ板全体がマスキングテープで覆われることはなく,全てのマスキングテープの辺はベニヤ板のいずれかの辺に平行である.

入力

入力は複数のデータセットからなる．各データセットは以下の形式で与えられる．

1 行目にはベニヤ板の幅 w (1 ≤ w ≤ 1000000 となる整数) と高さ h (1 ≤ h ≤ 1000000 となる整数) がこの順に空白区切りで書かれている.

2 行目にはマスキングテープの数 n (1 ≤ n ≤ 1000 となる整数) が書かれている.
続く 3 行目以降の 2 + i 行目 (1 ≤ i ≤ n) には,i 番目に貼るマスキングテープの左下の座標 (x1 , y1 ) と,右上の座標 (x2 , y2 ) が x1 , y1 , x2 , y2 (0 ≤ x1 < x2 ≤ w, 0 ≤ y1 < y2 ≤ h となる整数) の順に空白区切りで書かれている.

ただし,ベニヤ板の左下の角の座標は (0, 0) で右上の角の座標は (w, h) である. 採点用データのうち, 配点の 30% 分は w ≤ 100, h ≤ 100, n ≤ 100 を満たす.

h, w がともに 0 のとき入力の終了を示す. データセットの数は 20 を超えない．

出力

データセットごとに使うペンキの色数を１行に出力する.

入出力例

次の例は図 5-1 の場合である.

入力例

15 6
10
1 4 5 6
2 1 4 5
1 0 5 1
6 1 7 5
7 5 9 6
7 0 9 2
9 1 10 5
11 0 14 1
12 1 13 5
11 5 14 6
0 0

出力例

5

上記問題文と自動審判に使われるデータは、情報オリンピック日本委員会が作成し公開している問題文と採点用テストデータです。

Solution in Haskell (judge verdict: Accepted)

import Control.Monad (replicateM)
import Data.List (sort)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

type Rect = (Int,Int,Int,Int)
type Span = (Int,Int)
type Color = Int
type ColorRelation = Map.Map Int Int
type ColorCorrection = Map.Map Int Int

main = do
    [w,h] <- getLine >>= return . map read . words
    if all (==0) [w,h] then return () else do
        n <- readLn
        rs <- replicateM n (getLine >>= return . rect . map read . words)
        print $ solve w h rs
        main
    where
    rect [x1,y1,x2,y2] = (x1,y1,x2,y2)

solve :: Int -> Int -> [Rect] -> Int
solve w h rs = step [] (blankSpansSeq ++ [[]]) 0
    where
    rs' = sort rs

    blankSpansSeq :: [[Span]]
    blankSpansSeq = rs' `seq` map (listBlankSpans w rs') (listScanYs h rs)

    step :: [(Span,Color)] -> [[Span]] -> Int -> Int
    step [] [] num = num

    step prev (curr:spans) num = step curr'' spans num'
        where
        curr' = zip curr [1..]
        joints = listColorJoints prev curr'
        cor = matchColors joints
        curr'' = correctColors cor curr'
        num' = num + Set.size ((setOf (map snd prev)) Set.\\ setOf (map fst joints))

    setOf = foldr Set.insert Set.empty

listScanYs :: Int -> [Rect] -> [Int]
listScanYs h rs = filter' $ 0 : (sort $ concatMap (\(_,y1,_,y2) -> [y1,y2]) rs)
    where
    filter' (y:[])
        | y < h = [y]
        | otherwise = []
    filter' (y1:y2:ys)
        | y1 < y2 = y1 : filter' (y2:ys)
        | otherwise = filter' (y2:ys)

listRectSpans :: [Rect] -> Int -> [Span]
-- assumes rects are sorted by x1
listRectSpans rs y = merge $ map (\(x1,_,x2,_) -> (x1,x2)) $ filter cross rs
    where
    cross (_,y1,_,y2) = y1 <= y && y < y2
    merge [] = []
    merge ((x1,x2):[]) = [(x1,x2)]
    merge ((x1,x2):(x3,x4):ps)
        | x2 < x3 = (x1,x2) : merge ((x3,x4):ps)
        | otherwise = merge ((x1,max x2 x4):ps)

listBlankSpans :: Int -> [Rect] -> Int -> [Span]
listBlankSpans w rs y = blank' ((0,0) : listRectSpans rs y)
    where
    blank' ((0,0):(0,x):ps) = blank' ((0,x):ps)
    blank' ((x1,x2):(x3,x4):ps) = (x2,x3) : blank' ((x3,x4):ps)
    blank' ((x1,x2):[])
        | x2 == w = []
        | otherwise = [(x2,w)]

listColorJoints :: [(Span,Color)] -> [(Span,Color)] -> [(Color,Color)]
listColorJoints [] _ = []
listColorJoints _ [] = []
listColorJoints ps1@(((b1,e1),c1):ps1') ps2@(((b2,e2),c2):ps2')
    | e1 <= b2 = listColorJoints ps1' ps2
    | e2 <= b1 = listColorJoints ps1 ps2'
    | e1 <= e2 = (c1,c2) : listColorJoints ps1' ps2
    | e1 >  e2 = (c1,c2) : listColorJoints ps1 ps2'

matchColors :: [(Color,Color)] -> ColorCorrection
matchColors cps = matchColors' cps Map.empty Map.empty
    where
    matchColors' [] _ cor = cor
    matchColors' ((c1,c2):cps) rel cor = matchColors' cps rel' cor'
        where
        rel' = case Map.lookup c1 rel of
                Nothing -> Map.insert c1 c2 rel
                Just c0 -> case Map.lookup c2 cor of
                        Nothing -> rel
                        Just c0' -> Map.map (replace c0' c0) rel
        cor' = case Map.lookup c1 rel of
                Nothing -> cor
                Just c0 -> case Map.lookup c2 cor of
                        Nothing -> Map.insert c2 c0 cor
                        Just c0' -> Map.insert c0' c0 (Map.map (replace c0' c0) cor)
        replace x x' = \y -> if y == x then x' else y


correctColors :: ColorCorrection -> [(Span,Color)] -> [(Span,Color)]
correctColors cor [] = []
correctColors cor ((s,c):ps) = case Map.lookup c cor of
        Nothing -> (s,c)  : correctColors cor ps
        Just c' -> (s,c') : correctColors cor ps