Commit c38156ab authored by Tom Bower's avatar Tom Bower
Browse files

First commit of all my Exam.hs files 2009-15 inclusive

parent 80bd6c86
import Data.List
type Index = Int
data BExp = Prim Bool | IdRef Index | Not BExp | And BExp BExp | Or BExp BExp
deriving (Eq, Ord, Show)
type Env = [(Index, Bool)]
type NodeId = Int
type BDDNode = (NodeId, (Index, NodeId, NodeId))
type BDD = (NodeId, [BDDNode])
------------------------------------------------------
-- PART I
-- Pre: The item is in the given table
lookUp :: Eq a => a -> [(a, b)] -> b
lookUp x xs
= head [b | (a, b) <- xs, a == x]
checkSat :: BDD -> Env -> Bool
checkSat (id, ns) env
| id == 1 = True
| id == 0 = False
| otherwise = checkSat (nextNode, ns) env
where
(i, ifa, itr) = lookUp id ns
nextNode = if lookUp i env then itr
else ifa
sat :: BDD -> [[(Index, Bool)]]
sat (0, _) = []
sat (1, _) = [[]]
sat (id, ns)
= map ((i, False) :) (sat (ifa, ns)) ++ map ((i, True) :) (sat (itr, ns))
where
(i, ifa, itr) = lookUp id ns
------------------------------------------------------
-- PART II
simplify :: BExp -> BExp
simplify (Not (Prim b)) = Prim (not b)
simplify (Or (Prim b) (Prim b')) = Prim (b || b')
simplify (And (Prim b) (Prim b')) = Prim (b && b')
simplify any = any
restrict :: BExp -> Index -> Bool -> BExp
restrict (IdRef id) i b = if id == i then Prim b
else IdRef id
restrict (Prim e) _ _ = Prim e
restrict (Not e) i b = simplify $ Not (restrict e i b)
restrict (Or e e') i b = simplify $ Or (restrict e i b) (restrict e' i b)
restrict (And e e') i b = simplify $ And (restrict e i b) (restrict e' i b)
------------------------------------------------------
-- PART III
-- Pre: Each variable index in the BExp appears exactly once
-- in the Index list; there are no other elements
-- The question suggests the following definition (in terms of buildBDD')
-- but you are free to implement the function differently if you wish.
buildBDD :: BExp -> [Index] -> BDD
buildBDD e (x: xs)
= buildBDD' e 2 (x: xs)
where
buildBDD' :: BExp -> NodeId -> [Index] -> BDD
buildBDD' (Prim False) _ [] = (0, [])
buildBDD' (Prim True) _ [] = (1, [])
buildBDD' e' id (y: ys)
= (id, (id, (y, lid, rid)) : (lnodes ++ rnodes))
where
(lid, lnodes) = buildBDD' (restrict e' y False) (id * 2) ys
(rid, rnodes) = buildBDD' (restrict e' y True) (id * 2 + 1) ys
------------------------------------------------------
-- PART IV
getRedundantNodes :: [BDDNode] -> ([BDDNode], [BDDNode])
getRedundantNodes ns
= let redundantNodes = [(nid, (i, l, r)) | (nid, (i, l, r)) <- ns, l == r]
in (redundantNodes, ns \\ redundantNodes)
redundantNodeHeadTail :: NodeId -> [BDDNode] -> (NodeId, NodeId)
redundantNodeHeadTail id ns
= undefined
fixRedundantNodes :: [BDDNode] -> [BDDNode]
fixRedundantNodes ns
= (filter (\(x,_) -> notElem x (map fst nodeParents)) ns\\redNs) ++ fixedNodes
where
redNs = [n | n@(_, (_, l, r)) <- ns, l == r]
nodeChildren = map (\(_, (_, _, r)) -> r) redNs
nodeParents = map (flip getParentNodeInfo ns) redNs
parentsKids = zip (map fst nodeParents) nodeChildren
fixedNodesR = [(id, (i, l, lookUp id parentsKids))
| (id, (i, l, r)) <- ns\\redNs, elem (id, True) nodeParents]
fixedNodesL = [(id, (i, lookUp id parentsKids, r))
| (id, (i, l, r)) <- ns\\redNs, elem (id, False) nodeParents]
fixedNodes = fixedNodesR ++ fixedNodesL
-- Put in a node ID, and it will return the parent's ID along with if it is
-- parents for true or false.
getParentNodeInfo :: BDDNode -> [BDDNode] -> (NodeId, Bool)
getParentNodeInfo (id, _) ns
= head [(idP, r == id) | (idP, (i, l, r)) <- ns, l == id || r == id]
-- Pre: Each variable index in the BExp appears exactly once
-- in the Index list; there are no other elements
buildROBDD :: BExp -> [Index] -> BDD
buildROBDD
= undefined
------------------------------------------------------
-- Examples for testing...
b1, b2, b3, b4, b5, b6, b7, b8 :: BExp
b1 = Prim False
b2 = Not (And (IdRef 1) (Or (Prim False) (IdRef 2)))
b3 = And (IdRef 1) (Prim True)
b4 = And (IdRef 7) (Or (IdRef 2) (Not (IdRef 3)))
b5 = Not (And (IdRef 7) (Or (IdRef 2) (Not (IdRef 3))))
b6 = Or (And (IdRef 1) (IdRef 2)) (And (IdRef 3) (IdRef 4))
b7 = Or (Not (IdRef 3)) (Or (IdRef 2) (Not (IdRef 9)))
b8 = Or (IdRef 1) (Not (IdRef 1))
bdd1, bdd2, bdd3, bdd4, bdd5, bdd6, bdd7, bdd8 :: BDD
bdd1 = (0,[])
bdd2 = (2,[(4,(2,1,1)),(5,(2,1,0)),(2,(1,4,5))])
bdd3 = (5,[(5,(1,0,1))])
bdd4 = (2,[(2,(2,4,5)),(4,(3,8,9)),(8,(7,0,1)),(9,(7,0,0)),
(5,(3,10,11)),(10,(7,0,1)),(11,(7,0,1))])
bdd5 = (3,[(4,(3,8,9)),(3,(2,4,5)),(8,(7,1,0)),(9,(7,1,1)),
(5,(3,10,11)),(10,(7,1,0)),(11,(7,1,0))])
bdd6 = (2,[(2,(1,4,5)),(4,(2,8,9)),(8,(3,16,17)),(16,(4,0,0)),
(17,(4,0,1)),(9,(3,18,19)),(18,(4,0,0)),(19,(4,0,1)),
(5,(2,10,11)),(10,(3,20,21)),(20,(4,0,0)),(21,(4,0,1)),
(11,(3,22,23)),(22,(4,1,1)),(23,(4,1,1))])
bdd7 = (6,[(6,(2,4,5)),(4,(3,8,9)),(8,(9,1,1)),(9,(9,1,0)),
(5,(3,10,11)),(10,(9,1,1)),(11,(9,1,1))])
bdd8 = (2,[(2,(1,1,1))])
data SuffixTree = Leaf Int | Node [(String, SuffixTree)]
deriving (Eq, Show)
------------------------------------------------------
isPrefix :: String -> String -> Bool
isPrefix [] _ = True
isPrefix _ [] = False
isPrefix (x:xs) (y:ys) = x == y && isPrefix xs ys
--Pre: s is a prefix of s'
removePrefix :: String -> String -> String
removePrefix [] ys = ys
removePrefix (x:xs) (y:ys) = removePrefix xs ys
suffixes :: [a] -> [[a]]
suffixes [] = []
suffixes (x:xs) = (x:xs) : suffixes xs
isSubstring :: String -> String -> Bool
isSubstring xs ys = or $ map (isPrefix xs) (suffixes ys)
findSubstrings :: String -> String -> [Int]
findSubstrings xs ys
= map fst $ filter ((isPrefix xs) . snd) (zip [0..] (suffixes ys))
------------------------------------------------------
getIndices :: SuffixTree -> [Int]
getIndices (Leaf n) = [n]
getIndices (Node ts) = concatMap (getIndices . snd) ts
partition :: Eq a => [a] -> [a] -> ([a], [a], [a])
partition [] ys = ([], [], ys)
partition xs [] = ([], xs, [])
partition (x : xs) (y : ys)
| x == y = ([x] ++ xAndY, xs', ys')
| otherwise = ([], x : xs, y : ys)
where (xAndY, xs', ys') = partition xs ys
findSubstrings' :: String -> SuffixTree -> [Int]
findSubstrings' [] (Leaf n) = [n]
findSubstrings' s (Leaf n) = []
findSubstrings' s (Node []) = []
findSubstrings' s (Node ((a, t):ts))
| null s' = getIndices t
| null a' = findSubstrings' s' t
| otherwise = findSubstrings' s (Node ts)
where (_, s', a') = partition s a
------------------------------------------------------
insert :: (String, Int) -> SuffixTree -> SuffixTree
insert (s, n) (Node [])
= Node [(s, Leaf n)]
insert (s, n) (Node ((a, t) : xs))
| null p = let Node xs' = (insert (s, n) (Node xs)) in Node $ (a, t) : xs'
| p == a = Node $ (a, insert (s', n) t) : xs
| p /= a = Node $ (p, Node [(s', Leaf n), (a', t)]) : xs
where (p, s', a') = partition s a
-- This function is given
buildTree :: String -> SuffixTree
buildTree s
= foldl (flip insert) (Node []) (zip (suffixes s) [0..length s-1])
------------------------------------------------------
-- Part IV
longestRepeatedSubstring :: SuffixTree -> String
longestRepeatedSubstring t
= snd $ maximum $ map (\x -> (length x, x)) ((repeats t "") ++ [""])
where
repeats :: SuffixTree -> String -> [String]
repeats (Node ts) s | length ts > 1
= s : concatMap (\(a, t) -> repeats t (s ++ a)) ts
repeats _ _ = []
------------------------------------------------------
-- Example strings and suffix trees...
s1 :: String
s1
= "banana"
s2 :: String
s2
= "mississippi"
t1 :: SuffixTree
t1
= Node [("banana", Leaf 0),
("a", Node [("na", Node [("na", Leaf 1),
("", Leaf 3)]),
("", Leaf 5)]),
("na", Node [("na", Leaf 2),
("", Leaf 4)])]
t2 :: SuffixTree
t2
= Node [("mississippi", Leaf 0),
("i", Node [("ssi", Node [("ssippi", Leaf 1),
("ppi", Leaf 4)]),
("ppi", Leaf 7),
("", Leaf 10)]),
("s", Node [("si", Node [("ssippi", Leaf 2),
("ppi", Leaf 5)]),
("i", Node [("ssippi", Leaf 3),
("ppi", Leaf 6)])]),
("p", Node [("pi", Leaf 8),
("i", Leaf 9)])]
import Data.Maybe
data Expr = Number Int |
Boolean Bool |
Id String |
Prim String |
Cond Expr Expr Expr |
App Expr Expr |
Fun String Expr
deriving (Eq, Show)
data Type = TInt |
TBool |
TFun Type Type |
TVar String |
TErr
deriving (Eq, Show)
showT :: Type -> String
showT TInt
= "Int"
showT TBool
= "Bool"
showT (TFun t t')
= "(" ++ showT t ++ " -> " ++ showT t' ++ ")"
showT (TVar a)
= a
showT TErr
= "Type error"
type TypeTable = [(String, Type)]
type TEnv
= TypeTable -- i.e. [(String, Type)]
type Sub
= TypeTable -- i.e. [(String, Type)]
-- Built-in function types...
primTypes :: TypeTable
primTypes
= [("+", TFun TInt (TFun TInt TInt)),
(">", TFun TInt (TFun TInt TBool)),
("==", TFun TInt (TFun TInt TBool)),
("not", TFun TBool TBool)]
------------------------------------------------------
-- PART I
-- Pre: The search item is in the table
lookUp :: Eq a => a -> [(a, b)] -> b
lookUp x xs
= tryToLookUp x undefined xs
tryToLookUp :: Eq a => a -> b -> [(a, b)] -> b
tryToLookUp x alt xs
= head $ [v | (k, v) <- xs, k == x] ++ [alt]
-- Pre: The given value is in the table
reverseLookUp :: Eq b => b -> [(a, b)] -> [a]
reverseLookUp x xs
= map fst (filter ((==x) . snd) xs)
occurs :: String -> Type -> Bool
occurs s (TFun t t')
= occurs s t || occurs s t'
occurs s (TVar t)
= s == t
occurs _ _
= False
------------------------------------------------------
-- PART II
-- Pre: There are no user-defined functions (constructor Fun)
-- Pre: All type variables in the expression have a binding in the given
-- type environment
inferType :: Expr -> TEnv -> Type
inferType (Number _) _
= TInt
inferType (Boolean _) _
= TBool
inferType (Id i) env
= lookUp i env
inferType (Prim p) _
= lookUp p primTypes
inferType (Cond p t f) env
| pIsBool && typeT == typeF = typeT
| otherwise = TErr
where
typeT = inferType t env
typeF = inferType f env
pIsBool = inferType p env == TBool
inferType (App f a) env
= inferApp (inferType f env) (inferType a env) env
inferApp :: Type -> Type -> TEnv -> Type
inferApp (TFun t t') typeA env
| t == typeA = t'
inferApp _ _ _
= TErr
------------------------------------------------------
-- PART III
applySub :: Sub -> Type -> Type
applySub s (TFun t t')
= TFun (applySub s t) (applySub s t')
applySub s (TVar v)
= tryToLookUp v (TVar v) s
applySub _ t
= t
unify :: Type -> Type -> Maybe Sub
unify t t'
= unifyPairs [(t, t')] []
unifyPairs :: [(Type, Type)] -> Sub -> Maybe Sub
unifyPairs ((TInt _, TInt _):ts) sub = unifyPairs ts sub
unifyPairs ((TBool _, TBool _):ts) sub = unifyPairs ts sub
unifyPairs ((TVar v, TVar v'):ts) sub
| v == v' = unifyPairs ts sub
unifyPairs ((a, b):ts) sub
= unifyPairs (map (\(x,y) -> (applySub (v1,v2) x, applySub (v1,v2) y)) ts) ((v1,v2):sub)
where
v1 = if a == TVar v then v else a
v2 = if b == TVar v' then v' else b
------------------------------------------------------
-- PART IV
updateTEnv :: TEnv -> Sub -> TEnv
updateTEnv tenv tsub
= map modify tenv
where
modify (v, t) = (v, applySub tsub t)
combine :: Sub -> Sub -> Sub
combine sNew sOld
= sNew ++ updateTEnv sOld sNew
-- In combineSubs [s1, s2,..., sn], s1 should be the *most recent* substitution
-- and will be applied *last*
combineSubs :: [Sub] -> Sub
combineSubs
= foldr1 combine
inferPolyType :: Expr -> Type
inferPolyType
= undefined
-- You may optionally wish to use one of the following helper function declarations
-- as suggested in the specification.
-- inferPolyType' :: Expr -> TEnv -> [String] -> (Sub, Type, [String])
-- inferPolyType'
-- = undefined
-- inferPolyType' :: Expr -> TEnv -> Int -> (Sub, Type, Int)
-- inferPolyType'
-- = undefined
------------------------------------------------------
-- Monomorphic type inference test cases from Table 1...
env :: TEnv
env = [("x",TInt),("y",TInt),("b",TBool),("c",TBool)]
ex1, ex2, ex3, ex4, ex5, ex6, ex7, ex8 :: Expr
type1, type2, type3, type4, type5, type6, type7, type8 :: Type
ex1 = Number 9
type1 = TInt
ex2 = Boolean False
type2 = TBool
ex3 = Prim "not"
type3 = TFun TBool TBool
ex4 = App (Prim "not") (Boolean True)
type4 = TBool
ex5 = App (Prim ">") (Number 0)
type5 = TFun TInt TBool
ex6 = App (App (Prim "+") (Boolean True)) (Number 5)
type6 = TErr
ex7 = Cond (Boolean True) (Boolean False) (Id "c")
type7 = TBool
ex8 = Cond (App (Prim "==") (Number 4)) (Id "b") (Id "c")
type8 = TErr
------------------------------------------------------
-- Unification test cases from Table 2...
u1a, u1b, u2a, u2b, u3a, u3b, u4a, u4b, u5a, u5b, u6a, u6b :: Type
sub1, sub2, sub3, sub4, sub5, sub6 :: Maybe Sub
u1a = TFun (TVar "a") TInt
u1b = TVar "b"
sub1 = Just [("b",TFun (TVar "a") TInt)]
u2a = TFun TBool TBool
u2b = TFun TBool TBool
sub2 = Just []
u3a = TFun (TVar "a") TInt
u3b = TFun TBool TInt
sub3 = Just [("a",TBool)]
u4a = TBool
u4b = TFun TInt TBool
sub4 = Nothing
u5a = TFun (TVar "a") TInt
u5b = TFun TBool (TVar "b")
sub5 = Just [("b",TInt),("a",TBool)]
u6a = TFun (TVar "a") (TVar "a")
u6b = TVar "a"
sub6 = Nothing
------------------------------------------------------
-- Polymorphic type inference test cases from Table 3...
ex9, ex10, ex11, ex12, ex13, ex14 :: Expr
type9, type10, type11, type12, type13, type14 :: Type
ex9 = Fun "x" (Boolean True)
type9 = TFun (TVar "a1") TBool
ex10 = Fun "x" (Id "x")
type10 = TFun (TVar "a1") (TVar "a1")
ex11 = Fun "x" (App (Prim "not") (Id "x"))
type11 = TFun TBool TBool
ex12 = Fun "x" (Fun "y" (App (Id "y") (Id "x")))
type12 = TFun (TVar "a1") (TFun (TFun (TVar "a1") (TVar "a3")) (TVar "a3"))
ex13 = Fun "x" (Fun "y" (App (App (Id "y") (Id "x")) (Number 7)))
type13 = TFun (TVar "a1") (TFun (TFun (TVar "a1") (TFun TInt (TVar "a3")))
(TVar "a3"))
ex14 = Fun "x" (Fun "y" (App (Id "x") (Prim "+")))
type14 = TFun (TFun (TFun TInt (TFun TInt TInt)) (TVar "a3"))
(TFun (TVar "a2") (TVar "a3"))
import Data.List
import Data.Maybe
type Id = String
type State = Int
type Transition = ((State, State), Id)
type LTS = [Transition]
type Alphabet = [Id]
data Process = STOP | Ref Id | Prefix Id Process | Choice [Process]
deriving (Eq, Show)
type ProcessDef = (Id, Process)
type StateMap = [((State, State), State)]
------------------------------------------------------
-- PART I
lookUp :: Eq a => a -> [(a, b)] -> b
--Pre: The item is in the table
lookUp x xs
= head [v | (k, v) <- xs, k == x]
states :: LTS -> [State]
states lts
= sort $ nub $ concat $ [[s1, s2] | ((s1, s2), _) <- lts]
transitions :: State -> LTS -> [Transition]
transitions s lts
= [t | t@((s', _), _) <- lts, s == s']
alphabet :: LTS -> Alphabet
alphabet lts
= nub $ map snd lts
------------------------------------------------------
-- PART II
actions :: Process -> [Id]
actions (Choice ps) = nub $ concatMap actions ps
actions (Prefix i p) = nub $ i : actions p
actions _ = []
-- [(Id, Process)]
accepts :: [Id] -> [ProcessDef] -> Bool
--Pre: The first item in the list of process definitions is
-- that of the start process.
accepts is pds
= accepts' is (snd (head pds))
where
accepts' :: [Id] -> Process -> Bool
accepts' [] _ = True
accepts' (i : is) (Prefix i' p) = i == i' && accepts' is p
accepts' is (Ref r) = accepts' is (lookUp r pds)
accepts' is (Choice ps) = any (accepts' is) ps
accepts' _ STOP = False
------------------------------------------------------
-- PART III
composeTransitions :: Transition -> Transition
-> Alphabet -> Alphabet
-> StateMap
-> [Transition]
--Pre: The first alphabet is that of the LTS from which the first transition is
-- drawn; likewise the second.
--Pre: All (four) pairs of source and target states drawn from the two transitions
-- are contained in the given StateMap.
composeTransitions ((s, s'), a) ((t, t'), a') a1 a2 sm
| a == a' =