From 1166ca9a0fb0a9aae7a22ae56cd65a47e5dd17c7 Mon Sep 17 00:00:00 2001 From: ik1g19 <ik1g19@soton.ac.uk> Date: Fri, 8 Jan 2021 19:51:09 +0000 Subject: [PATCH] finished challenge 4 --- cw/src/Challenges.hs | 332 +++++++++++++++++-------------------------- 1 file changed, 134 insertions(+), 198 deletions(-) diff --git a/cw/src/Challenges.hs b/cw/src/Challenges.hs index 295d931..f5ff8e1 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) where + cpsTransform,innerRedn1,outerRedn1,compareInnerOuter,unique,macroName,closedParse,expr) 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 @@ -22,23 +22,26 @@ import System.Random import Control.Applicative +instance NFData Orientation +instance NFData LamMacroExpr +instance NFData LamExpr -- types for Part I type WordSearchGrid = [[ Char ]] type Placement = (Posn,Orientation) type Posn = (Int,Int) -data Orientation = Forward | Back | Up | Down | UpForward | UpBack | DownForward | DownBack deriving (Eq,Ord,Show,Read) +data Orientation = Forward | Back | Up | Down | UpForward | UpBack | DownForward | DownBack deriving (Eq,Ord,Show,Read,Generic) -- types for Parts II and III -data LamMacroExpr = LamDef [ (String,LamExpr) ] LamExpr deriving (Eq,Show,Read) +data LamMacroExpr = LamDef [ (String,LamExpr) ] LamExpr deriving (Eq,Show,Read,Generic) data LamExpr = LamMacro String | LamApp LamExpr LamExpr | - LamAbs Int LamExpr | LamVar Int deriving (Eq,Show,Read) + LamAbs Int LamExpr | LamVar Int deriving (Eq,Show,Read,Generic) -- END OF CODE YOU MUST NOT MODIFY -- ADD YOUR OWN CODE HERE --- Challenge 1 -- +------------------------------------------Challenge 1------------------------------------------------- -- | inline comments solveWordSearch :: [ String ] -> WordSearchGrid -> [ (String,Maybe Placement) ] @@ -49,8 +52,8 @@ findString :: WordSearchGrid -> String -> (String,Maybe Placement) findString css s = (s,findLocation css (0,0) s) ---recursively searches grid for first char of word ---returns Nothing or Placement +{--| recursively searches grid for first char of word |-- + --| returns Nothing or Placement |--} findLocation :: WordSearchGrid -> Posn -> String -> Maybe Placement findLocation css (x,y) s@(l:ls) | x > limit && y > limit = Nothing | x > limit = findLocation css (0,y+1) s @@ -61,7 +64,7 @@ findLocation css (x,y) s@(l:ls) | x > limit && y > limit = N limit = length css - 1 ---checks for hidden word in possible directions +{--| checks for hidden word in possible directions |--} findPlacement :: WordSearchGrid -> Posn -> String -> Maybe Placement findPlacement css (x,y) s | checkWordDir css (x,y) Forward s = Just ((x,y),Forward) | checkWordDir css (x,y) Back s = Just ((x,y),Back) @@ -81,10 +84,10 @@ checkWordDir css (x,y) dir (l:ls) | nextElem css (x,y) dir == Just l = checkWo | otherwise = False - --------------------pattern matching for traversing the grid-------------------- ---returns position of movement in a given direction + +{--| returns position of movement in a given direction |--} nextPos :: Orientation -> Posn -> Posn nextPos Forward (x,y) = (x+1,y) nextPos Back (x,y) = (x-1,y) @@ -97,80 +100,56 @@ nextPos DownBack (x,y) = (x-1,y+1) elemAt :: [[a]] -> Posn -> a -elemAt ass (x,y) = (ass !! y) !! x --ass means list of list of a's, - --not associated with any other meaning +elemAt ass (x,y) = (ass !! y) !! x -- | ass means list of list of a's, + -- | not associated with any other meaning ---returns specified adjacent element in grid, relative to given position +{--| returns specified adjacent element in grid, |-- + --| relative to given position |--} nextElem :: [[a]] -> Posn -> Orientation -> Maybe a -nextElem css (x,y) dir | x' < 0 || y' < 0 || - x' > length css - 1 || y' > length css - 1 = Nothing - | otherwise = Just (elemAt css (x',y')) +nextElem css (x,y) dir | x' < 0 || y' < 0 || + x' > length css - 1 || + y' > length css - 1 = Nothing + | otherwise = Just (elemAt css (x',y')) where (x',y') = nextPos dir (x,y) --- Two examples for you to try out, the first of which is in the instructions - -exGrid1'1 = ["HAGNIRTSH" , "SACAGETAK", "GCSTACKEL", - "MGHKMILKI", "EKNLETGCN", "TNIRTLETE", - "IRAAHCLSR", "MAMROSAGD", "GIZKDDNRG"] - -exWords1'1 = [ "HASKELL","STRING","STACK","MAIN","METHOD"] - -exGrid1'2 = ["ROBREUMBR","AURPEPSAN","UNLALMSEE", - "YGAUNPYYP","NLMNBGENA","NBLEALEOR", - "ALRYPBBLG","NREPBEBEP","YGAYAROMR"] - -exWords1'2 = [ "BANANA", "ORANGE", "MELON", "RASPBERRY", - "APPLE", "PLUM", "GRAPE" ] - - --- Challenge 2 -- +------------------------------------------Challenge 2------------------------------------------------- ---internal grid values are either a character or a placeholder for a random letter +{--| internal grid values are either a character + --| or a placeholder for a random letter |--} data GridVal = Letter Char | Rand deriving Eq type RandGrid = [[GridVal]] createWordSearch :: [ String ] -> Double -> IO WordSearchGrid -createWordSearch ss den = do gen <- newStdGen --initial generator +createWordSearch ss den = do gen <- newStdGen -- | initial generator return (createGrid dim gen ss) where charInInput = fromIntegral $ sum $ map length ss :: Double longestWordLen = fromIntegral $ foldl1 max $ map length ss :: Double - dim = floor $ head [x | x <- [0..], x^2 > (charInInput / den), x >= longestWordLen] --calculates needed dimension of grid according to the density + dim = floor $ head [x | x <- [0..], x^2 > (charInInput / den), x >= longestWordLen] -- | calculates needed dimension of grid according to the density createGrid :: Int -> StdGen -> [String] -> WordSearchGrid createGrid dim gen ss = randToWord (charsFromStrs ss) gen' finalGrid where - tempGrid = replicate dim (replicate dim Rand) --fills grid with random values - (finalGrid,gen') = addStrsToGrid tempGrid gen ss --final grid after all strings added + tempGrid = replicate dim (replicate dim Rand) -- | fills grid with random values + (finalGrid,gen') = addStrsToGrid tempGrid gen ss -- | final grid after all strings added - charsFromStrs = rmdups . concat --list of chars used in given strings + charsFromStrs = rmdups . concat -- | list of chars used in given strings ---removes duplicates from a list ---code from https://stackoverflow.com/a/16109302/10218833 -rmdups :: (Ord a) => [a] -> [a] -rmdups = map head . group . sort +----------------------------Primary Functions----------------------------------- --- --converts RandGrid to WordSearchGrid --- --replaces placeholder random values with actual random values --- randToWord :: RandGrid -> [Char] -> StdGen -> WordSearchGrid --- randToWord rg cs gen = --- where --- charStream :: [Char] --- charStream = map (cs!!) $ randomRs (0,length cs - 1) g - --- replaceRands = map (\Rand -> head charStream) randToWord :: [Char] -> StdGen -> RandGrid -> WordSearchGrid randToWord cs gen [] = [] randToWord cs gen (row:rs) = let (newRow,newGen) = rowConvert cs gen row in newRow : randToWord cs newGen rs + rowConvert :: [Char] -> StdGen -> [GridVal] -> ([Char],StdGen) rowConvert cs gen [] = ([],gen) rowConvert cs gen (Letter x:xs) = let (rows,gen') = rowConvert cs gen xs @@ -182,7 +161,7 @@ rowConvert cs gen (Rand:xs) = let (rows,gen') = rowConvert cs newGen xs randChar = cs !! index ---adds list of strings to given grid one by one +{--| adds list of strings to given grid one by one |--} addStrsToGrid :: RandGrid -> StdGen -> [String] -> (RandGrid,StdGen) addStrsToGrid rg gen (s:[]) = insertString rg s gen addStrsToGrid rg gen (s:ss) = addStrsToGrid newGrid newGen ss @@ -190,14 +169,22 @@ addStrsToGrid rg gen (s:ss) = addStrsToGrid newGrid newGen ss (newGrid,newGen) = insertString rg s gen ---takes a grid, string and a position ---returns a list of valid orientations for the string at that position +{--| takes a grid, string and a position |-- + --| returns a list of valid orientations for the |-- + --| string at that position |--} validDirs :: RandGrid -> String -> Posn -> [Orientation] -validDirs rg s (x,y) = map fst $ filter ( \(_,b) -> b == True ) (zip dirs (map ( checkDir rg s (x,y) ) dirs) ) +validDirs rg s (x,y) = map fst $ filter (\b -> snd b == True) (zipF ( checkDir rg s (x,y) ) dirs) where dirs = [Forward,Back,Up,Down,UpForward,UpBack,DownForward,DownBack] ---checks whether an orientation for a string at a given position in a grid is valid +{--| applies given func to list and zips result with |-- + --| original list |--} +zipF :: (a -> b) -> [a] -> [(a,b)] +zipF f xs = zip xs $ map f xs + + +{--| checks whether an orientation for a string at a + --| given position in a grid is valid |--} checkDir :: RandGrid -> String -> Posn -> Orientation -> Bool checkDir rg s (x,y) dir | let (x',y') = posns !! (length s - 1), x' < 0 || x' > length rg - 1 || @@ -209,12 +196,12 @@ checkDir rg s (x,y) dir | let (x',y') = posns !! (length s - 1), lettersGrid = take (length s) $ map (elemAt rg) posns ---adds an individual string to a given grid ---returns new grid and new generator +{--| adds an individual string to a given grid |-- + --| returns new grid and new generator |--} insertString :: RandGrid -> String -> StdGen -> (RandGrid,StdGen) insertString rg s gen | elemAt rg (x,y) /= Rand && - elemAt rg (x,y) /= Letter (head s) = insertString rg s newGen --guard:if position is invalid, generate new position - | length vDirs == 0 = insertString rg s newGen --guard:if no valid orientations exist, generate new position + elemAt rg (x,y) /= Letter (head s) = insertString rg s newGen -- | guard:if position is invalid, generate new position + | length vDirs == 0 = insertString rg s newGen -- | guard:if no valid orientations exist, generate new position | otherwise = (addToGrid randomDir s rg (x,y),newGen) where ( (x,y),newGen ) = generatePos gen (length rg) @@ -228,21 +215,6 @@ insertString rg s gen | elemAt rg (x,y) /= Rand && where charAdded :: RandGrid charAdded = insertAt2D (Letter c) (x',y') rg - --addToGrid dir = map (\(c,(m,n)) -> insertAt2D (Letter c) (m,n) rg) (zip s (take (length s) $ iterate (nextPos dir) (x,y))) - - ---inserts element at location in 2d array -insertAt2D :: a -> (Int,Int) -> [[a]] -> [[a]] -insertAt2D newElement (x,y) grid | y == 0 = insertAt newElement x (grid !! y) : drop 1 belowRows - | y == length grid - 1 = aboveRows ++ [insertAt newElement x (grid !! y)] - | otherwise = aboveRows ++ [insertAt newElement x (grid !! y)] ++ drop 1 belowRows - where - (aboveRows,belowRows) = splitAt y grid - ---using code from https://stackoverflow.com/a/43291593/10218833 -insertAt :: a -> Int -> [a] -> [a] -insertAt newElement 0 as = newElement : drop 1 as -insertAt newElement i (a:as) = a : insertAt newElement (i - 1) as generatePos :: StdGen -> Int -> (Posn,StdGen) @@ -251,84 +223,81 @@ generatePos gen dim = let (x,gen') = randomR (0,dim - 1) gen :: (Int,StdGen) in ((x,y),gen'') +----------------------------Utility Functions----------------------------------- ---- Convenience functions supplied for testing purposes -createAndSolve :: [ String ] -> Double -> IO [ (String, Maybe Placement) ] -createAndSolve words maxDensity = do g <- createWordSearch words maxDensity - let soln = solveWordSearch words g - printGrid g - return soln -printGrid :: WordSearchGrid -> IO () -printGrid [] = return () -printGrid (w:ws) = do putStrLn w - printGrid ws +{--| removes duplicates from a list |-- + --| code from https://stackoverflow.com/a/16109302/10218833 |--} +rmdups :: (Ord a) => [a] -> [a] +rmdups = map head . group . sort --- Challenge 3 -- +{--| inserts element at location in 2d array |--} +insertAt2D :: a -> (Int,Int) -> [[a]] -> [[a]] +insertAt2D newElement (x,y) grid | y == 0 = insertAt newElement x (grid !! y) : drop 1 belowRows + | y == length grid - 1 = aboveRows ++ [insertAt newElement x (grid !! y)] + | otherwise = aboveRows ++ [insertAt newElement x (grid !! y)] ++ drop 1 belowRows + where + (aboveRows,belowRows) = splitAt y grid --- 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) +{--| inserts element at given index of list |-- + --| using code from https://stackoverflow.com/a/43291593/10218833 |--} +insertAt :: a -> Int -> [a] -> [a] +insertAt newElement 0 as = newElement : drop 1 as +insertAt newElement i (a:as) = a : insertAt newElement (i - 1) as -prettyPrint :: LamMacroExpr -> String -prettyPrint (LamDef ms e) = exprBrackets e +------------------------------------------Challenge 3------------------------------------------------- ---applies brackets to expr if needed -exprBrackets :: LamExpr -> String -exprBrackets e | foldl1 (||) $ map (e==) parsed = str --omit brackets - | otherwise = "(" ++ str ++ ")" --include brackets - where - str = exprToStr e - parsed = map fst (parse expr str) --possible parsings of str +{--| 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) |--} + +prettyPrint :: LamMacroExpr -> String +prettyPrint (LamDef ms e) = macroDef ms ++ exprToStr ms e ---converts expr to string -exprToStr :: LamExpr -> String -exprToStr (LamApp e1 e2) = exprBrackets e1 ++ " " ++ exprBrackets e2 -exprToStr (LamAbs x e) = "\\x" ++ show x ++ " -> " ++ exprBrackets e -exprToStr (LamVar x) = "x" ++ show x -exprToStr (LamMacro m) = m +macroDef :: [(String,LamExpr)] -> String +macroDef [] = "" +macroDef ( (name,expr):ms ) = foldl1 (++) ["def ",name," = ",exprToStr [] expr," in ",macroDef ms] --- examples in the instructions -ex3'1 = LamDef [] (LamApp (LamAbs 1 (LamVar 1)) (LamAbs 1 (LamVar 1))) --"(\x1 -> x1) \x1 -> x1" -ex3'2 = LamDef [] (LamAbs 1 (LamApp (LamVar 1) (LamAbs 1 (LamVar 1)))) --"\x1 -> x1 \x1 -> x1" -ex3'3 = LamDef [ ("F", LamAbs 1 (LamVar 1) ) ] (LamAbs 2 (LamApp (LamVar 2) (LamMacro "F"))) --"def F = \x1-> x1 in \x2 -> x2 F" -ex3'4 = LamDef [ ("F", LamAbs 1 (LamVar 1) ) ] (LamAbs 2 (LamApp (LamAbs 1 (LamVar 1)) (LamVar 2))) --"def F = \x1-> x1 in \x2-> F x2" +{--| replaces a macro with its definition |--} +catchMacro :: [(String,LamExpr)] -> LamExpr -> String +catchMacro ms e | macros == [] = exprToStr ms e + | otherwise = fst $ head macros + where + macros = filter ( (e==) . snd ) ms --- Challenge 4 -- +exprToStr :: [(String,LamExpr)] -> LamExpr -> String +exprToStr ms (LamApp e1@(LamVar _) e2) = catchMacro ms e1 ++ " " ++ catchMacro ms e2 --- 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) +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 (LamAbs x e ) = "\\x" ++ show x ++ " -> " ++ catchMacro ms e +exprToStr ms (LamVar x ) = "x" ++ show x +exprToStr ms (LamMacro m ) = m ---MacroExpr ::= "def" MacroName "=" Expr "in" MacroExpr | Expr ---Expr ::= Var | MacroName | Expr Expr | “\” Var “->” Expr | “(“ Expr “)” ---MacroName ::= UChar | UChar MacroName ---UChar ::= "A" | "B" | ... | "Z" ---Var ::= “x” Digits ---Digits ::= Digit | Digit Digits ---Digit ::= “0” | “1” | “2” | “3” | “4” | “5” | “6” | “7” | “8” | “9” +------------------------------------------Challenge 4------------------------------------------------- ---MacroExpr ::= "def" MacroName "=" Expr "in" MacroExpr | Expr ---Expr ::= Var | MacroName | Applicative | Function | Expression ---MacroName ::= UChar | UChar MacroName ---UChar ::= "A" | "B" | ... | "Z" ---Var ::= “x” Digits ---Digits ::= Digit | Digit Digits ---Digit ::= “0” | “1” | “2” | “3” | “4” | “5” | “6” | “7” | “8” | “9” ---Applicative ::= Expr Expr ---Function ::= “\” Var “->” Expr ---Expression ::= “(“ Expr “)” +{--| Corresponding Grammar: |-- + --| |-- + --| MacroExpr ::= "def" MacroName "=" Expr "in" MacroExpr | Expr |-- + --| Expr ::= Var | MacroName | Expr Expr | “\” Var “->” Expr | “(“ Expr “)” |-- + --| MacroName ::= UChar | UChar MacroName |-- + --| UChar ::= "A" | "B" | ... | "Z" |-- + --| Var ::= “x” Digits |-- + --| Digits ::= Digit | Digit Digits |-- + --| Digit ::= “0” | “1” | “2” | “3” | “4” | “5” | “6” | “7” | “8” | “9” |--} parseLamMacro :: String -> Maybe LamMacroExpr @@ -336,14 +305,13 @@ parseLamMacro str | parsed == [] = Nothing | otherwise = Just $ fstHead parsed where parsed = parse (macroExpr []) str - fstHead = fst . head macroExpr :: [ (String,LamExpr) ] -> Parser LamMacroExpr macroExpr ms = do string "def" - name <- token macroName + name <- unique (map fst ms) (token macroName) symbol "=" - e <- token expr + e <- closedParse expr token $ string "in" macros <- macroExpr $ ms ++ [(name,e)] return $ macros @@ -352,6 +320,34 @@ macroExpr ms = do string "def" return $ LamDef ms e +{--| parses an element only if it is unique to a |-- + --| given list |--} +unique :: Eq a => [a] -> Parser a -> Parser a +unique xs p = do x <- p + if x `elem` xs then empty else return x + + +{--| 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 + +{--| 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 a given variable is free in an expr |-- + --| |--} +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 + + expr :: Parser LamExpr expr = do terms <- some (token term) return $ foldl1 LamApp terms @@ -369,30 +365,9 @@ term = do char '(' e <- expr return $ LamAbs x e - <|> do {x <- var; return $ LamVar x} - - <|> do {name <- macroName;return $ LamMacro name} - --- expr :: Parser LamExpr --- expr = do e1 <- expr --- space --- e2 <- expr --- return $ LamApp e1 e2 + <|> do {x <- var; return $ LamVar x} --- <|> do {x <- var; return $ LamVar x} - --- <|> do {name <- macroName;return $ LamMacro name} - --- <|> do char '\\' --- x <- var --- symbol "->" --- e <- expr --- return $ LamAbs x e - --- <|> do char '(' --- e <- token expr --- char ')' --- return e + <|> do {name <- macroName; return $ LamMacro name} macroName :: Parser String @@ -406,47 +381,8 @@ var = do char 'x' return x - --- examples in the instructions ---Just (LamDef [] (LamApp (LamVar 1) (LamApp (LamVar 2) (LamVar 3)))) --"x1 (x2 x3)" ---Just (LamDef [] (LamApp (LamApp (LamVar 1) (LamVar 2)) (LamMacro"F"))) --"x1 x2 F" ---Just (LamDef [ ("F", LamAbs 1 (LamVar 1) ) ] (LamAbs 2 (LamApp (LamVar 2) (LamMacro "F")))) --"def F = \x1-> x1 in \x2 -> x2 F" ---Nothing -not in grammar --"def F = \x1 -> x1 (def G = \x1 -> x1 in x1)in \x2 -> x2" ---Nothing -repeated macro definition --"def F = \x1 -> x1 in def F = \x2 -> x2 x1 in x1" ---Nothing -macro body not closed --"def F = x1 in F" - - ---arithmetic expression examples - --- expr ::= term '+' expr ⏐ term --- term ::= factor '*' term ⏐ factor --- factor ::= nat ⏐ '(' expr ')‘ --- nat ::= digit | digit nat --- digit ::= ’0’ ⏐ '1' ⏐ ... ⏐ '9' - --- expr :: Parser AETree --- expr = do t ← term --- char ‘+’ --- e ← expr --- return (Add t e) --- <|> term - --- term :: Parser AETree --- term = do f ← factor --- char ‘*’ --- t ← term --- return (Mul f t) --- <|> factor - --- factor :: Parser AETree --- factor = nat <|> do char '(' --- e ← expr --- char ')' --- return e - --- nat :: Parser AETree --- nat = do ds ← some digit --- return (Lit (read ds)) +fstHead :: [(a,b)] -> a +fstHead = fst . head -- Challenge 5 -- GitLab