Skip to content
Snippets Groups Projects
Commit 10551cb5 authored by ik1g19's avatar ik1g19
Browse files

formatted for submission, fuck challenge 6

parent 5af70b30
No related branches found
No related tags found
No related merge requests found
...@@ -4,10 +4,9 @@ ...@@ -4,10 +4,9 @@
-- Skeleton code to be updated with your solutions -- Skeleton code to be updated with your solutions
-- The dummy functions here simply return an arbitrary value that is usually wrong -- The dummy functions here simply return an arbitrary value that is usually wrong
-- DO NOT MODIFY THE FOLLOWING LINES OF CODE
module Challenges (WordSearchGrid,Placement,Posn,Orientation(..),solveWordSearch, createWordSearch, module Challenges (WordSearchGrid,Placement,Posn,Orientation(..),solveWordSearch, createWordSearch,
LamMacroExpr(..),LamExpr(..),prettyPrint, parseLamMacro, LamMacroExpr(..),LamExpr(..),prettyPrint, parseLamMacro,
cpsTransform,innerRedn1,outerRedn1,compareInnerOuter,ex6'1,ex6'2,ex6'3,ex6'4,ex6'5,ex6'6,ex6'7,eval1cbv,eval1cbn,reductions,trace,ex5'1,ex5'2,ex5'3,ex5'4,highestVar,exId,freeVar,unique,closed) where cpsTransform,innerRedn1,outerRedn1,compareInnerOuter) where
-- Import standard library and parsing definitions from Hutton 2016, Chapter 13 -- Import standard library and parsing definitions from Hutton 2016, Chapter 13
-- We import System.Random - make sure that your installation has it installed - use stack ghci and stack ghc -- We import System.Random - make sure that your installation has it installed - use stack ghci and stack ghc
...@@ -98,9 +97,12 @@ nextPos DownForward (x,y) = (x+1,y+1) ...@@ -98,9 +97,12 @@ nextPos DownForward (x,y) = (x+1,y+1)
nextPos DownBack (x,y) = (x-1,y+1) nextPos DownBack (x,y) = (x-1,y+1)
----------------------------Utility Functions-----------------------------------
elemAt :: [[a]] -> Posn -> a elemAt :: [[a]] -> Posn -> a
elemAt ass (x,y) = (ass !! y) !! x -- | ass means list of list of a's, elemAt ass (x,y) = (ass !! y) !! x
-- | not associated with any other meaning
{--| returns specified adjacent element in grid, |-- {--| returns specified adjacent element in grid, |--
--| relative to given position |--} --| relative to given position |--}
...@@ -260,6 +262,10 @@ prettyPrint :: LamMacroExpr -> String ...@@ -260,6 +262,10 @@ prettyPrint :: LamMacroExpr -> String
prettyPrint (LamDef ms e) = macroDef ms ++ exprToStr ms e prettyPrint (LamDef ms e) = macroDef ms ++ exprToStr ms e
----------------------------Primary Functions-----------------------------------
{--| converts bindings to strings |--}
macroDef :: [(String,LamExpr)] -> String macroDef :: [(String,LamExpr)] -> String
macroDef [] = "" macroDef [] = ""
macroDef ( (name,expr):ms ) = foldl1 (++) ["def ",name," = ",exprToStr [] expr," in ",macroDef ms] macroDef ( (name,expr):ms ) = foldl1 (++) ["def ",name," = ",exprToStr [] expr," in ",macroDef ms]
...@@ -284,8 +290,8 @@ exprToStr ms e@(LamApp e1 e2) | e == eNone = none ...@@ -284,8 +290,8 @@ exprToStr ms e@(LamApp e1 e2) | e == eNone = none
| e == eRight = right | e == eRight = right
| e == eBoth = both | e == eBoth = both
where where
none = foldl1 (++) [ catchMacro ms e1, " ", catchMacro ms e2 ] none = foldl1 (++) [ catchMacro ms e1, " ", catchMacro ms e2 ] -- | applying different uses of parenthese to
left = foldl1 (++) ["(",catchMacro ms e1,") ", catchMacro ms e2 ] left = foldl1 (++) ["(",catchMacro ms e1,") ", catchMacro ms e2 ] -- | determine when they are necessary
right = foldl1 (++) [ catchMacro ms e1, " (",catchMacro ms e2,")"] right = foldl1 (++) [ catchMacro ms e1, " (",catchMacro ms e2,")"]
both = foldl1 (++) ["(",catchMacro ms e1,") (",catchMacro ms e2,")"] both = foldl1 (++) ["(",catchMacro ms e1,") (",catchMacro ms e2,")"]
...@@ -315,13 +321,16 @@ exprToStr ms (LamMacro m ) = m ...@@ -315,13 +321,16 @@ exprToStr ms (LamMacro m ) = m
parseLamMacro :: String -> Maybe LamMacroExpr parseLamMacro :: String -> Maybe LamMacroExpr
parseLamMacro str | parsed == [] = Nothing parseLamMacro str | parsed == [] = Nothing
| foldl1 (&&) $ | foldl1 (&&) $ -- | if anything is left unparsed then the
map ( (""/=) . snd ) parsed = Nothing map ( (""/=) . snd ) parsed = Nothing -- | parsing has failed
| otherwise = Just $ fstHead parsed | otherwise = Just $ fstHead parsed
where where
parsed = parse (macroExpr []) str parsed = parse (macroExpr []) str
----------------------------Primary Functions-----------------------------------
macroExpr :: [ (String,LamExpr) ] -> Parser LamMacroExpr macroExpr :: [ (String,LamExpr) ] -> Parser LamMacroExpr
macroExpr ms = do string "def" macroExpr ms = do string "def"
name <- unique (map fst ms) (token macroName) name <- unique (map fst ms) (token macroName)
...@@ -335,31 +344,11 @@ macroExpr ms = do string "def" ...@@ -335,31 +344,11 @@ macroExpr ms = do string "def"
return $ LamDef ms e return $ LamDef ms e
{--| parses an element only if it is unique to a |--
--| given list |--}
unique :: Eq a => [a] -> Parser a -> Parser a
unique xs p = do x <- p
if x `elem` xs then empty else return x
{--| parses an expr if it is closed |--} {--| parses an expr if it is closed |--}
closedParse :: Parser LamExpr -> Parser LamExpr closedParse :: Parser LamExpr -> Parser LamExpr
closedParse p = do e <- p closedParse p = do e <- p
if closed e e then return e else empty if closed e e then return e else empty
{--| finds if an expression is closed |--}
closed :: LamExpr -> LamExpr -> Bool
closed expr (LamVar x) = not $ freeVar x expr
closed expr (LamAbs _ e ) = closed expr e
closed expr (LamApp e1 e2) = closed expr e1 && closed expr e2
{--| finds if a given variable is free in an expr |--}
freeVar :: Int -> LamExpr -> Bool
freeVar x (LamVar y) = x == y
freeVar x (LamAbs y e) | x == y = False
| otherwise = freeVar x e
freeVar x (LamApp e1 e2) = freeVar x e1 || freeVar x e2
expr :: Parser LamExpr expr :: Parser LamExpr
expr = do terms <- some $ token term expr = do terms <- some $ token term
...@@ -398,7 +387,31 @@ fstHead :: [(a,b)] -> a ...@@ -398,7 +387,31 @@ fstHead :: [(a,b)] -> a
fstHead = fst . head fstHead = fst . head
-- Challenge 5 ----------------------------Utility Functions-----------------------------------
{--| parses an element only if it is unique to a |--
--| given list |--}
unique :: Eq a => [a] -> Parser a -> Parser a
unique xs p = do x <- p
if x `elem` xs then empty else return x
{--| finds if an expression is closed |--}
closed :: LamExpr -> LamExpr -> Bool
closed expr (LamVar x) = not $ freeVar x expr
closed expr (LamAbs _ e ) = closed expr e
closed expr (LamApp e1 e2) = closed expr e1 && closed expr e2
{--| finds if a given variable is free in an expr |--}
freeVar :: Int -> LamExpr -> Bool
freeVar x (LamVar y) = x == y
freeVar x (LamAbs y e) | x == y = False
| otherwise = freeVar x e
freeVar x (LamApp e1 e2) = freeVar x e1 || freeVar x e2
------------------------------------------Challenge 5-------------------------------------------------
{--| Repeated for Clarity: |-- {--| Repeated for Clarity: |--
...@@ -411,24 +424,24 @@ fstHead = fst . head ...@@ -411,24 +424,24 @@ fstHead = fst . head
cpsTransform :: LamMacroExpr -> LamMacroExpr cpsTransform :: LamMacroExpr -> LamMacroExpr
cpsTransform (LamDef ms e) = LamDef ms' e' cpsTransform (LamDef ms e) = LamDef ms' e'
where where
nextFreeInExpr = if highestVar e == -1 then nextFreeInExpr = if highestVar e == -1 then -- | the next free variable name in the expression
1 1
else else
(+1) $ highestVar e (+1) $ highestVar e
nextFreeInMacro = if ms == [] then nextFreeInMacro = if ms == [] then -- | the next free variable name in the bindings
1 1
else else
(+1) $ foldl1 max $ map (highestVar . snd) ms (+1) $ foldl1 max $ map (highestVar . snd) ms
(ms',k) = cpsMacro [] ms $ max nextFreeInMacro nextFreeInExpr (ms',k) = cpsMacro [] ms $ max nextFreeInMacro nextFreeInExpr -- | next free variable name is passed to converter
(e',_) = cpsExpr e k (e',_) = cpsExpr e k -- | for use in creating new variables
----------------------------Primary Functions-----------------------------------
{--| finds the variable name with the highest value |-- {--| finds the variable name with the highest value |--
--| in an expression |-- --| in an expression |--}
--| params: |--
--| -expression to search |--
--| -highest variable name |--}
highestVar :: LamExpr -> Int highestVar :: LamExpr -> Int
highestVar (LamVar x) = x highestVar (LamVar x) = x
highestVar (LamMacro _) = -1 highestVar (LamMacro _) = -1
...@@ -472,12 +485,7 @@ cpsExpr (LamApp e1 e2) k = (LamAbs k $ LamApp e1' $ ...@@ -472,12 +485,7 @@ cpsExpr (LamApp e1 e2) k = (LamAbs k $ LamApp e1' $
cpsExpr (LamMacro name) k = (LamMacro name,k) cpsExpr (LamMacro name) k = (LamMacro name,k)
-- Examples in the instructions
exId = (LamAbs 1 (LamVar 1)) exId = (LamAbs 1 (LamVar 1))
ex5'1 = LamDef [] (LamApp (LamVar 1) (LamVar 2))
ex5'2 = (LamDef [ ("F", exId) ] (LamVar 2) )
ex5'3 = (LamDef [ ("F", exId) ] (LamMacro "F") )
ex5'4 = (LamDef [ ("F", exId) ] (LamApp (LamMacro "F") (LamMacro "F")))
-- Challenge 6 -- Challenge 6
...@@ -492,6 +500,43 @@ ex5'4 = (LamDef [ ("F", exId) ] (LamApp (LamMacro "F") (LamMacro "F"))) ...@@ -492,6 +500,43 @@ ex5'4 = (LamDef [ ("F", exId) ] (LamApp (LamMacro "F") (LamMacro "F")))
--| freeVar x (LamApp e1 e2) = freeVar x e1 || freeVar x e2 |--} --| freeVar x (LamApp e1 e2) = freeVar x e1 || freeVar x e2 |--}
compareInnerOuter :: LamMacroExpr -> Int -> (Maybe Int,Maybe Int,Maybe Int,Maybe Int)
compareInnerOuter e b = (innerSteps,outerSteps,innerCps,outerCps)
where
innerSteps = let reduces = trace innerRedn1 b e
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
outerSteps = let reduces = trace outerRedn1 b e
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
innerCps = let LamDef ms' e' = cpsTransform e
reduces = trace innerRedn1 b $ LamDef ms' $ LamApp e' exId
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
outerCps = let LamDef ms' e' = cpsTransform e
reduces = trace outerRedn1 b $ LamDef ms' $ LamApp e' exId
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
innerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
innerRedn1 (LamDef ms e) | redex e = Just $ LamDef ms e'
| otherwise = Nothing
where e' = eval1cbv ms e
outerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
outerRedn1 (LamDef ms e) | redex e = Just $ LamDef ms e'
| otherwise = Nothing
where e' = eval1cbn ms e
----------------------------Primary Functions-----------------------------------
{--| substitutes an expression into another expr |-- {--| substitutes an expression into another expr |--
--| params: |-- --| params: |--
--| -expr to sub in to |-- --| -expr to sub in to |--
...@@ -509,11 +554,11 @@ subst (LamAbs x e) y e' | x /= y && not (freeVar x e') = LamAbs x $ subst e y ...@@ -509,11 +554,11 @@ subst (LamAbs x e) y e' | x /= y && not (freeVar x e') = LamAbs x $ subst e y
subst (LamApp e1 e2) y e = LamApp (subst e1 y e) (subst e2 y e) subst (LamApp e1 e2) y e = LamApp (subst e1 y e) (subst e2 y e)
rename :: Int -> LamExpr -> Int rename :: Int -> LamExpr -> Int
rename x e = highestVar e + 1 rename x e = highestVar e + 1
{--| returns true if an expression contains a redex |--}
redex :: LamExpr -> Bool redex :: LamExpr -> Bool
redex (LamAbs _ _) = False redex (LamAbs _ _) = False
redex (LamVar _) = False redex (LamVar _) = False
...@@ -522,11 +567,6 @@ redex (LamApp (LamAbs _ _) _) = True ...@@ -522,11 +567,6 @@ redex (LamApp (LamAbs _ _) _) = True
redex (LamApp e1 e2) = redex e1 || redex e2 redex (LamApp e1 e2) = redex e1 || redex e2
innerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
innerRedn1 (LamDef ms e) | redex e = Just $ LamDef ms e'
| otherwise = Nothing
where e' = eval1cbv ms e
eval1cbv :: [ (String,LamExpr) ] -> LamExpr -> LamExpr eval1cbv :: [ (String,LamExpr) ] -> LamExpr -> LamExpr
eval1cbv ms (LamAbs x e) = LamAbs x e eval1cbv ms (LamAbs x e) = LamAbs x e
eval1cbv ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms eval1cbv ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms
...@@ -535,11 +575,6 @@ eval1cbv ms (LamApp e1@(LamAbs x e) e2) = LamApp e1 $ eval1cbv ms e2 ...@@ -535,11 +575,6 @@ eval1cbv ms (LamApp e1@(LamAbs x e) e2) = LamApp e1 $ eval1cbv ms e2
eval1cbv ms (LamApp e1 e2) = LamApp (eval1cbv ms e1) e2 eval1cbv ms (LamApp e1 e2) = LamApp (eval1cbv ms e1) e2
outerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
outerRedn1 (LamDef ms e) | redex e = Just $ LamDef ms e'
| otherwise = Nothing
where e' = eval1cbn ms e
eval1cbn :: [ (String,LamExpr) ] -> LamExpr -> LamExpr eval1cbn :: [ (String,LamExpr) ] -> LamExpr -> LamExpr
eval1cbn ms (LamAbs x e) = LamAbs x e eval1cbn ms (LamAbs x e) = LamAbs x e
eval1cbn ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms eval1cbn ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms
...@@ -547,13 +582,6 @@ eval1cbn ms (LamApp (LamAbs x e1) e2) = subst e1 x e2 ...@@ -547,13 +582,6 @@ eval1cbn ms (LamApp (LamAbs x e1) e2) = subst e1 x e2
eval1cbn ms (LamApp e1 e2) = LamApp (eval1cbn ms e1) e2 eval1cbn ms (LamApp e1 e2) = LamApp (eval1cbn ms e1) e2
reductions :: (LamMacroExpr -> Maybe LamMacroExpr) -> LamMacroExpr -> [Maybe LamMacroExpr]
reductions ssev e = drop 1 evals
where
evals :: [Maybe LamMacroExpr]
evals = iterate (>>=ssev) $ Just e
{--| returns the trace of reductions for an {--| returns the trace of reductions for an
--| expression |-- --| expression |--
--| params: |-- --| params: |--
...@@ -561,53 +589,10 @@ reductions ssev e = drop 1 evals ...@@ -561,53 +589,10 @@ reductions ssev e = drop 1 evals
--| -bound for reductions |-- --| -bound for reductions |--
--| -expr to be reduced |--} --| -expr to be reduced |--}
trace :: (LamMacroExpr -> Maybe LamMacroExpr) -> Int -> LamMacroExpr -> [Maybe LamMacroExpr] trace :: (LamMacroExpr -> Maybe LamMacroExpr) -> Int -> LamMacroExpr -> [Maybe LamMacroExpr]
--trace ssev e = (map fst) $ (takeWhile (uncurry (/=)) $ reductions ssev e) ++ [( head . dropWhile (uncurry (/=)) ssev e)]
trace ssev b e = take b $ reductions ssev e trace ssev b e = take b $ reductions ssev e
reductions :: (LamMacroExpr -> Maybe LamMacroExpr) -> LamMacroExpr -> [Maybe LamMacroExpr]
compareInnerOuter :: LamMacroExpr -> Int -> (Maybe Int,Maybe Int,Maybe Int,Maybe Int) reductions ssev e = drop 1 evals
compareInnerOuter e b = (innerSteps,outerSteps,innerCps,outerCps)
where where
innerSteps = let reduces = trace innerRedn1 b e evals :: [Maybe LamMacroExpr]
tillNoRedex = takeWhile (Nothing/=) reduces evals = iterate (>>=ssev) $ Just e
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing \ No newline at end of file
outerSteps = let reduces = trace outerRedn1 b e
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
innerCps = let LamDef ms' e' = cpsTransform e
reduces = trace innerRedn1 b $ LamDef ms' $ LamApp e' exId
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
outerCps = let LamDef ms' e' = cpsTransform e
reduces = trace outerRedn1 b $ LamDef ms' $ LamApp e' exId
tillNoRedex = takeWhile (Nothing/=) reduces
in if Nothing `elem` reduces then Just $ length tillNoRedex else Nothing
-- Examples in the instructions
-- (\x1 -> x1 x2)
ex6'1 = LamDef [] (LamAbs 1 (LamApp (LamVar 1) (LamVar 2)))
-- def F = \x1 -> x1 in F
ex6'2 = LamDef [ ("F",exId) ] (LamMacro "F")
-- (\x1 -> x1) (\x2 -> x2)
ex6'3 = LamDef [] ( LamApp exId (LamAbs 2 (LamVar 2)))
-- (\x1 -> x1 x1)(\x1 -> x1 x1)
wExp = (LamAbs 1 (LamApp (LamVar 1) (LamVar 1)))
ex6'4 = LamDef [] (LamApp wExp wExp)
-- def ID = \x1 -> x1 in def FST = (\x1 -> λx2 -> x1) in FST x3 (ID x4)
ex6'5 = LamDef [ ("ID",exId) , ("FST",LamAbs 1 (LamAbs 2 (LamVar 1))) ] ( LamApp (LamApp (LamMacro "FST") (LamVar 3)) (LamApp (LamMacro "ID") (LamVar 4)))
-- def FST = (\x1 -> λx2 -> x1) in FST x3 ((\x1 ->x1) x4))
ex6'6 = LamDef [ ("FST", LamAbs 1 (LamAbs 2 (LamVar 1)) ) ] ( LamApp (LamApp (LamMacro "FST") (LamVar 3)) (LamApp (exId) (LamVar 4)))
-- def ID = \x1 -> x1 in def SND = (\x1 -> λx2 -> x2) in SND ((\x1 -> x1 x1 ) (\x1 -> x1 x1)) ID
ex6'7 = LamDef [ ("ID",exId) , ("SND",LamAbs 1 (LamAbs 2 (LamVar 2))) ] (LamApp (LamApp (LamMacro "SND") (LamApp wExp wExp) ) (LamMacro "ID") )
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment