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

finished 6 not working

parent 16647a29
No related branches found
No related tags found
No related merge requests found
Show whitespace changes
Inline Side-by-side
Showing
with 90 additions and 108 deletions
cw/src/Challenges.hs
+ 90
− 108
View file @ cb345a87
......@@ -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 |--
......@@ -492,16 +444,14 @@ cpsTransform (LamDef ms e) = LamDef ms' e'
--| 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' ( (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
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment