# Programming_玉手箱_その他

Programming:玉手箱:その他

Programming_玉手箱

データタイプから再帰を分離

Graphical Sequence

## 関数型表

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   = s

balance が美しい。

### 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..]