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