finishing challenge 6

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
@@ -300,6 +320,8 @@ exprToStr ms (LamMacro m    ) = m
 
 parseLamMacro :: String -> Maybe LamMacroExpr
 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