Purely Functional Data Structures 第2章

演習問題を解いたのでメモ.

ex 2.1

suffixes :: [a] -> [[a]]
suffixes [] = [[]]
suffixes xss@(_:xs) = xss : suffixes xs

ex 2.2

data Set a = Leaf
           | Branch a (Set a) (Set a)
  deriving Show

empty :: Set a
empty = Leaf

insert :: Ord a => a -> Set a -> Set a
insert x Leaf = Branch x Leaf Leaf
insert x tree@(Branch y left right)
  | x < y     = Branch y (insert x left) right
  | x > y     = Branch y left (insert x right)
  | otherwise = tree

member :: Ord a => a -> Set a -> Bool
member x set = member' Nothing set
  where
  member' c Leaf = maybe False (>= x) c
  member' c (Branch y left right)
    | x < y     = member' c left
    | otherwise = member' (Just y) right

ex 2.3

「Establish only one handler per insertion rather than one handler per iteration」の意味がわからなかったので,この文は無視して解いた.

import Data.Maybe

data Set a = Leaf
           | Branch a (Set a) (Set a)
  deriving Show

empty :: Set a
empty = Leaf

insert :: Ord a => a -> Set a -> Set a
insert x set = fromMaybe set (insert' set)
  where
  insert' Leaf = Just (Branch x Leaf Leaf)
  insert' (Branch y left right)
    | x < y     = fmap (\new -> Branch y new right) (insert' left)
    | x > y     = fmap (\new -> Branch y left new) (insert' right)
    | otherwise = Nothing

member :: Ord a => a -> Set a -> Bool
member x set = member' Nothing set
  where
  member' c Leaf = maybe False (>= x) c
  member' c (Branch y left right)
    | x < y     = member' c left
    | otherwise = member' (Just y) right

ex 2.4

import Data.Maybe

data Set a = Leaf
           | Branch a (Set a) (Set a)
  deriving Show

empty :: Set a
empty = Leaf

insert :: Ord a => a -> Set a -> Set a
insert x set = fromMaybe set (insert' Nothing set)
  where
  insert' c Leaf
    | isNothing c || x > fromJust c = Just (Branch x Leaf Leaf)
    | otherwise                     = Nothing
  insert' c (Branch y left right)
    | x < y     = fmap (\new -> Branch y new right) (insert' c left)
    | otherwise = fmap (\new -> Branch y left new) (insert' (Just y) right)

member :: Ord a => a -> Set a -> Bool
member x set = member' Nothing set
  where
  member' c Leaf = maybe False (>= x) c
  member' c (Branch y left right)
    | x < y     = member' c left
    | otherwise = member' (Just y) right

ex 2.5

data Tree a = Empty
            | Node a (Tree a) (Tree a)
  deriving Show

makeCompleteBinaryTree :: a -> Int -> Tree a
makeCompleteBinaryTree _ 0 = Empty
makeCompleteBinaryTree x d = let subtree = makeCompleteBinaryTree x (d-1)
                             in Node x subtree subtree

makeBinaryTree :: a -> Int -> Tree a
makeBinaryTree x n = fst (make2 n)
  where
  make2 0 = (Empty, Node x Empty Empty)
  make2 n
    | n `mod` 2 == 0 = let (t1, t2) = make2 (n `div` 2 - 1)
                       in (Node x t1 t2, Node x t2 t2)
    | otherwise      = let (t1, t2) = make2 (n `div` 2)
                       in (Node x t1 t1, Node x t1 t2)

ex 2.6

import Data.Maybe

data FinateMap k v = Leaf
                   | Branch k v (FinateMap k v) (FinateMap k v)
  deriving Show

empty :: FinateMap k v
empty = Leaf

bind :: Ord k => k -> v -> FinateMap k v -> FinateMap k v
bind k v m = fromMaybe m (bind' Nothing m)
  where
  bind' c Leaf
    | isNothing c || k > fromJust c = Just (Branch k v Leaf Leaf)
    | otherwise                     = Nothing
  bind' c (Branch k' v' left right)
    | k < k'    = fmap (\new -> Branch k' v' new right) (bind' c left)
    | otherwise = fmap (\new -> Branch k' v' left new) (bind' (Just k') right)

lookup :: Ord k => k -> FinateMap k v -> Maybe v
lookup k m = lookup' Nothing m
  where
  lookup' (Just (k', v')) Leaf | k' >= k = Just v'
  lookup' c (Branch k' v' left right)
    | k < k'    = lookup' c left
    | otherwise = lookup' (Just (k', v')) right
  lookup' _ _ = Nothing