"git@git.soton.ac.uk:gdp-project-4/360monodepth.git" did not exist on "6f32d05b9a68d69f5d00dc2fd168f4fe976d83f6"
Select Git revision
DataDrivenMethods_Tutorial_DWCarter_V5.pptx
Challenges.hs 19.38 KiB
{-# LANGUAGE DeriveGeneric #-}
-- comp2209 Functional Programming Challenges
-- (c) University of Southampton 2020
-- Skeleton code to be updated with your solutions
-- The dummy functions here simply return an arbitrary value that is usually wrong
-- 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
-- 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
import Data.Char
import Parsing
import Control.Monad
import Data.List
import GHC.Generics (Generic,Generic1)
import Control.DeepSeq
import System.IO
import System.Random
import Control.Applicative
-- 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)
-- types for Parts II and III
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)
-- END OF CODE YOU MUST NOT MODIFY
-- ADD YOUR OWN CODE HERE
-- Challenge 1 --
solveWordSearch :: [ String ] -> WordSearchGrid -> [ (String,Maybe Placement) ]
solveWordSearch ss css = map (findString css) ss
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
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
| elemAt css (x,y) == l && result /= Nothing = result
| otherwise = findLocation css (x+1,y) s
where
result = findPlacement css (x,y) ls
limit = length css - 1
--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)
| checkWordDir css (x,y) Up s = Just ((x,y),Up)
| checkWordDir css (x,y) Down s = Just ((x,y),Down)
| checkWordDir css (x,y) UpForward s = Just ((x,y),UpForward) | checkWordDir css (x,y) UpBack s = Just ((x,y),UpBack)
| checkWordDir css (x,y) DownForward s = Just ((x,y),DownForward)
| checkWordDir css (x,y) DownBack s = Just ((x,y),DownBack)
| otherwise = Nothing
checkWordDir :: WordSearchGrid -> Posn -> Orientation -> String -> Bool
checkWordDir css (x,y) dir (l:[]) | nextElem css (x,y) dir == Just l = True
| otherwise = False
checkWordDir css (x,y) dir (l:ls) | nextElem css (x,y) dir == Just l = checkWordDir css (nextPos dir (x,y)) dir ls
| otherwise = False
--------------------pattern matching for traversing the grid--------------------
--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)
nextPos Up (x,y) = (x,y-1)
nextPos Down (x,y) = (x,y+1)
nextPos UpForward (x,y) = (x+1,y-1)
nextPos UpBack (x,y) = (x-1,y-1)
nextPos DownForward (x,y) = (x+1,y+1)
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
--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'))
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 --
--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
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
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
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
-- --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
in (x : rows,gen')
rowConvert cs gen (Rand:xs) = let (rows,gen') = rowConvert cs newGen xs
in (randChar : rows,gen')
where
(index,newGen) = randomR (0,length cs - 1) gen
randChar = cs !! index
--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
where
(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
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) )
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
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 ||
y' < 0 || y' > length rg - 1 = False
| foldl (&&) True (map (\(a,b) -> Letter a == b || b == Rand) $ zip s lettersGrid) = True
| otherwise = False
where
posns = iterate (nextPos dir) (x,y)
lettersGrid = take (length s) $ map (elemAt rg) posns
--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
| otherwise = (addToGrid randomDir s rg (x,y),newGen)
where
( (x,y),newGen ) = generatePos gen (length rg)
vDirs = validDirs rg s (x,y)
randomDir = let (index,_) = randomR (0,length vDirs - 1) gen
in vDirs !! index
addToGrid :: Orientation -> String -> RandGrid -> Posn -> RandGrid
addToGrid dir (c:[]) rg (x',y') = insertAt2D (Letter c) (x',y') rg
addToGrid dir (c:cs) rg (x',y') = addToGrid dir cs charAdded (nextPos dir (x',y'))
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)
generatePos gen dim = let (x,gen') = randomR (0,dim - 1) gen :: (Int,StdGen)
(y,gen'') = randomR (0,dim - 1) gen' :: (Int,StdGen)
in ((x,y),gen'')
--- 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
-- Challenge 3 --
-- 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) = exprBrackets e
--applies brackets to expr if needed
exprBrackets :: LamExpr -> StringexprBrackets e | fst (head (parse expr str)) == e = str --omit brackets
| otherwise = "(" ++ str ++ ")" --include brackets
where
str = exprToStr 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
-- 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"
-- Challenge 4 --
-- 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)
--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
parseLamMacro str | parsed == [] = Nothing
| otherwise = Just parsed
where
parsed = fst (head (parse (macroExpr []) str)) --HEAD WILL NOT WORK
macroExpr :: [ (String,LamExpr) ] -> Parser LamMacroExpr
macroExpr ms = do string "def"
name <- token macroName
symbol "="
e <- token expr
token $ string "in"
macros <- macroExpr $ ms ++ [(name,e)]
return $ macros
<|> do e <- token expr
return $ LamDef ms e
-- macroExpr :: Parse LamMacroExpr
-- macroExpr = do string "def"
-- name <- token macroName
-- symbol "="
-- e <- token expr
-- token $ string "in"
-- macros <- macroLoop
-- return $ LamDef macros
-- where
-- macroLoop :: Parse [(String,LamExpr)]-- macroLoop = do string "def"
-- name <- token macroName
-- symbol "="
-- e <- token expr
-- token $ string "in"
-- ms <- many macroExpr
-- return ((name,e):ms) <|>
-- do {e <- token expr;return []}
expr :: Parser LamExpr
expr = do {x <- var; return $ LamVar x}
<|> do {name <- macroName;return $ LamMacro name}
<|> do e1 <- expr
space
e2 <- expr
return $ LamApp e1 e2
<|> do char '\\'
x <- var
symbol "->"
e <- expr
return $ LamAbs x e
<|> do char '('
e <- token expr
char ')'
return e
macroName :: Parser String
macroName = do name <- some upper
return name
var :: Parser Int
var = do char 'x'
x <- nat
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))
-- Challenge 5
cpsTransform :: LamMacroExpr -> LamMacroExpr
cpsTransform _ = LamDef [] (LamVar 0)
-- Examples in the instructions
exId = (LamAbs 1 (LamVar 1))
ex5'1 = LamDef [] (LamApp (LamVar 1) (LamVar 2))
ex5'2 = (LamDef [ ("F", exId) ] (LamVar 2) )
ex5'3 = (LamDef [ ("F", exId) ] (LamMacro "F") )
ex5'4 = (LamDef [ ("F", exId) ] (LamApp (LamMacro "F") (LamMacro "F")))
-- Challenge 6
innerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
innerRedn1 _ = Nothing
outerRedn1 :: LamMacroExpr -> Maybe LamMacroExpr
outerRedn1 _ = Nothing
compareInnerOuter :: LamMacroExpr -> Int -> (Maybe Int,Maybe Int,Maybe Int,Maybe Int)
compareInnerOuter _ _ = (Nothing,Nothing,Nothing,Nothing)
-- Examples in the instructions
-- (\x1 -> x1 x2)
ex6'1 = LamDef [] (LamAbs 1 (LamApp (LamVar 1) (LamVar 2)))
-- def F = \x1 -> x1 in F
ex6'2 = LamDef [ ("F",exId) ] (LamMacro "F")
-- (\x1 -> x1) (\x2 -> x2)
ex6'3 = LamDef [] ( LamApp exId (LamAbs 2 (LamVar 2)))
-- (\x1 -> x1 x1)(\x1 -> x1 x1)
wExp = (LamAbs 1 (LamApp (LamVar 1) (LamVar 1)))
ex6'4 = LamDef [] (LamApp wExp wExp)
-- def ID = \x1 -> x1 in def FST = (\x1 -> λx2 -> x1) in FST x3 (ID x4)
ex6'5 = LamDef [ ("ID",exId) , ("FST",LamAbs 1 (LamAbs 2 (LamVar 1))) ] ( LamApp (LamApp (LamMacro "FST") (LamVar 3)) (LamApp (LamMacro "ID") (LamVar 4)))
-- def FST = (\x1 -> λx2 -> x1) in FST x3 ((\x1 ->x1) x4))
ex6'6 = LamDef [ ("FST", LamAbs 1 (LamAbs 2 (LamVar 1)) ) ] ( LamApp (LamApp (LamMacro "FST") (LamVar 3)) (LamApp (exId) (LamVar 4)))
-- def ID = \x1 -> x1 in def SND = (\x1 -> λx2 -> x2) in SND ((\x1 -> x1 x1 ) (\x1 -> x1 x1)) ID
ex6'7 = LamDef [ ("ID",exId) , ("SND",LamAbs 1 (LamAbs 2 (LamVar 2))) ] (LamApp (LamApp (LamMacro "SND") (LamApp wExp wExp) ) (LamMacro "ID") )