From cb345a873f52b69f0d93b5375b329eecaf247c85 Mon Sep 17 00:00:00 2001 From: ik1g19 <ik1g19@soton.ac.uk> Date: Wed, 13 Jan 2021 23:19:16 +0000 Subject: [PATCH] finished 6 not working --- cw/src/Challenges.hs | 198 ++++++++++++++++++++----------------------- 1 file changed, 90 insertions(+), 108 deletions(-) diff --git a/cw/src/Challenges.hs b/cw/src/Challenges.hs index 7f9442d..e9ac1a4 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,ex6'1,ex6'2,ex6'3,ex6'4,ex6'5,ex6'6,ex6'7) where + 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 -- 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 @@ -21,6 +21,7 @@ import System.IO import System.Random import Control.Applicative +import Data.Maybe instance NFData Orientation instance NFData LamMacroExpr @@ -278,12 +279,6 @@ catchMacro ms e | macros == [] = exprToStr ms e --| -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 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 @@ -350,53 +345,27 @@ unique xs p = do x <- p {--| parses an expr if it is closed |--} closedParse :: Parser LamExpr -> Parser LamExpr closedParse p = do e <- p - if free e then empty else return e + if closed e e then return e else empty -{--| finds if an expression contains free variables |--} -free :: LamExpr -> Bool -free (LamVar _) = True -free (LamAbs x e ) = freeVar x e -free (LamApp e1 e2) = free e1 && free e2 +{--| 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) = not $ x == y +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 LamExprs --- expr = do terms <- manyF (token term) --- return $ foldl1 LamApp terms - expr :: Parser LamExpr 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 symbol "(" e <- expr @@ -439,49 +408,32 @@ fstHead = fst . head --| 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 ms e) = LamDef ms' e' where - (ms',k) = cpsMacro [] ms 1 + nextFreeInExpr = if highestVar e == -1 then + 1 + else + (+1) $ highestVar e + nextFreeInMacro = if ms == [] then + 1 + else + (+1) $ foldl1 max $ map (highestVar . snd) ms + + (ms',k) = cpsMacro [] ms $ max nextFreeInMacro nextFreeInExpr (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 +{--| finds the variable name with the highest value |-- + --| in an expression |-- + --| params: |-- + --| -expression to search |-- + --| -highest variable name |--} +highestVar :: LamExpr -> Int +highestVar (LamVar x) = x +highestVar (LamMacro _) = -1 +highestVar (LamAbs x e) = max x $ highestVar e +highestVar (LamApp e1 e2) = max (highestVar e1) (highestVar e2) {--| converts macro expr to cps form |-- @@ -491,17 +443,15 @@ cpsTransform (LamDef ms e) = LamDef ms' e' --| -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 +cpsMacro es' [] k = (es',k) +cpsMacro es' ( (mName,mExpr):es ) k = cpsMacro (es'++[(mName,e')]) es k' + where (e',k') = cpsExpr mExpr k {--| converts a lambda expression to cps form |-- --| params: |-- --| -expr to convert |-- - --| -available variable name |-- + --| -next available variable name |-- --| returns pair of converted expr and next |-- --| available variable name |--} cpsExpr :: LamExpr -> Int -> (LamExpr,Int) @@ -512,10 +462,14 @@ cpsExpr (LamAbs x e) k = (LamAbs k $ LamApp (LamVar k) $ LamAbs x e',k') 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) + LamAbs e $ foldl1 LamApp $ [LamVar f,LamVar e,LamVar k],k'') where - (e1',f) = cpsExpr e1 (k+1) - (e2',e) = cpsExpr e2 (f+1) + f = k+1 + e = k+2 + (e1',k') = cpsExpr e1 (e+1) + (e2',k'') = cpsExpr e2 k' + +cpsExpr (LamMacro name) k = (LamMacro name,k) -- Examples in the instructions @@ -557,52 +511,80 @@ 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 +rename x e = highestVar e + 1 + + +redex :: LamExpr -> Bool +redex (LamAbs _ _) = False +redex (LamVar _) = False +redex (LamMacro _) = True +redex (LamApp (LamAbs _ _) _) = True +redex (LamApp e1 e2) = redex e1 || redex e2 innerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr -innerRedn1 (LamDef ms e) = Just $ LamDef ms $ eval1cbv ms e +innerRedn1 (LamDef ms e) | redex e = Just $ LamDef ms e' + | otherwise = Nothing + where e' = eval1cbv ms e eval1cbv :: [ (String,LamExpr) ] -> LamExpr -> LamExpr eval1cbv ms (LamAbs x e) = LamAbs x e +eval1cbv ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms 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@(LamAbs x e) e2) = LamApp e1 $ 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 (LamDef ms e) = Just $ LamDef ms $ eval1cbn ms e - +outerRedn1 (LamDef ms e) | redex e = Just $ LamDef ms e' + | otherwise = Nothing + where e' = eval1cbn ms e eval1cbn :: [ (String,LamExpr) ] -> LamExpr -> LamExpr eval1cbn ms (LamAbs x e) = LamAbs x e +eval1cbn ms (LamMacro name) = (snd . head) $ filter ((name==) . fst) ms 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] +reductions :: (LamMacroExpr -> Maybe LamMacroExpr) -> LamMacroExpr -> [Maybe LamMacroExpr] +reductions ssev e = drop 1 evals where - evals = iterate ssev e + evals :: [Maybe LamMacroExpr] + evals = iterate (>>=ssev) $ Just e + -trace :: (LamMacroExpr -> Maybe LamMacroExpr) -> LamMacroExpr -> [Maybe LamMacroExpr] -trace ssev e = (map fst) $ (takeWhile (uncurry (/=)) $ reductions ssev e) ++ [( head . dropWhile (uncurry (/=)) ssev e)] +{--| returns the trace of reductions for an + --| expression |-- + --| params: |-- + --| -single step reduction strat |-- + --| -bound for reductions |-- + --| -expr to be reduced |--} +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 compareInnerOuter :: LamMacroExpr -> Int -> (Maybe Int,Maybe Int,Maybe Int,Maybe Int) -compareInnerOuter e b = (Nothing,Nothing,Nothing,Nothing) +compareInnerOuter e b = (innerSteps,outerSteps,innerCps,outerCps) 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 + 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 -- Examples in the instructions -- GitLab