Left-Leaning Red-Black Tree part2

前回の Left-Leaning Red-Black (LLRB) Tree の Haskell のコードがきちんと動くことを大体確認した. HaskellのData.Setと比べた特徴は以下の通り.

• insert と member は LLRB の方が早い.
  
• delete は Data.Set の方が早い.
  

今後の課題としては, Data.Set にある集合演算を LLRB で実装するのも面白いかも.

LLRB の delete を Data.Set よりも早くしようと試行錯誤したがうまくいかなかった. Haskell のチューニングの難しさを実感した. なかなか直感通りにいかなくて大変だ.

Left-Leaning Red-Black Tree

Left-Leaning Red-Black Tree [PDF] というのを見つけて, 実装が簡単だと書いてあったので, 最近練習中のHaskellで書いてみた. PDF に所々ミスがあるし, Haskell に慣れてないのもあって, あんまり簡単ではなかった. まだきちんと検証もしていないがさらしてみる. とりあえず, delete が member でない要素を与えられたときにエラーを返すのは仕様. deleteはPDFに載っているのとは少し変える必要があった上に, 書き直しにかなり悩んだので間違っているかも.

module Main where

data Color = Red | Black deriving (Show, Eq)
data LLRB a = Null | Branch !Color !(LLRB a) a !(LLRB a) deriving (Show)

member :: Ord a => a -> LLRB a -> Bool
member _ Null = False
member x (Branch c l y r) =
    case compare x y of
 LT -> member x l
 GT -> member x r
 EQ -> True

null :: LLRB a -> Bool
null Null = True
null _   = False

empty :: LLRB a
empty = Null

singleton :: a -> LLRB a
singleton x = Branch Red Null x Null

insert :: Ord a => a -> LLRB a -> LLRB a
insert x root = make_black $ insert' x root

