From 16647a2995e57f64306df1f0d6de00fdf598fb1c Mon Sep 17 00:00:00 2001
From: ik1g19 <ik1g19@soton.ac.uk>
Date: Wed, 13 Jan 2021 02:31:20 +0000
Subject: [PATCH] finishing challenge 6
---
cw/src/Challenges.hs | 230 ++++++++++++++++++++++++++++++++++++++++---
1 file changed, 215 insertions(+), 15 deletions(-)
diff --git a/cw/src/Challenges.hs b/cw/src/Challenges.hs
index ec8fd7a..7f9442d 100644
--- a/cw/src/Challenges.hs
+++ b/cw/src/Challenges.hs
@@ -7,7 +7,7 @@
-- DO NOT MODIFY THE FOLLOWING LINES OF CODE
module Challenges (WordSearchGrid,Placement,Posn,Orientation(..),solveWordSearch, createWordSearch,
LamMacroExpr(..),LamExpr(..),prettyPrint, parseLamMacro,
- cpsTransform,innerRedn1,outerRedn1,compareInnerOuter) where
+ cpsTransform,innerRedn1,outerRedn1,compareInnerOuter,ex6'1,ex6'2,ex6'3,ex6'4,ex6'5,ex6'6,ex6'7) where
-- 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
@@ -272,12 +272,32 @@ catchMacro ms e | macros == [] = exprToStr ms e
macros = filter ( (e==) . snd ) ms
+{--| converts expr to str |--
+ --| params: |--
+ --| -list of macros and bindings |--
+ --| -expr to convert |--
+ --| returns expr in string form |--}
exprToStr :: [(String,LamExpr)] -> LamExpr -> String
-exprToStr ms (LamApp e1@(LamVar _) e2) = catchMacro ms e1 ++ " " ++ catchMacro ms e2
+-- exprToStr ms (LamApp e1@(LamVar _) e2) = catchMacro ms e1 ++ " " ++ catchMacro ms e2
-exprToStr ms (LamApp e1 e2) | catchMacro ms e1 == exprToStr ms e1 = foldl1 (++) ["(",exprToStr ms e1,") ",catchMacro ms e2]
- | otherwise = catchMacro ms e1 ++ " " ++ catchMacro ms e2
+-- exprToStr ms (LamApp e1 e2) | catchMacro ms e1 == exprToStr ms e1 = foldl1 (++) ["(",exprToStr ms e1,") ",catchMacro ms e2]
+-- | otherwise = catchMacro ms e1 ++ " " ++ catchMacro ms e2
+
+exprToStr ms e@(LamApp e1 e2) | e == eNone = none
+ | e == eLeft = left
+ | e == eRight = right
+ | e == eBoth = both
+ where
+ none = foldl1 (++) [ catchMacro ms e1, " ", catchMacro ms e2 ]
+ left = foldl1 (++) ["(",catchMacro ms e1,") ", catchMacro ms e2 ]
+ right = foldl1 (++) [ catchMacro ms e1, " (",catchMacro ms e2,")"]
+ both = foldl1 (++) ["(",catchMacro ms e1,") (",catchMacro ms e2,")"]
+
+ Just (LamDef _ eNone) = parseLamMacro none
+ Just (LamDef _ eLeft) = parseLamMacro left
+ Just (LamDef _ eRight) = parseLamMacro right
+ Just (LamDef _ eBoth) = parseLamMacro both
exprToStr ms (LamAbs x e ) = "\\x" ++ show x ++ " -> " ++ catchMacro ms e
exprToStr ms (LamVar x ) = "x" ++ show x
@@ -299,8 +319,10 @@ exprToStr ms (LamMacro m ) = m
parseLamMacro :: String -> Maybe LamMacroExpr
-parseLamMacro str | parsed == [] = Nothing
- | otherwise = Just $ fstHead parsed
+parseLamMacro str | parsed == [] = Nothing
+ | foldl1 (&&) $
+ map ( (""/=) . snd ) parsed = Nothing
+ | otherwise = Just $ fstHead parsed
where
parsed = parse (macroExpr []) str
@@ -344,18 +366,44 @@ freeVar x (LamAbs y e) | x == y = False
freeVar x (LamApp e1 e2) = freeVar x e1 || freeVar x e2
+-- expr :: Parser LamExprs
+-- expr = do terms <- manyF (token term)
+-- return $ foldl1 LamApp terms
+
expr :: Parser LamExpr
-expr = do terms <- some (token term)
+expr = do terms <- some $ token term
return $ foldl1 LamApp terms
+-- manyF :: Parser a -> Parser [a]
+-- manyF p = many1F p
+
+
+-- manyF :: Parser a -> [a] -> Parser [a]
+-- manyF p pd = do endOfString
+-- return pd
+
+-- <|> do v <- p
+-- manyF p $ pd ++ [v]
+
+-- endExpr ::
+
+-- endOfString :: Parser ()
+-- endOfString = fails item
+
+-- fails :: Parser a -> Parser ()
+-- fails p = P (\inp -> case parse p inp of
+-- [] -> [((),inp)]
+-- _ -> [])
+
+
term :: Parser LamExpr
-term = do char '('
- e <- token expr
- char ')'
+term = do symbol "("
+ e <- expr
+ symbol ")"
return e
- <|> do char '\\'
+ <|> do symbol "\\"
x <- var
symbol "->"
e <- expr
@@ -383,8 +431,92 @@ fstHead = fst . head
-- Challenge 5
+
+{--| Repeated for Clarity: |--
+ --| |--
+ --| data LamMacroExpr = LamDef [ (String,LamExpr) ] LamExpr deriving (Eq,Show,Read) |--
+ --| data LamExpr = LamMacro String | LamApp LamExpr LamExpr | |--
+ --| LamAbs Int LamExpr | LamVar Int deriving (Eq,Show,Read) |--}
+
+
+-- cpsTransform :: LamMacroExpr -> LamMacroExpr
+-- cpsTransform (LamDef xs e) = LamDef (zip strs es') (fst $ cpsExpr e var)
+-- where
+-- strs = map fst xs
+-- es = map snd xs
+-- es' = fst $ mapFoldSnd cpsExpr 1 es
+-- var = snd $ mapFoldSnd cpsExpr 1 es
+
cpsTransform :: LamMacroExpr -> LamMacroExpr
-cpsTransform _ = LamDef [] (LamVar 0)
+cpsTransform (LamDef ms e) = LamDef ms' e'
+ where
+ (ms',k) = cpsMacro [] ms 1
+ (e',_) = cpsExpr e k
+
+
+{--| maps a functions across a list, |--
+ --| folds the second element of the returned tuple |--}
+
+-- mapFoldSnd :: (a -> b -> (a,b)) -> b -> [a] -> ([a],b)
+-- mapFoldSnd f z (x:[]) = (fst (f x z),snd (f x z))
+-- mapFoldSnd f z (x:xs) = (e : list,val)
+-- where
+-- (e,n) = f x z
+-- next = mapFoldSnd f n xs
+-- list = fst next
+-- val = snd next
+
+-- mapFoldSnd :: (a -> b -> (a,b)) -> b -> [a] -> ([a],b)
+-- mapFoldSnd g w ys = (mfs g w ys,mfsVal g w ys)
+-- where
+-- {--| returns the final value |--}
+-- mfsVal :: (a -> b -> (a,b)) -> b -> [a] -> b
+-- mfsVal f z (x:[]) = snd $ f x z
+-- mfsVal f z (x:xs) = mfsVal f n xs
+-- where
+-- (e,n) = f x z
+
+-- {--| returns the list |--}
+-- mfs :: (a -> b -> (a,b)) -> b -> [a] -> [a]
+-- mfs f z [] = []
+-- mfs f z (x:xs) = e : mfs f n xs
+-- where
+-- (e,n) = f x z
+
+
+{--| converts macro expr to cps form |--
+ --| params: |--
+ --| -converted macros |--
+ --| -macros to convert |--
+ --| -next available variable name |--
+ --| returns the converted macro def |--}
+cpsMacro :: [ (String,LamExpr) ] -> [ (String,LamExpr) ] -> Int -> ([ (String,LamExpr) ],Int)
+cpsMacro es' [] k = (es',k)
+cpsMacro es' (e:es) k = cpsMacro (es'++[(mName,e')]) es k'
+ where
+ (mName,mExpr) = e
+ (e',k') = cpsExpr mExpr k
+
+
+{--| converts a lambda expression to cps form |--
+ --| params: |--
+ --| -expr to convert |--
+ --| -available variable name |--
+ --| returns pair of converted expr and next |--
+ --| available variable name |--}
+cpsExpr :: LamExpr -> Int -> (LamExpr,Int)
+cpsExpr (LamVar x) k = (LamAbs k $ LamApp (LamVar k) (LamVar x),k+1)
+
+cpsExpr (LamAbs x e) k = (LamAbs k $ LamApp (LamVar k) $ LamAbs x e',k')
+ where (e',k') = cpsExpr e (k+1)
+
+cpsExpr (LamApp e1 e2) k = (LamAbs k $ LamApp e1' $
+ LamAbs f $ LamApp e2' $
+ LamAbs e $ foldl1 LamApp $ [LamVar f,LamVar e,LamVar k],e+1)
+ where
+ (e1',f) = cpsExpr e1 (k+1)
+ (e2',e) = cpsExpr e2 (f+1)
+
-- Examples in the instructions
exId = (LamAbs 1 (LamVar 1))
@@ -396,14 +528,82 @@ ex5'4 = (LamDef [ ("F", exId) ] (LamApp (LamMacro "F") (LamMacro "F")))
-- Challenge 6
+
+{--| Repeated for Reference: |--
+ --| |--
+ --| freeVar :: Int -> LamExpr -> Bool |--
+ --| freeVar x (LamVar y) = not $ 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 |--}
+
+
+{--| substitutes an expression into another expr |--
+ --| params: |--
+ --| -expr to sub in to |--
+ --| -variable being replaced |--
+ --| -expr to sub in |--
+ --| returns new expr |--}
+subst :: LamExpr -> Int -> LamExpr -> LamExpr
+subst (LamVar x) y e | x == y = e
+ | otherwise = LamVar x
+
+subst (LamAbs x e) y e' | x /= y && not (freeVar x e') = LamAbs x $ subst e y e'
+ | x /= y && freeVar x e' = let x' = rename x e in
+ subst (LamAbs x' $ subst e x $ LamVar x') y e'
+ | x == y = LamAbs x e
+
+subst (LamApp e1 e2) y e = LamApp (subst e1 y e) (subst e2 y e)
+
+
+rename :: Int -> LamExpr -> Int
+rename x e | freeVar (x+1) e = rename (x+1) e
+ | otherwise = x+1
+
+
innerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
-innerRedn1 _ = Nothing
+innerRedn1 (LamDef ms e) = Just $ LamDef ms $ eval1cbv ms e
+
+eval1cbv :: [ (String,LamExpr) ] -> LamExpr -> LamExpr
+eval1cbv ms (LamAbs x e) = LamAbs x e
+eval1cbv ms (LamApp (LamAbs x e1) e@(LamAbs y e2)) = subst e1 x e
+eval1cbv ms (LamApp e@(LamAbs x e1) e2) = LamApp e $ eval1cbv ms e2
+eval1cbv ms (LamApp e1 e2) = LamApp (eval1cbv ms e1) e2
+eval1cbv ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms
+
outerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
-outerRedn1 _ = Nothing
+outerRedn1 (LamDef ms e) = Just $ LamDef ms $ eval1cbn ms e
+
+
+eval1cbn :: [ (String,LamExpr) ] -> LamExpr -> LamExpr
+eval1cbn ms (LamAbs x e) = LamAbs x e
+eval1cbn ms (LamApp (LamAbs x e1) e2) = subst e1 x e2
+eval1cbn ms (LamApp e1 e2) = LamApp (eval1cbn ms e1) e2
+eval1cbn ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms
+
+
+reductions :: (LamMacroExpr -> Maybe LamMacroExpr) -> LamMacroExpr -> [ (Maybe LamMacroExpr,Maybe LamMacroExpr) ]
+reductions ssev e = [p | p <- zip evals $ tail evals]
+ where
+ evals = iterate ssev e
+
+trace :: (LamMacroExpr -> Maybe LamMacroExpr) -> LamMacroExpr -> [Maybe LamMacroExpr]
+trace ssev e = (map fst) $ (takeWhile (uncurry (/=)) $ reductions ssev e) ++ [( head . dropWhile (uncurry (/=)) ssev e)]
+
compareInnerOuter :: LamMacroExpr -> Int -> (Maybe Int,Maybe Int,Maybe Int,Maybe Int)
-compareInnerOuter _ _ = (Nothing,Nothing,Nothing,Nothing)
+compareInnerOuter e b = (Nothing,Nothing,Nothing,Nothing)
+ where
+ innerSteps = let l = length $ trace eval1cbv e in
+ if b < l then Nothing else Just l
+ outerSteps = let l = length $ trace eval1cbn e in
+ if b < l then Nothing else Just l
+ innerCps = let l = length $ trace eval1cbv $ LamApp (cpsTransform e) exId in
+ if b < l then Nothing else Just l
+ outerCps = let l = length $ trace eval1cbn $ LamApp (cpsTransform e) exId in
+ if b < l then Nothing else Just l
+
-- Examples in the instructions
--
GitLab