commit 0def8e8f5c7fa74f98dc76e6e2bd69796e5f6c1d
parent 3f338e6e2a2589e14b345b74364c301dd0f4905c
Author: Jared Tobin <jared@jtobin.ca>
Date: Thu, 11 May 2017 20:00:18 +1200
Recursion schemes for fun.
Diffstat:
| M | Tree.hs | | | 47 | ++++++++++++++++++++++++++++++++++------------- |
| A | TreeRS.hs | | | 106 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 140 insertions(+), 13 deletions(-)
diff --git a/Tree.hs b/Tree.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE LambdaCase #-}
module Tree where
@@ -7,25 +8,30 @@ import Prelude hiding (lookup)
data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Eq, Show)
-empty :: Tree a
-empty = Leaf
+node :: a -> Tree a -> Tree a -> Tree a
+node x l = Node l x
+
+leaf :: Tree a
+leaf = Leaf
insert :: Ord a => a -> Tree a -> Tree a
-insert x Leaf = Node Leaf x Leaf
-insert x t@(Node l e r) = case compare x e of
- EQ -> t
- LT -> Node (insert x l) e r
- GT -> Node l e (insert x r)
+insert x tree = case tree of
+ Leaf -> node x leaf leaf
+ Node l e r -> case compare x e of
+ EQ -> tree
+ LT -> node e (insert x l) r
+ GT -> node e l (insert x r)
member :: Ord a => a -> Tree a -> Bool
-member _ Leaf = False
-member x (Node l e r) = case compare x e of
- EQ -> True
- LT -> member x l
- GT -> member x r
+member x = \case
+ Leaf -> False
+ Node l e r -> case compare x e of
+ EQ -> True
+ LT -> member x l
+ GT -> member x r
fromList :: Ord a => [a] -> Tree a
-fromList = foldr insert empty
+fromList = foldr insert leaf
test :: Tree Int
test = fromList [5..10]
@@ -79,3 +85,18 @@ completeSize x n
r = completeSize x (n `quot` 2 - 1)
in Node l x r
+test0 :: Num a => Tree a
+test0 = node 1 leaf leaf
+
+test1 :: Num a => Tree a
+test1 = node 2 (node 1 leaf leaf) (node 3 leaf leaf)
+
+test2 :: (Ord a, Num a) => Tree a
+test2 = insert 0 test1
+
+test3 :: (Ord a, Num a) => Tree a
+test3 = insert 5 test1
+
+test4 :: (Ord a, Num a) => Tree a
+test4 = insert 4 test3
+
diff --git a/TreeRS.hs b/TreeRS.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+import Data.Functor.Foldable
+import Text.Show.Deriving
+
+data TreeF a r =
+ LeafF
+ | NodeF r a r
+ deriving (Functor, Show)
+
+$(deriveShow1 ''TreeF)
+
+type Tree a = Fix (TreeF a)
+
+leaf :: Tree a
+leaf = Fix LeafF
+
+node :: a -> Tree a -> Tree a -> Tree a
+node x l r = Fix (NodeF l x r)
+
+-- insert :: forall a. Ord a => a -> Tree a -> Tree a
+-- insert x = apo coalg where
+-- coalg :: Ord a => Tree a -> TreeF a (Either (Tree a) (Tree a))
+-- coalg input = case unfix input of
+-- LeafF -> NodeF (Left leaf) x (Left leaf)
+-- NodeF l e r -> case compare x e of
+-- EQ -> NodeF (Left l) e (Left r)
+-- LT -> NodeF (Right l) e (Left r)
+-- GT -> NodeF (Left l) e (Right r)
+
+insert :: forall a. Ord a => a -> Tree a -> Tree a
+insert x = apo coalg where
+ coalg :: (Ord b, b ~ a) => Tree b -> TreeF a (Either (Tree b) (Tree b))
+ coalg input = case unfix input of
+ LeafF -> NodeF (Left leaf) x (Left leaf)
+ NodeF l e r -> case compare x e of
+ EQ -> NodeF (Left l) e (Left r)
+ LT -> NodeF (Right l) e (Left r)
+ GT -> NodeF (Left l) e (Right r)
+
+member :: Ord a => a -> Tree a -> Bool
+member x = cata $ \case
+ LeafF -> False
+ NodeF l e r -> case compare x e of
+ EQ -> True
+ LT -> l
+ GT -> r
+
+fromList :: Ord a => [a] -> Tree a
+fromList = foldr insert leaf
+
+test0 :: Num a => Tree a
+test0 = node 1 leaf leaf
+
+-- 1
+-- | \
+-- L L
+
+test1 :: Num a => Tree a
+test1 = node 2 (node 1 leaf leaf) (node 3 leaf leaf)
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- L L L L
+
+test2 :: (Ord a, Num a) => Tree a
+test2 = insert 0 test1
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- 0 L L L
+-- | \
+-- L L
+
+test3 :: (Ord a, Num a) => Tree a
+test3 = insert 5 test1
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- L L L 5
+-- | \
+-- L L
+
+test4 :: (Ord a, Num a) => Tree a
+test4 = insert 4 test3
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- L L L 5
+-- | \
+-- 4 L
+-- | \
+-- L L
+