insert' :: Ord a => a -> LLRB a -> LLRB a
insert' x Null = singleton x
insert' x h@(Branch _ (Branch Red _ _ _) _ (Branch Red _ _ _)) = insert' x $ colorFlip h
insert' x h@(Branch c l y r) =
    f2 $ f1 $ case compare x y of
 LT -> Branch c (insert' x l) y r
 GT -> Branch c l y (insert' x r)
 EQ -> h
    where 
    f1 t@(Branch _ _ _ (Branch Red _ _ _)) = rotateL t
    f1 t = t
    f2 t@(Branch _ (Branch Red (Branch Red _ _ _) _ _) _ _) = rotateR t
    f2 t = t

findMin :: LLRB a -> a
findMin (Branch _ Null x r) = x
findMin (Branch _ l x r) = findMin l
findMin Null = error "LLRB.findMin: empty tree has no minimal element"

findMax :: LLRB a -> a
findMax (Branch _ l x Null) = x
findMax (Branch _ l x r) = findMax r
findMax Null = error "LLRB.findMax: empty tree has no minimal element"

deleteMax :: LLRB a -> LLRB a
deleteMax root = make_black $ deleteMax' root where

deleteMax' :: LLRB a -> LLRB a
deleteMax' h = let t' = apply_rotR h in
    if isRightNull t' then Null else (fixUp . f . apply_mRR) t' where
    f (Branch c l x r) = Branch c l x (deleteMax' r)

deleteMin :: LLRB a -> LLRB a
deleteMin root = make_black $ deleteMin' root where

deleteMin' :: LLRB a -> LLRB a
deleteMin' (Branch _ Null _ _) = Null
deleteMin' h = (fixUp . f . apply_mRL) h
    where
    f (Branch c l x r) = Branch c (deleteMin' l) x r

delete :: Ord a => a -> LLRB a -> LLRB a
delete x root = make_black $ delete' x root

data NodeCond = NLeft | NRight | NBottom

delete' :: Ord a => a -> LLRB a -> LLRB a
delete' _ Null = error "LLRB.delete: element is not the member"
delete' x h@(Branch c l y r) =
    fixUp $ case compare x y of
 LT -> (f . apply_mRL) h
     where
     f (Branch c l y r) = Branch c (delete' x l) y r
 GT -> (f . apply_mRR . apply_rotR) h
     where
     f (Branch c l y r) = Branch c l y (delete' x r)
 EQ -> case nodecond h of
     NBottom -> Null
     NLeft -> let z = apply_mRL h in
  if eq x z then delleft z else delete' x z
     NRight -> let z = (apply_mRR . apply_rotR) h in
  if eq x z then delright z else delete' x z
     where
     eq a (Branch _ _ b _) = a == b
     nodecond (Branch _ Null _ Null) = NBottom
     nodecond (Branch _ (Branch _ _ _ _) _ _) = NLeft
     nodecond (Branch _ _ _ (Branch _ _ _ _)) = NRight
     delleft  (Branch c' l' x' r') = Branch c' (deleteMax' l') (findMax l') r'
     delright (Branch c' l' x' r') = Branch c' l' (findMin r') (deleteMin' r')

--
-- Helper
--
apply_mRL t@(Branch _ (Branch Red _ _ _) _ _) = t
apply_mRL t@(Branch _ (Branch _ (Branch Red _ _ _) _ _) _ _) = t
apply_mRL t = moveRedLeft t

apply_mRR t@(Branch _ _ _ (Branch Red _ _ _)) = t
apply_mRR t@(Branch _ _ _ (Branch _ (Branch Red _ _ _) _ _)) = t
apply_mRR t = moveRedRight t

apply_rotR t@(Branch _ (Branch Red _ _ _) _ _) = rotateR t
apply_rotR t = t

isRightNull t@(Branch _ _ _ Null) = True
isRightNull t = False

make_black :: LLRB a -> LLRB a
make_black (Branch _ l x r) = Branch Black l x r
make_black Null = Null

fixUp :: LLRB a -> LLRB a
fixUp = f3 . f2 . f1 where
    f1 t@(Branch _ _ _ (Branch Red _ _ _)) = rotateL t
    f1 t = t
    f2 t@(Branch _ (Branch Red (Branch Red _ _ _) _ _) _ _) = rotateR t
    f2 t = t
    f3 t@(Branch _ (Branch Red _ _ _) _ (Branch Red _ _ _)) = colorFlip t
    f3 t = t

moveRedRight :: LLRB a -> LLRB a
moveRedRight h = f $ colorFlip h where
    f t@(Branch _ (Branch _ (Branch Red _ _ _) _ _) _ _) = colorFlip $ rotateR t
    f t = t

moveRedLeft :: LLRB a -> LLRB a
moveRedLeft h = f $ colorFlip h where
    f (Branch c l x r@(Branch _ (Branch Red _ _ _) _ _)) = colorFlip $ rotateL $ Branch c l x (rotateR r)
    f t = t

colorFlip :: LLRB a -> LLRB a
colorFlip (Branch c (Branch c1 l1 x1 r1) x (Branch c2 l2 x2 r2)) =
    Branch (fl c) (Branch (fl c1) l1 x1 r1) x (Branch (fl c2) l2 x2 r2)
    where
    fl Red = Black
    fl Black = Red
colorFlip _ = error "LLRB.colorFlip: tree must have 3 nodes at least"

rotateL :: LLRB a -> LLRB a
rotateL (Branch c l x (Branch c' l' x' r')) =
    Branch c (Branch Red l x l') x' r'
rotateL _ = error "LLRB.rotateL: tree must have 2 nodes at least"

rotateR :: LLRB a -> LLRB a
rotateR (Branch c (Branch c' l' x' r') x r) =
    Branch c l' x' (Branch Red r' x r)
rotateR _ = error "LLRB.rotateR: tree must have 2 nodes at least"

     
-- 
-- test 
--

tree :: Int -> LLRB Int
tree 0 = empty
tree (n+1) = insert (n+1) (tree n)

main :: IO ()
main = do
    print $ member 1 $ (iterate deleteMax (tree 100000)) !! 100000

円の交差判定2

新しいテーマを考えなければならないんだけど, いいネタが思い浮かばないので, 前々から思っていたアイデアをいろいろ実装して円の交差判定の高速化を試した. 走査線法とバケットソートの組み合わせ. 理論的には, オーダーの改善はできていないけど, 簡単な実験の結果だと, 単純にバウンディングボックスのみを使う場合に比べて, 数倍から数十倍の改善が見られたの満足. 教授にこれを報告しよう.

円の交差判定

今の研究の中で大切なパートとして, 「円の交差列挙問題」がある.

n枚の円が与えられた時に, 交差する円のペアを全て列挙する. (ただし, 円の半径は異なってもよい)

Preparata & Shamosの本によると, 交差するペアの数をKとしたとき, 下界はΩ(n log n + K)になる. 現在僕が困っているのは, この最適なオーダーのアルゴリズムが知られているかどうかということ. この本には, 長方形の場合の最適なオーダーのアルゴリズムが紹介されている. また, 線分の場合はBalabanによって記憶量的にも最適なオーダーのアルゴリズムが提案されている.

ところが, 円の場合の最適なオーダーのアルゴリズムが見つからない. それっぽいキーワードでググっても, 別の問題の話ばかりなのだ. 仕方なく, 簡単なアルゴリズムを考えて実装してみた. 計算量はO(n^2)でナイーブな場合と変わらないけど, 実験では数倍早くなった. なんかめっちゃ地味なことしてるわ.