Old/sampou.org/Programming_玉手箱_その他
Programming_玉手箱_その他
Programming:玉手箱:その他
関数型表
関数型の表(Table)。結構、味があるとおもいません？
type Table k v = k -> Maybe v
emptyTable :: Table k v
emptyTable = const Nothing
lookup :: Table k v -> k -> Maybe v
lookup = id
insert :: Eq k => Table k v -> (k,v) -> Table k v
insert tbl (k,v) key = if k == key then Just v else tbl key
remove :: Eq k => Table k v -> k -> Table k v
remove tbl k key = if k == key then Nothing else tbl key上向きにも辿れる木
zipper代わりに。– yts
import Data.Maybe (isJust, fromJust)
data Tree a = Tree a [Tree a] deriving Show
data TreeP a = TreeP { parent :: Maybe (TreeP a), value :: a, children :: [TreeP a] }
mkTreeP pmb (Tree a cs) = let x = TreeP pmb a (map (mkTreeP (Just x)) cs) in x
parents = map fromJust . takeWhile isJust . iterate (>>= parent) . return
instance Show a => Show (TreeP a) where
showsPrec d (TreeP p a cs) = showParen (d > 10) $
("TreeP " ++) . (f p ++) . showsPrec 11 a . (" " ++) . showList cs
where f (Just _) = "(Just <parent>) "; f Nothing = "Nothing "
test00 = Tree 0 [Tree 1 [Tree 2 [Tree 3 []], Tree 4 []]]
test01 = mkTreeP Nothing test00
test02 = head . children . head . children $ test01
test03 = parent test02
test04 = parents test02平衡木
赤黒木
Haskell Red-Black Setより。 Red Black Trees に deletion 付きのものがある。
data Color = R | B
data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a)
balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
balance color a x b = T color a x b
empty = E
member x E = False
member x (T _ a y b)
| x < y = member x a
| x > y = member x b
| True = True
insert x s = T B a y b
where
T _ a y b = ins s
ins E = T R E x E
ins [email protected](T color a y b)
| x < y = balance color (ins a) y b
| x > y = balance color a y (ins b)
| True = sbalance が美しい。
AVL 木
data AVLSet a = E | T H (AVLSet a) a (AVLSet a) deriving Show
data H = L | B | R deriving Show
balanceL R a x b = (False, T B a x b)
balanceL B a x b = (True, T L a x b)
balanceL L (T L a x b) y c = (False, T B a x (T B b y c))
balanceL L (T B a x b) y c = (True, T R a x (T L b y c))
balanceL L (T R a x (T h b y c)) z d = (False, T B (T h' a x b) y (T h'' c z d))
where (h', h'') = case h of L -> (B, R); B -> (B, B); R -> (L, B)
balanceR L a x b = (False, T B a x b)
balanceR B a x b = (True, T R a x b)
balanceR R a x (T R b y c) = (False, T B (T B a x b) y c)
balanceR R a x (T B b y c) = (True, T L (T R a x b) y c)
balanceR R a x (T L (T h b y c) z d) = (False, T B (T h' a x b) y (T h'' c z d))
where (h', h'') = case h of R -> (L, B); B -> (B, B); L -> (B, R)
member x E = False
member x (T _ a y b)
| x < y = member x a
| x > y = member x b
| True = True
insert x E = T B E x E
insert x t = snd $ ins x t
ins x E = (True, T B E x E)
ins x [email protected](T h l v r)
| x < v = case ins x l of
(True, l) -> balanceL h l v r
(False, l) -> (False, T h l v r)
| x > v = case ins x r of
(True, r) -> balanceR h l v r
(False, r) -> (False, T h l v r)
| True = (False, t)
delete x t = snd $ del x t
del x E = (True, E)
del x (T h l y r)
| x < y = case del x l of
(False, l) -> balanceR h l y r
(True, l) -> (True, T h l y r)
| x > y = case del x r of
(False, r) -> balanceL h l y r
(True, r) -> (True, T h l y r)
| True = case l of
E -> (False,r)
l -> case rightElem l of
(z, (False, l)) -> balanceR h l z r
(z, (True, l)) -> (True, T h l z r)
rightElem (T h l x E) = (x, (False,l))
rightElem (T h l x r) = case rightElem r of
(z, (False, r)) -> (z, balanceL h l x r)
(z, (True, r)) -> (z, (True, T h l x r))
height E = 0
height (T _ l _ r) = 1 + max (height l) (height r)
toList E = []
toList (T _ a x b) = toList a ++ [x] ++ toList b
check = snd . check'
check' E = (0, True)
check' (T h l _ r) =
( 1 + max a c
, b && d && (case h of
L -> a == c + 1
R -> a + 1 == c
B -> a == c
)
)
where ((a, b), (c, d)) = (check' l, check' r)
permutation [] = [[]]
permutation xs = concat [map (x:) $ permutation (List.delete x xs) | x <- xs]
test = and $ map (check . foldl (flip insert) E) $ permutation [1..8]
test' = and [check $ delete x t | t <- map (foldl (flip insert) E) $ permutation [1..7], x <-[1..7]]Red-Black Tree をまねしてみたけど、場合分けが多くなってしまった。 – y.hanatani
height E = 0
height (T L l _ _) = 1 + height l
height (T _ _ _ r) = 1 + height rこれを使ってGADTで遊ばせてもらいました。その際に気付いたのですが、「balanceL L (T B a x b) y c = (True, T L (T B a x b) y c)」は「balanceL L (T B a x b) y c = (True, (T R a x (T L b y c)」ではないでしょうか。– sakai
あ、insert だけだとこの規則は使われないですね。delete のときにはsakai氏のおっしゃるとおりです。 – y.hanatani
data Z = Z
data S n = S n
data (Ord a) => T a n where
E :: T a Z
T :: H l r n -> T a l -> a -> T a r -> T a n
data H l r n where
B :: H a a (S a)
L :: H (S a) a (S (S a))
R :: H a (S a) (S (S a))
balanceL :: H l r n -> T a (S l) -> a -> T a r -> Either (T a n) (T a (S n))
balanceL R a x b = Left (T B a x b)
balanceL B a x b = Right (T L a x b)
balanceL L (T B a x b) y c = Right (T R a x (T L b y c))
balanceL L (T L a x b) y c = Left (T B a x (T B b y c))
balanceL L (T R a x (T h b y c)) z d =
case h of
L -> Left (T B (T B a x b) y (T R c z d))
B -> Left (T B (T B a x b) y (T B c z d))
R -> Left (T B (T L a x b) y (T B c z d))
balanceR :: H l r n -> T a l -> a -> T a (S r) -> Either (T a n) (T a (S n))
balanceR L a x b = Left (T B a x b)
balanceR B a x b = Right (T R a x b)
balanceR R a x (T B b y c) = Right (T L (T R a x b) y c)
balanceR R a x (T R b y c) = Left (T B (T B a x b) y c)
balanceR R a x (T L (T h b y c) z d) =
case h of
R -> Left (T B (T L a x b) y (T B c z d))
B -> Left (T B (T B a x b) y (T B c z d))
L -> Left (T B (T B a x b) y (T R c z d))
ins :: (Ord a) => a -> T a n -> Either (T a n) (T a (S n))
ins x E = Right (T B E x E)
ins x [email protected](T h l v r) =
case x `compare` v of
EQ -> Left t
LT -> case ins x l of
Left l' -> Left (T h l' v r)
Right l' -> balanceL h l' v r
GT -> case ins x r of
Left r' -> Left (T h l v r')
Right r' -> balanceR h l v r'
data (Ord a) => AVLSet a = forall n. AVLSet (T a n)
emptySet :: (Ord a) => AVLSet a
emptySet = AVLSet E
insert :: (Ord a) => a -> AVLSet a -> AVLSet a
insert x (AVLSet t) =
case ins x t of
Left u -> AVLSet u
Right u -> AVLSet u
toList :: (Ord a) => AVLSet a -> [a]
toList (AVLSet t) = f t
where f :: forall a n. T a n -> [a]
f E = []
f (T _ l x r) = f l ++ [x] ++ f r
height :: (Ord a) => AVLSet a -> Int
height (AVLSet t) = f t
where f :: forall a n. T a n -> Int
f E = 0
f (T L l _ r) = 1 + f l
f (T _ _ _ r) = 1 + f r
test = height $ foldl (flip insert) emptySet [1..100]foldによって書いてみる – yts
fold :: (forall l n r. H l n r -> b -> a -> b -> b) -> b -> T a d -> b
fold f z [email protected](T h l a r) = f h (g l) a (g r) where g = fold f z
fold f z E = z
member :: (Ord a) => a -> AVLSet a -> Bool
member (x :: a) (AVLSet t) = fold f False t
where f :: H l r n -> Bool -> a -> Bool -> Bool
f _ l a r = case compare x a of
EQ -> True; LT -> l; GT -> r
-- toList (AVLSet t) = fold (\h l a r -> l ++ [a] ++ r) [] t
-- height (AVLSet t) = <snip>データタイプから再帰を分離
newtype Fix f = Fix (f (Fix f))
type Rec r = r (Fix r)
type Stream a = Rec ((,) a)
stream (x:xs) = (x, Fix (stream xs))
tolist (a, (Fix b)) = a:tolist b
test = take 10 $ tolist $ stream [1..]もっといい項目名をつけたかったのだけど… – yts
探索
深さ優先探索
dfs :: (a -> [a]) -> a -> [a]
dfs f x = x:(f x >>= dfs f)幅優先探索
bfs :: (a -> [a]) -> a -> [a]
bfs f = bfs' . (:[])
where bfs' [] = []
bfs' xs = xs ++ bfs' (xs >>= f)
-- 一行で書くと
bfs f = concat . takeWhile (not.null) . iterate (>> f) . (:[])Graphical Sequence
mputの日記より
isGraphic [] = True
isGraphic (x:xs) = or [isGraphic $ map (subtract 1) xs ++ ys | (xs,ys) <- choice x xs]choice の定義はProgramming_玉手箱_組合せにある．
–nobsun
splitAt' :: Int -> [a] -> Maybe ([a], [a])
splitAt' 0 xs = Just ([], xs)
splitAt' _ [] = Nothing
splitAt' n (x:xs) = splitAt' (n-1) xs >>= \(ys, zs) -> Just (x:ys, zs)
isGraphical :: [Int] -> Bool
isGraphical = isGraphical' . reverse . sort
where
isGraphical' [] = True
isGraphical' (x:xs) = case splitAt' x xs of
Just (ys, zs) -> isGraphical $ map (subtract 1) ys ++ zs
Nothing -> Falseグラフ的な列を列挙。
genGraphical :: Int -> [[Int]]
genGraphical 0 = [[]]
genGraphical n = nub $ concat [[ins m $ map (+1) ys ++ zs | (m, (ys, zs)) <- zip [0..] (splits xs)] | xs <- genGraphical (n-1)]
where splits xs = zip (inits xs) (tails xs)
ins a [] = [a]
ins a [email protected](x:xs) | x <= a = a:xxs
| True = x:ins a xs
graphicals :: [[Int]]
graphicals = concatMap genGraphical [0..]Last modified : 2008/05/22 14:05:57 JST
