{- Question 1: a) Implement a data type TruthValues as an enumeration type that contains the three "truth" values Yes, Unknown, and No. b) Implement three functions tv_and :: TruthValues -> TruthValues -> TruthValues, tv_or :: TruthValues -> TruthValues -> TruthValues, and tv_neg :: TruthValues -> TruthValues that compute an "and", "or", and "negation" for TruthValues following the tables below. tv_and | Yes | Unknown | No -------------------------------------- Yes | Yes | Unknown | No Unknown | Unknown | Unknown | No No | No | No | No tv_or | Yes | Unknown | No -------------------------------------- Yes | Yes | Yes | Yes Unknown | Yes | Unknown | Unknown No | Yes | Unkown | No | tv_neg ------------------ Yes | No Unknown | Unknown No | Yes c) Implement a new data type for rough sets. A rough set is a set that for any given element indicates that the element is either in the set, not in the set, or that it is unknown whether the element is in the set or not. Use a function a -> TruthValues to implement a rough set. Make sure that you use data and not type. d) Implement universal, empty, complement, intersection, and union for rough sets similar to the second test but based on tv_and, tv_or, and tv_neg instead of &&, ||, and not. e) Implement a function upper :: RoughSet a -> RoughSet a for which an element is in the set upper s iff it is in s or it is unknown, i.e, s x == Yes or s x == Unknown. f) Implement a function lower :: RoughSet a -> RoughSet a for which an element is not in the set lower s iff it is not in s or it is unknown, i.e, s x == No or s x == Unknown. -} data TruthValues = Yes | Unknown | No deriving (Eq,Show) tv_and :: TruthValues -> TruthValues -> TruthValues tv_and Yes x = x tv_and Unknown No = No tv_and Unknown _ = Unknown tv_and No _ = No tv_or :: TruthValues -> TruthValues -> TruthValues tv_or Yes _ = Yes tv_or Unknown Yes = Yes tv_or Unknown _ = Unknown tv_or No x = x tv_neg :: TruthValues -> TruthValues tv_neg Yes = No tv_neg Unknown = Unknown tv_neg No = Yes data RoughSet a = RS (a -> TruthValues) universal :: RoughSet a universal = RS (const Yes) empty :: RoughSet a empty = RS (const No) complement :: RoughSet a -> RoughSet a complement (RS f) = RS (tv_neg . f) intersection :: RoughSet a -> RoughSet a -> RoughSet a intersection (RS f1) (RS f2) = RS (\x -> f1 x `tv_and` f2 x) union :: RoughSet a -> RoughSet a -> RoughSet a union (RS f1) (RS f2) = RS (\x -> f1 x `tv_or` f2 x) upper :: RoughSet a -> RoughSet a upper (RS f) = RS (\x -> if f x == No then No else Yes) lower :: RoughSet a -> RoughSet a lower (RS f) = RS (\x -> if f x == Yes then Yes else No) {- Question 2: a) Define a data type Expr of arithmetic expression made up from int's, variables (string), addition of two expressions, and multiplication of two expressions. b) Make Expr an instance of Show so that expressions are printed as strings with the appropriate brackets according to ususal binding conventions of multiplication and addition, i.e., an expression where 1 is multiplied by 2, and then 3 is added, should be printed as 1 * 2 + 3, and an expression where 1 is added to 2, and then multiplied by 3, should be printed as (1 + 2) * 3. c) Use the type Env below of lookup table for values for variables to implement a function eval :: Env -> Expr -> Int that computes the value of an expression. For example, if the expression is (x + 3) * 2 and the environment [("x",4)] then eval should result in 14. You may want to use the functions maybe and lookup in the variable case. -} type Env = [(String,Int)] data Expr = Var String | Lit Int | Add Expr Expr | Mult Expr Expr deriving Eq example1 = Mult (Add (Lit 1) (Var "x")) (Lit 2) example2 = Add (Add (Lit 1) (Var "x")) (Lit 2) example3 = Add (Mult (Lit 1) (Var "x")) (Lit 2) example4 = Mult (Mult (Lit 1) (Var "x")) (Lit 2) example5 = Add (Mult (Lit 1) (Add (Var "x") (Var "x"))) (Lit 2) instance Show Expr where showsPrec _ (Var s) = showString s showsPrec _ (Lit n) = shows n showsPrec n (Add e1 e2) = (if n>0 then showChar '(' else id) . showsPrec 0 e1 . showString " + " . showsPrec 0 e2 . (if n>0 then showChar ')' else id) showsPrec n (Mult e1 e2) = (if n>1 then showChar '(' else id) . showsPrec 1 e1 . showString " * " . showsPrec 1 e2 . (if n>1 then showChar ')' else id) eval :: Env -> Expr -> Int eval e (Var s) = maybe (error $ "Variable " ++ s ++ " does not have a value") id (lookup s e) eval _ (Lit n) = n eval e (Add e1 e2) = eval e e1 + eval e e2 eval e (Mult e1 e2) = eval e e1 * eval e e2 {- Question 3: Below you find the data type Tree a of binary trees with empty leaves storing elements of type a at inner nodes. Appropriate show and height functions are already implemented. In this question we want to implement insertion and deletion in those trees as binary search trees resp. AVL trees (cf. Wikipedia Binary search tree resp. AVL tree). a) Define a function insert :: Ord a => a -> Tree a -> Tree a that inserts an element into a binary search tree at the appropriate position. b) Implement a function removeLeftMost :: Tree a -> Maybe (a,Tree a) that returns for a tree t the pair consisting of the left-most element in the tree and the tree without that element (if those things actally exists). For examples (+ denotes a leaf): removeLeftMost (Node 10 (Node 2 Leaf (Node 4 Leaf Leaf)) (Node 13 Leaf Leaf)) = Just (2,Node 10 (Node 4 Leaf Leaf) (Node 13 Leaf Leaf)) 10 10 / \ / \ 2 13 ~~~> 2 and 4 13 + \ + + + + + + 4 + + removeLeftMost (Node 5 (Node 1 Leaf Leaf) (Node 6 Leaf Leaf)) = Just (1,Node 5 Leaf (Node 6 Leaf Leaf)) 5 5 / \ + \ 1 6 ~~~> 1 and 6 + + + + + + removeLeftMost Leaf = Nothing c) Define a function delete :: Ord a => a -> Tree a -> Tree a that deletes an element from a binary search tree. Use the function from b if you are at the node where the element that should be removed is stored. d) Define a function balanceFactor :: Tree a -> Int that computes the balance factor of the root of the given tree. The balance factor is the difference of the height of the right and the left subtree. e) Use d to define a function balanced :: Tree a -> Bool that checks whether the input tree is balanced. A tree is balanced if the absolut value of balance factor is smaller or equal to 1,i.e., the height of the left and right subtree differs by at most 1. f) Implement for functions rotate_left, rotate_right, rotate_left_right, rotate_right_left :: Tree a -> Tree a which perform the correspnding rotation on the tree (cf. Wikipedia AVL tree). g) Define a function balanceRoot :: Tree a -> Tree a that balances the root of the given tree using the rotations from f. Here we assume that the balance factor of the root is in the range -2..2 and that all sbtrees are already balanced (cf. Wikipedia AVL tree). h) Implement the function balance :: Tree a -> Tree a that balances a tree after insertion or deletion. Any leaf is already balanced and at an inner node apply the function from g after recursively balancing the left and right subtree. After implementing this question you can also test your program by call the function main() below (currently commented). The program will does the same steps a the animated example on the Wikipedia page for AVL Trees. -} data Tree a = Leaf | Node a (Tree a) (Tree a) showTree :: Show a => Int -> Tree a -> String showTree n Leaf = replicate n ' ' ++ "Leaf\n" showTree n (Node a t1 t2) = replicate n ' ' ++ show a ++ "\n" ++ showTree (n+2) t1 ++ showTree (n+2) t2 instance Show a => Show (Tree a) where show t = showTree 0 t height :: Tree a -> Int height Leaf = 0 height (Node _ t1 t2) = 1+max (height t1) (height t2) insert :: Ord a => a -> Tree a -> Tree a insert a Leaf = Node a Leaf Leaf insert a (Node b t1 t2) | a <= b = Node b (insert a t1) t2 | otherwise = Node b t1 (insert a t2) removeLeftMost :: Tree a -> Maybe (a,Tree a) removeLeftMost Leaf = Nothing removeLeftMost (Node a Leaf t2) = Just (a,t2) removeLeftMost (Node a t1 t2) = Just (r,Node a t' t2) where Just (r,t') = removeLeftMost t1 delete :: Ord a => a -> Tree a -> Tree a delete a Leaf = Leaf delete a (Node b t1 t2) | a == b = maybe t1 (\(r,t') -> Node r t1 t') (removeLeftMost t2) | a <= b = Node b (delete a t1) t2 | otherwise = Node b t1 (delete a t2) balanceFactor :: Tree a -> Int balanceFactor Leaf = 0 balanceFactor (Node _ t1 t2) = height t2 - height t1 isBalanced :: Tree a -> Bool isBalanced Leaf = True isBalanced t@(Node _ t1 t2) = isBalanced t1 && isBalanced t2 && abs (balanceFactor t) <= 1 rotate_left :: Tree a -> Tree a rotate_left (Node a t1 (Node b t2 t3)) = Node b (Node a t1 t2) t3 rotate_right :: Tree a -> Tree a rotate_right (Node a (Node b t1 t2) t3) = Node b t1 (Node a t2 t3) rotate_right_left :: Tree a -> Tree a rotate_right_left (Node a t1 t2) = rotate_left (Node a t1 (rotate_right t2)) rotate_left_right :: Tree a -> Tree a rotate_left_right (Node a t1 t2) = rotate_right (Node a (rotate_left t1) t2) balanceRoot :: Tree a -> Tree a balanceRoot t@(Node a t1 t2) | bt == 2 && bt2 == -1 = rotate_right_left t | bt == 2 && otherwise = rotate_left t | bt == -2 && bt1 == 1 = rotate_left_right t | bt == -2 && otherwise = rotate_right t | otherwise = t where bt = balanceFactor t bt1 = balanceFactor t1 bt2 = balanceFactor t2 balance :: Tree a -> Tree a balance Leaf = Leaf balance (Node a t1 t2) = balanceRoot (Node a (balance t1) (balance t2)) main :: IO () main = runExample ['m','n','o','l','k','q','p','h','i','a'] Leaf where runExample :: (Ord a, Show a) => [a] -> Tree a -> IO () runExample [] t = print t runExample (a:as) t = do print t putStrLn "Hit any key." getChar runExample as (insert a t)