I have implement the Set datatype using Binary search tree.
My implementation is as follows:-
data Set a = Empty | Node a (Set a) (Set a)
I have also written some other functions such as toList, fromList, and Insert. (took help in my previous question)
These are the functions that I have written until now:
insert :: Ord a => a -> Set a -> Set a
insert x Empty = Node x Empty Empty
insert x (Node e l r)
| x == e = Node e l r
| x < e = Node e (insert x l) r
| otherwise = Node e l (insert x r)
fromList :: Ord a => [a] -> Set a
fromList [] = Empty
fromList (x:xs) = insert x (fromList xs)
toList :: Set a -> [a]
toList Empty = []
toList (Node val l r) = toList l ++ val : (toList r)
I have been trying to solve the following functions for quite a long time now. Can you please help me out. I have made multiple attempts , but none of them work.
---- return the common elements between two Sets
intersection :: (Ord a) => Set a -> Set a -> Set a
-- all the elements in Set A *not* in Set B,
-- {1,2,3,4} `difference` {3,4} => {1,2}
-- {} `difference` {0} => {}
difference :: (Ord a) => Set a -> Set a -> Set a
Here's my attempt to this function, which compiles without an error , but it does not solve the problem:
intersection :: (Ord a) => Set a -> Set a -> Set a
intersection Empty Empty = Empty
intersection l Empty = Empty
intersection Empty r = Empty
intersection (Node val1 Empty Empty) (Node val2 Empty Empty) = if val1
== val2 then (Node val1 Empty Empty) else Empty
intersection l (Node val1 l1 r1) = Node val1 (intersection l l1) r1
I cannot import any external module/ libraries. I have also written a setmap function if that helps .
Thank you for your help.
Here is my solution, it's not the best in performance but work, solution is create a list and use element function inside filter function.
module Lib
(
insert, fromList, toList, element, intersection, difference
)
where
data Set a = Empty | Node a (Set a) (Set a) deriving Show
insert :: Ord a => a -> Set a -> Set a
insert x Empty = Node x Empty Empty
insert x (Node e l r)
| x == e = Node e l r
| x < e = Node e (insert x l) r
| otherwise = Node e l (insert x r)
fromList :: Ord a => [a] -> Set a
fromList = foldr insert Empty
toList :: Set a -> [a]
toList Empty = []
toList (Node val l r) = toList l ++ val : toList r
element :: Ord t => Set t -> t -> Bool
element Empty _ = False
element (Node v l r) x
| x == v = True
| x < v = element l x
| otherwise = element r x
intersection :: (Ord a) => Set a -> Set a -> Set a
intersection s1 s2 = intersect
where
ls2 = toList s2
intersect = fromList $ filter (element s1) ls2
difference :: (Ord a) => Set a -> Set a -> Set a
difference s1 s2 = diff
where
ls1 = toList s1
diff = fromList $ filter (not.element s2) ls1
Related
I'm a beginner to Haskell.
I've implemented a set as a binary tree
Set a = Node a | Tree a (Set a) (Set a)
I've been stuck on creating a powers function. Any ideas on how I could implement a powerset function, ideally not completely the same as Data.Set 😅?
Let's look at a simpler version of powerset that uses lists:
powerset [] = [[]]
powerset (x:xs) = [x:ps | ps <- pxs] ++ pxs where
pxs = powerset xs
Running powerset [1, 2, 3] yields [[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]
From this you can see basic functions and data definitions needed for implementing the operations with BSTs:
powerset [] = [[]] an empty set, which is missing in your case as pointed out in the comments
x:ps a way to add an element to a set
And, a more subtle one: removing an element from the set, because (x:xs) splits the set int x and xs which is used in pxs = powerset xs
A simple implementation would look like this:
data TreeSet a = Node (TreeSet a) a (TreeSet a) | Nil deriving Show
powersetTree :: (Ord a) => TreeSet a -> [TreeSet a]
powersetTree Nil = [Nil]
powersetTree tree =
[addTreeSet subtree v | subtree <- pxs] ++ pxs where
(Node l v r) = tree
pxs = powersetTree (removeTreeSet tree v)
addTreeSet :: (Ord a) => TreeSet a -> a -> TreeSet a
addTreeSet Nil x = Node Nil x Nil
addTreeSet (Node l v r) x =
if x < v then
Node (addTreeSet l x) v r
else if x > v then
Node l v (addTreeSet r x)
else error "Duplicate element"
removeTreeSet :: (Ord a) => TreeSet a -> a -> TreeSet a
removeTreeSet Nil a = error "Can't remove from empty set"
removeTreeSet (Node l v r) x =
if v == x then
unionTreeSet l r
else if x < v then
Node (removeTreeSet l x) v r
else
Node l v (removeTreeSet r x)
unionTreeSet :: (Ord a) => TreeSet a -> TreeSet a -> TreeSet a
unionTreeSet Nil Nil = Nil
unionTreeSet Nil r = r
unionTreeSet l Nil = l
unionTreeSet l (Node rl rv rr) = Node (unionTreeSet l rl) rv rr
buildTreeSet [] = Nil
buildTreeSet (x:xs) = addTreeSet ts x where ts = buildTreeSet xs
showTreeSet Nil = []
showTreeSet (Node l v r) = (showTreeSet l) ++ [v] ++ (showTreeSet r)
powerset' xs =
foldr (:) [] lists where
tree = buildTreeSet xs
treeList = powersetTree tree
lists = map showTreeSet treeList
You can try it by running powerset' [1, 2, 3] which yields [[1,2,3],[2,3],[1,3],[3],[1,2],[2],[1],[]]
Some notes:
Efficiency: my main goal above was to write the functions in simplest way to show the basic idea (maybe except powerset'). For example the performance of buildTreeSetcould be easily improved by using tail recursion with an accumulator like so:
buildTreeSet' l = build l Nil where
build [] tree = tree
build (x:xs) partTree = build xs (addTreeSet partTree x)
Another glaring problem is that if the list given as input to buildTreeSet is ordered, the tree build will be degenerate, effectively acting as a linked list, which defeats the point of using trees. The same applies for removeTreeSet and unionTreeSet because the latter just chains the two trees.
Error handling: I used error (which is like throwing an exception in java or c++) to keep the code simple. However you should consider using types like Maybe or Either to indicate that functions might fail. A big advantage of functional programming that the possibility of failure can be indicated by the signature of the function, forcing the programmer to handle errors at compile time (by checking if the return was Just or Nothing) instead of throwing errors at runtime.
Here's an example for removeTreeSet:
removeTreeSetSafe :: (Ord a) => TreeSet a -> a -> Maybe (TreeSet a)
removeTreeSetSafe Nil a = Nothing
removeTreeSetSafe (Node l v r) x =
if v == x then
Just (unionTreeSet l r)
else if x < v then
let mTree = (removeTreeSetSafe l x) in
case mTree of
(Just tree) -> Just (Node tree v r)
Nothing -> Nothing
else
let mTree = (removeTreeSetSafe r x) in
case mTree of
(Just tree) -> Just (Node l v tree)
Nothing -> Nothing
Here is an example of the difference:
> tree = buildTreeSet [1..4]
> tree
Node (Node (Node (Node Nil 1 Nil) 2 Nil) 3 Nil) 4 Nil
> removeTreeSet tree 2
Node (Node (Node Nil 1 Nil) 3 Nil) 4 Nil
> removeTreeSet Nil 2
*** Exception: Can't remove from empty set
CallStack (from HasCallStack):
error, called at main.hs:24:23 in main:Main
> removeTreeSetSafe tree 2
Just (Node (Node (Node Nil 1 Nil) 3 Nil) 4 Nil)
> removeTreeSetSafe Nil 2
Nothing
In the first case with removeTreeSet if an element is not found or the set is empty the program will simply exit with an error (assuming it was compiled).
In the second case using removeTreeSetSafe we are forced to handle the possibility of failure, else the code won't compile (as in you can't replace removeTreeSet with removeTreeSetSafe)
data Set a = Node | Tree (Set a) (Set a)
How can I implement a partition function which partitions the set into two sets, with all elements that satisfy the predicate on the left and the rest on the right as simply as possible?
Any help is appreciated.
Thanks in advance!
As noted in the comments, your type won't quite cut it. A reasonable implementation of a set as a tree might have type:
data Set a = Leaf | Node a (Set a) (Set a) deriving (Show)
^- note this extra `a`
where each internal Node x l r has all elements in l less than x and all elements in r greater than x.
You can partition such a Set recursively as follows:
partition :: (a -> Bool) -> Set a -> (Set a, Set a)
The Leaf case is easy, obviously:
partition _ Leaf = (Leaf, Leaf)
Here's how we do the Node case. For the sub-case where the predicate holds for the value x in the node, note that we want:
partition f (Node x l r) | f x = (Node x l1 r1, ...)
where l1 and r1 are the subsets of elements in l and r that satisfy the predicate, which we can get by recursively partitioning l and r.
where (l1, l2) = partition f l
(r1, r2) = partition f r
The Set invariant will be preserved here, because all elements in l, including those in the subset l1 are less than x; for the same reason, all elements in r1 are greater than x. The only missing piece is that we somehow need to combine l2 and r2 to form the second part of the tuple:
partition f (Node x l r) | f x = (Node x l1 r1, combine l2 r2)
Since combine is a function that takes two trees with all elements in the first tree less than all elements in the second tree, the following recursive function will do:
combine Leaf r' = r'
combine (Node x l r) r' = Node x l (combine r r')
The case where the predicate does not hold for x is handled similarly, giving the full definition:
data Set a = Leaf | Node a (Set a) (Set a)
partition :: (a -> Bool) -> Set a -> (Set a, Set a)
partition _ Leaf = (Leaf, Leaf)
partition f (Node x l r)
| f x = (Node x l1 r1, combine l2 r2)
| otherwise = (combine l1 r1, Node x l2 r2)
where (l1, l2) = partition f l
(r1, r2) = partition f r
combine Leaf r' = r'
combine (Node x l r) r' = Node x l (combine r r')
Here's the complete code plus a QuickCheck test that that partition function works as expected:
import Test.QuickCheck
import qualified Data.List (nub, partition, sort)
import Data.List (nub, sort)
data Set a = Leaf | Node a (Set a) (Set a) deriving (Show)
partition :: (a -> Bool) -> Set a -> (Set a, Set a)
partition _ Leaf = (Leaf, Leaf)
partition f (Node x l r)
| f x = (Node x l1 r1, combine l2 r2)
| otherwise = (combine l1 r1, Node x l2 r2)
where (l1, l2) = partition f l
(r1, r2) = partition f r
combine Leaf r' = r'
combine (Node x l r) r' = Node x l (combine r r')
insert :: (Ord a) => a -> Set a -> Set a
insert x Leaf = Node x Leaf Leaf
insert x (Node y l r) = case compare x y of
LT -> Node y (insert x l) r
GT -> Node y l (insert x r)
EQ -> Node y l r
fromList :: (Ord a) => [a] -> Set a
fromList = foldr insert Leaf
toList :: (Ord a) => Set a -> [a]
toList Leaf = []
toList (Node x l r) = toList l ++ x : toList r
prop_partition :: [Int] -> Bool
prop_partition lst =
let (l, r) = Main.partition even (fromList lst') in (toList l, toList r)
== Data.List.partition even (sort $ lst')
where lst' = nub lst
main = quickCheck (withMaxSuccess 10000 prop_partition)
What I want to do is to take a binary search tree, and an element, and then remove it from the tree
(if it is present).
Here is my code:
data BinaryTree a = Null | Node (BinaryTree a) a (BinaryTree a)
deriving Show
type BSTree a = BinaryTree a
treeDelete :: (Ord a) => (BSTree a) -> a -> (BSTree a)
treeDelete a btree = case btree of
Null -> Null
Node Null val Null
|a==val -> Null
|otherwise -> Node Null val Null
Node left val right
|a==val-> Node left Null right
|otherwise -> (treeDelete a left) val (treeDelete a right)
You can:
Change you data structure definition as
data BinaryTree a = Null | Node (BinaryTree a) (Maybe a) (BinaryTree a)
which is a simplified trie keyed by [Bool].
Define a rotation behavior (like in Balanced Tree) to fill in the blank after delete. The rotation is not unique. For example, for the lazy Map in the container package, the deletion of a balanced tree is defined as:
data Map k a = Bin Size k a (Map k a) (Map k a)
| Tip
type Size = Int
delete :: Ord k => k -> Map k a -> Map k a
delete = go
where
go :: Ord k => k -> Map k a -> Map k a
go !_ Tip = Tip
go k t#(Bin _ kx x l r) =
case compare k kx of
LT | l' == l -> t
| otherwise -> balanceR kx x l' r
where l' = go k l
GT | r' == r -> t
| otherwise -> balanceL kx x l r'
where r' = go k r
EQ -> glue l r
balanceR, balanceL and glue are rotation to balance depth in a balanced tree.
http://hackage.haskell.org/package/containers-0.6.2.1/docs/Data-Map-Lazy.html
In my application, I'm trying to implement an animation system. In this system, animations are represented as a cyclic list of frames:
data CyclicList a = CL a [a]
We can (inefficiently) advance the animation as follows:
advance :: CyclicList a -> CyclicList a
advance (CL x []) = CL x []
advance (CL x (z:zs)) = CL z (zs ++ [x])
Now, I'm pretty sure that this data type is a comonad:
instance Functor CyclicList where
fmap f (CL x xs) = CL (f x) (map f xs)
cyclicFromList :: [a] -> CyclicList a
cyclicFromList [] = error "Cyclic list must have one element!"
cyclicFromList (x:xs) = CL x xs
cyclicLength :: CyclicList a -> Int
cyclicLength (CL _ xs) = length xs + 1
listCycles :: CyclicList a -> [CyclicList a]
listCycles cl = let
helper 0 _ = []
helper n cl' = cl' : (helper (n-1) $ advance cl')
in helper (cyclicLength cl) cl
instance Comonad CyclicList where
extract (CL x _) = x
duplicate = cyclicFromList . listCycles
The question I have is: what kind of benefits do I get (if any) from using the comonad instance?
The advantage of providing a type class or implementing an interface is that code, written to use that typeclass or interface, can use your code without any modifications.
What programs can be written in terms of Comonad? A Comonad provides a way to both inspect the value at the current location (without observing its neighbors) using extract and a way to observe the neighborhood of every location with duplicate or extend. Without any additional functions, this isn't terribly useful. However, if we also require other functions along with the Comonad instance, we can write programs that depend on both local data and data from elsewhere. For example, if we require functions that allow us to change location, such as your advance, we can write programs that depend only on the local structure of the data, not on the data structure itself.
For a concrete example, consider a cellular automata program written in terms of Comonad and the following Bidirectional class:
class Bidirectional c where
forward :: c a -> Maybe (c a)
backward :: c a -> Maybe (c a)
The program could use this, together with Comonad, to extract data stored in a cell and explore the cells forward and backward of the current cell. It can use duplicate to capture the neighborhood of each cell and fmap to inspect that neighborhood. This combination of fmap f . duplicate is extract f.
Here is such a program. rule' is only interesting to the example; it implements cellular automata rules on neighborhood with just the left and right values. rule extracts data from the neighborhood, given the class, and runs the rule on each neighborhood. slice pulls out even larger neighborhoods so that we can display them easily. simulate runs the simulation, displaying these larger neighborhoods for each generation.
rule' :: Word8 -> Bool -> Bool -> Bool -> Bool
rule' x l m r = testBit x ((if l then 4 else 0) .|. (if m then 2 else 0) .|. (if r then 1 else 0))
rule :: (Comonad w, Bidirectional w) => Word8 -> w Bool -> w Bool
rule x = extend go
where
go w = rule' x (maybe False extract . backward $ w) (extract w) (maybe False extract . forward $ w)
slice :: (Comonad w, Bidirectional w) => Int -> Int -> a -> w a -> [a]
slice l r a w = sliceL l w (extract w : sliceR r w)
where
sliceR r w | r > 0 = case (forward w) of
Nothing -> take r (repeat a)
Just w' -> extract w' : sliceR (r-1) w'
sliceR _ _ = []
sliceL l w r | l > 0 = case (backward w) of
Nothing -> take l (repeat a) ++ r
Just w' -> sliceL (l-1) w' (extract w':r)
sliceL _ _ r = r
simulate :: (Comonad w, Bidirectional w) => (w Bool -> w Bool) -> Int -> Int -> Int -> w Bool -> IO ()
simulate f l r x w = mapM_ putStrLn . map (map (\x -> if x then '1' else '0') . slice l r False) . take x . iterate f $ w
This program might have been intended to work with the following Bidirectional Comonad, a Zipper on a list.
data Zipper a = Zipper {
heads :: [a],
here :: a,
tail :: [a]
} deriving Functor
instance Bidirectional Zipper where
forward (Zipper _ _ [] ) = Nothing
forward (Zipper l h (r:rs)) = Just $ Zipper (h:l) r rs
backward (Zipper [] _ _) = Nothing
backward (Zipper (l:ls) h r) = Just $ Zipper ls l (h:r)
instance Comonad Zipper where
extract = here
duplicate (Zipper l h r) = Zipper (goL (h:r) l) (Zipper l h r) (goR (h:l) r)
where
goL r [] = []
goL r (h:l) = Zipper l h r : goL (h:r) l
goR l [] = []
goR l (h:r) = Zipper l h r : goR (h:l) r
But will also work with a CyclicList Bidirectional Comonad.
data CyclicList a = CL a (Seq a)
deriving (Show, Eq, Functor)
instance Bidirectional CyclicList where
forward (CL x xs) = Just $ case viewl xs of
EmptyL -> CL x xs
x' :< xs' -> CL x' (xs' |> x)
backward (CL x xs) = Just $ case viewr xs of
EmptyR -> CL x xs
xs' :> x' -> CL x' (x <| xs')
instance Comonad CyclicList where
extract (CL x _) = x
duplicate (CL x xs) = CL (CL x xs) (go (singleton x) xs)
where
go old new = case viewl new of
EmptyL -> empty
x' :< xs' -> CL x' (xs' >< old) <| go (old |> x') xs'
We can reuse simulate with either data structure. The CyclicList has a more interesting output, because, instead of bumping into a wall, it wraps back around to interact with itself.
{-# LANGUAGE DeriveFunctor #-}
import Control.Comonad
import Data.Sequence hiding (take)
import Data.Bits
import Data.Word
main = do
putStrLn "10 + 1 + 10 Zipper"
simulate (rule 110) 10 10 30 $ Zipper (take 10 . repeat $ False) True (take 10 . repeat $ False)
putStrLn "10 + 1 + 10 Cyclic"
simulate (rule 110) 10 10 30 $ CL True (fromList (take 20 . repeat $ False))
How can I check if a BST is a valid one, given its definition and using a generalized version of fold for BST?
data(Ord a, Show a, Read a) => BST a = Void | Node {
val :: a,
left, right :: BST a
} deriving (Eq, Ord, Read, Show)
fold :: (Read a, Show a, Ord a) => (a -> b -> b -> b) -> b -> BST a -> b
fold _ z Void = z
fold f z (Node x l r) = f x (fold f z l) (fold f z r)
The idea is to check that a node value is greater then all values in left-subtree and smaller than all values in its right-subtree. This must be True for all nodes in the tree. A function bstList simply output the list of (ordered) values in the BST.
Of course something like this won't work:
--isBST :: (Read a, Show a, Ord a) => BST a -> Bool
isBST t = fold (\x l r -> all (<x) (bstList l) && all (>x) (bstList r)) (True) t
because, for example, applying the fold function to the node 19 ends up all (<19) (bstList True) && all (>19) (bstList True).
Your problem seems to be that you lose information because your function only returns a boolean when it examines the left and right subtrees. So change it to also return the minimum and maximum values of the subtrees. (This is probably more efficient as well, since you don't need to used bslist to check all elements anymore)
And make a wrapper function to ignore these "auxiliary" values after you are done, of course.
(Please don't put typeclass constraints on the data type.)
A BST is valid iff an in-order traversal is monotonically increasing.
flatten tree = fold (\a l r -> l . (a:) . r) id tree []
ordered list#(_:rest) = and $ zipWith (<) list rest
ordered _ = True
isBST = ordered . flatten
A nice way of encoding this is to lean on the traversal provided by Data.Foldable.
{-# LANGUAGE DeriveFunctor, DeriveFoldable #-}
import Data.Foldable
import Data.Monoid
We can derive an instance of it automatically using an extension, but we need to reorder the fields of the Node constructor to provide us an in-order traversal.
While we're at it, we should eliminate the constraints on the data type itself. They actually provide no benefit, and has been removed from the language as of Haskell 2011. (When you want to use such constraints you should put them on instances of classes, not on the data type.)
data BST a
= Void
| Node
{ left :: BST a
, val :: a
, right :: BST a
} deriving (Eq, Ord, Read, Show, Foldable)
First we define what it means for a list to be strictly sorted.
sorted :: Ord a => [a] -> Bool
sorted [] = True
sorted [x] = True
sorted (x:xs) = x < head xs && sorted xs
-- head is safe because of the preceeding match.
Then we can use the toList method provided by Data.Foldable and the above helper.
isBST :: Ord a => BST a -> Bool
isBST = sorted . toList
We can also implement this more directly, like you asked. Since we removed the spurious constraints on the data type, we can simplify the definition of your fold.
cata :: (b -> a -> b -> b) -> b -> BST a -> b
cata _ z Void = z
cata f z (Node l x r) = f (cata f z l) x (cata f z r)
Now we need a data type to model the result of our catamorphism, which is that we either have no nodes (Z), or a range of strictly increasing nodes (T) or have failed (X)
data T a = Z | T a a | X deriving Eq
And we can then implement isBST directly
isBST' :: Ord a => BST a -> Bool
isBST' b = cata phi Z b /= X where
phi X _ _ = X
phi _ _ X = X
phi Z a Z = T a a
phi Z a (T b c) = if a < b then T a c else X
phi (T a b) c Z = if b < c then T a c else X
phi (T a b) c (T d e) = if b < c && c < d then T a e else X
This is a bit tedious, so perhaps it would be better to decompose the way we compose the interim states a bit:
cons :: Ord a => a -> T a -> T a
cons _ X = X
cons a Z = T a a
cons a (T b c) = if a < b then T a c else X
instance Ord a => Monoid (T a) where
mempty = Z
Z `mappend` a = a
a `mappend` Z = a
X `mappend` _ = X
_ `mappend` X = X
T a b `mappend` T c d = if b < c then T a d else X
isBST'' :: Ord a => BST a -> Bool
isBST'' b = cata phi Z b /= X where
phi l a r = l `mappend` cons a r
Personally, I'd probably just use the Foldable instance.
If you don't insist on using a fold you can do it like this:
ord Void = True
ord (Node v l r) = every (< v) l && every (> v) r && ord l && ord r where
every p Void = True
every p (Node v l r) = p v && every p l && every p r