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

Firefoxの反応が遅い

最近, 研究室用のマシンの FreeBSD 7-stable 上の linux-firefox の反応が遅くなった. Ctrl-T で新しいタブを作成しようとしても, キーを押してからタブができるまでに数秒のタイムラグが発生するのだ. ちょっとしたら, どこかで修正されるかなと思って我慢していたけど, 改善されないので, 諦めて 6-stable に戻った. 6-stable 上ならキビキビ動く. ちなみに, 後輩の Debian 上の Firefox でも同様の現象が起きていた. Linux用の Firefox 特有の問題なのだろうか.

あと, 後輩にC言語のコールグラフを生成する方法を聞かれたので, 調べてみたら gprof2dot というのを見つけた. なかなか便利そうだ.