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: Wrong Answer)

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..]
        (rel,cor) = matchColors $ listJointColors prev curr'
        curr'' = correctColors cor curr'
        num' = num + countFixedColors rel prev

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)]

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

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

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

countFixedColors :: ColorRelation -> [(Span,Color)] -> Int
countFixedColors rel ps = Set.size (colors Set.\\ mapped)
    where
    colors = foldr Set.insert Set.empty (map snd ps)
    mapped = foldr Set.insert Set.empty (Map.keys rel)