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