finished 6 not working

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