Commit d881a0f1 authored by Tom Bower's avatar Tom Bower
Browse files
parents 65667ad8 0e2210a3
{-
Ashley Davies ad5615
http://facebook.com/ashleydavies5
General notice for all my additions:
Not sure which ones I tidied up, so if I haven't tidied this one,
it may be messy.
My variables names are often abhorrent sorry ;D feel free to drop me a fb
message for any clarifications or anything, always more than happy to help out
-}
import Data.List
import Debug.Trace
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 v
= snd . head . filter ((==v) . fst)
checkSat :: BDD -> Env -> Bool
checkSat (root, nodes) env
| root == 1 = True
| root == 0 = False
| varState = checkSat (itr, nodes) env
| not varState = checkSat (ifa, nodes) env
where
initial@(ivar, ifa, itr) = lookUp root nodes
varState = lookUp ivar env
sat :: BDD -> [[(Index, Bool)]]
sat (root, nodes)
| root == 1 = [[]]
| root == 0 = []
| otherwise = itrReturn ++ ifaReturn
where
initial@(ivar, ifa, itr) = lookUp root nodes
itrReturn = map ((ivar, True) :) (sat (itr, nodes))
ifaReturn = map ((ivar, False):) (sat (ifa, nodes))
------------------------------------------------------
-- PART II
simplify :: BExp -> BExp
simplify (Not (Prim v1) ) = Prim (not v1)
simplify (And (Prim v1) (Prim v2)) = Prim (v1 && v2)
simplify (Or (Prim v1) (Prim v2)) = Prim (v1 || v2)
simplify v1 = v1
restrict :: BExp -> Index -> Bool -> BExp
restrict (Prim v1) _ _ = Prim v1
restrict (IdRef v1) i b = case v1 == i of
True -> Prim b
False -> IdRef v1
restrict (Not v1) i b
= simplify (Not (restrict v1 i b))
restrict (And v1 v2) i b
= simplify (And (restrict v1 i b) (restrict v2 i b))
restrict (Or v1 v2) i b
= simplify (Or (restrict v1 i b) (restrict v2 i b))
------------------------------------------------------
-- PART III
-- Pre: Each variable index in the BExp appears exactly
-- once in the Index list; there are no other elements
buildBDD :: BExp -> [Index] -> BDD
buildBDD
= flip buildBDD' 2
buildBDD' :: BExp -> NodeId -> [Index] -> BDD
buildBDD' (Prim True ) _ [] = (1,[])
buildBDD' (Prim False) _ [] = (0,[])
buildBDD' exp nID (x:xs)
= (nID, (nID, (x, lI, rI)) : (lL ++ rL))
where
expL = restrict exp x False
expR = restrict exp x True
(lI, lL) = buildBDD' expL (nID * 2 ) xs
(rI, rL) = buildBDD' expR (nID * 2 + 1) xs
------------------------------------------------------
-- PART IV
-- Pre: Each variable index in the BExp appears exactly once
-- in the Index list; there are no other elements
buildROBDD :: BExp -> [Index] -> BDD
buildROBDD = flip ((flip bQROBDD) []) 2
-- Build Queued ROBDD
bQROBDD :: BExp -> [BDDNode] -> NodeId -> [Index] -> BDD
bQROBDD (Prim True ) _ _ [] = (1,[])
bQROBDD (Prim False) _ _ [] = (0,[])
bQROBDD exp nodeList nID (x:xs)
= case identicalSubTree nodeList (curNode) of
Nothing -> case lI == rI of
False -> (nID, curNode : (lL ++ rL))
True -> (lI, lL ++ rL)
Just x -> (x, [])
where
expL = restrict exp x False
expR = restrict exp x True
curNode = (nID, (x, lI, rI))
newNodeList = union nodeList lL
(lI, lL) = bQROBDD expL nodeList (nID * 2) xs
(rI, rL) = bQROBDD expR newNodeList (nID * 2 + 1) xs
bQROBDD exp a1 a2 a3 = bQROBDD (simplify exp) a1 a2 a3
identicalSubTree :: [BDDNode] -> BDDNode -> Maybe NodeId
identicalSubTree [] _ = Nothing
identicalSubTree ((nodeID, (nIndex, nr, nl)):ns)
c@(_ , (cIndex, cr, cl))
| nl == cl && nr == cr
&& nIndex == cIndex = Just nodeID
| otherwise = identicalSubTree ns c
------------------------------------------------------
-- 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))])
{-
Ashley Davies ad5615
http://facebook.com/ashleydavies5
General notice for all my additions:
Not sure which ones I tidied up, so if I haven't tidied this one,
it may be messy.
My variables names are often abhorrent sorry ;D feel free to drop me a fb
message for any clarifications or anything, always more than happy to help out
-}
data SuffixTree = Leaf Int | Node [(String, SuffixTree)]
deriving (Eq, Show)
------------------------------------------------------
isPrefix :: String -> String -> Bool
isPrefix s1 s2
= (length s1 <= length s2) && (and $ zipWith (==) s1 s2)
removePrefix :: String -> String -> String
removePrefix
--Pre: s is a prefix of s'
= drop . length
suffixes :: [a] -> [[a]]
suffixes [] = []
suffixes s = s:(suffixes $ tail s)
isSubstring :: String -> String -> Bool
isSubstring s1
= (or . map (isPrefix s1)) . suffixes
findSubstrings :: String -> String -> [Int]
findSubstrings s1
= reverse . drop 1 . foldl (\(h:xs) x -> case x of True -> (h+1):h:xs
False -> (h+1) :xs) [0]
. map (isPrefix s1) . suffixes
------------------------------------------------------
getIndices :: SuffixTree -> [Int]
getIndices (Node xs) = concatMap (getIndices.snd) xs
getIndices (Leaf v) = [v]
partition :: Eq a => [a] -> [a] -> ([a], [a], [a])
partition [] s1 = ([], [], s1)
partition s1 [] = ([], s1, [])
partition s1@(c1:c1s) s2@(c2:c2s)
= case c1 == c2 of
True -> (c1:preCont, lCont, rCont)
False -> ([] , s1 , s2)
where
(preCont, lCont, rCont) = partition c1s c2s
findSubstrings' :: String -> SuffixTree -> [Int]
findSubstrings' s (Node xs)
= foldr (\(a, rec) acc -> let (mutual, lLeft, rLeft) = partition s a in
if lLeft == [] then
getIndices rec ++ acc
else if rLeft == [] then
findSubstrings' lLeft rec ++ acc
else acc) [] xs
findSubstrings' [] (Leaf v) = [v]
findSubstrings' s (Leaf _) = [ ]
------------------------------------------------------
commonPrefix :: Eq a => [a] -> [a] -> Bool
commonPrefix s1 s2 = prefix /= []
where
(prefix,_,_) = partition s1 s2
insert :: (String, Int) -> SuffixTree -> SuffixTree
insert (s, n) (Node xs)
| filter (commonPrefix s . fst) xs == [] = (Node ((s, Leaf n):xs))
| otherwise = Node (foldr insertCumulative [] xs)
where
insertCumulative :: (String, SuffixTree) -> [(String, SuffixTree)] -> [(String, SuffixTree)]
insertCumulative stree@(a, t) acc
| mutual == [] = stree:acc
| rLeft == [] = (a, insert (lLeft, n) t):acc
| otherwise = (mutual, Node [(lLeft, Leaf n), (rLeft, t)]):acc
where (mutual, lLeft, rLeft) = 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
= undefined
------------------------------------------------------
-- 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)])]
{-
Ashley Davies ad5615
http://facebook.com/ashleydavies5
General notice for all my additions:
Not sure which ones I tidied up, so if I haven't tidied this one,
it may be messy.
My variables names are often abhorrent sorry ;D feel free to drop me a fb
message for any clarifications or anything, always more than happy to help out
-}
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
= flip tryToLookUp undefined
tryToLookUp :: Eq a => a -> b -> [(a, b)] -> b
tryToLookUp c d xs
= head $ [ y | (x, y) <- xs, x == c ] ++ [d]
-- Pre: The given value is in the table
reverseLookUp :: Eq b => b -> [(a, b)] -> [a]
reverseLookUp c xs
= [ x | (x, y) <- xs, y == c ]
occurs :: String -> Type -> Bool
occurs _ TInt = False
occurs _ TBool = False
occurs _ TErr = False
occurs s (TVar c) = s == c
occurs s (TFun c1 c2) = occurs s c1 || occurs s c2
------------------------------------------------------
-- 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 (Prim p) _ = lookUp p primTypes
inferType (Id i) te = lookUp i te
inferType (Cond e1 e2 e3) te
| error = TErr
| otherwise = e2T
where
e1T = inferType e1 te
e2T = inferType e2 te
e3T = inferType e3 te
error = e1T /= TBool || e2T /= e3T
inferType (App fun arg) tenv
| error = TErr
| otherwise = funReturnType
where
funType = inferType fun tenv
argType = inferType arg tenv
-- This pattern match is only ever evaluated if "not (isTFun e1T)" is false
-- hence -- it is only evaluated if it is a function. Otherwise
-- it immediately shortcircuits an error :)
TFun funParamType funReturnType = funType
error = not (isTFun funType) || funParamType /= argType
isTFun :: Type -> Bool
isTFun (TFun _ _) = True
isTFun _ = False
------------------------------------------------------
-- PART III
applySub :: Sub -> Type -> Type
applySub s (TFun t1 t2) = TFun (applySub s t1) (applySub s t2)
applySub s (TVar var ) = tryToLookUp var (TVar var) s
applySub s v = v
unify :: Type -> Type -> Maybe Sub
unify t t'
= unifyPairs [(t, t')] []
unifyPairs :: [(Type, Type)] -> Sub -> Maybe Sub
unifyPairs [] s = Just s
unifyPairs (x:xs) s
= case x of
(TInt , TInt ) -> unifyPairs xs s
(TBool , TBool ) -> unifyPairs xs s
(TVar v, t@(TVar v'))
-> if v == v'
then unifyPairs xs s
else unifyPairs (mapBTuple (applySub [(v,t)]) xs) ((v,t):s)
(TVar v, t )
-> if occurs v t
then Nothing
else unifyPairs (mapBTuple (applySub [(v,t)]) xs) ((v,t):s)
(t , TVar v )
-> if occurs v t
then Nothing
else unifyPairs (mapBTuple (applySub [(v,t)]) xs) ((v,t):s)
(TFun t1 t2, TFun t1' t2')
-> unifyPairs ((t1,t1'):(t2,t2'):xs) s
(_ , _ ) -> Nothing
-- BTuple = Shorthand for binary tuple / of the form ( _ , _ )
mapBTuple :: (a -> b) -> [(a,a)] -> [(b,b)]
mapBTuple f ls = zip (map (f . fst) ls) (map (f . snd) ls)
------------------------------------------------------
-- 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"))
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment