Practice Coding Questions

Basic Concepts

Define a function lastElement that returns the last element of a list, or Nothing if the list is empty.

Answer:

lastElement :: [a] -> Maybe a
lastElement [] = Nothing
lastElement [x] = Just x
lastElement (_:xs) = lastElement xs

Alternative solution using library functions:

lastElement :: [a] -> Maybe a
lastElement [] = Nothing
lastElement xs = Just (last xs)

Write a function isPalindrome that checks if a list reads the same forwards and backwards.

Answer:

isPalindrome :: Eq a => [a] -> Bool
isPalindrome xs = xs == reverse xs

Write a function compress that removes consecutive duplicates from a list.

Answer:

compress :: Eq a => [a] -> [a]
compress [] = []
compress [x] = [x]
compress (x:y:xs)
  | x == y    = compress (y:xs)
  | otherwise = x : compress (y:xs)

Alternative solution:

compress :: Eq a => [a] -> [a]
compress = map head . group

Algebraic Data Types

Define an algebraic data type Tree a for a binary tree, and write a function treeDepth that calculates the maximum depth of the tree.

Answer:

data Tree a = Empty | Node a (Tree a) (Tree a)
 
treeDepth :: Tree a -> Int
treeDepth Empty = 0
treeDepth (Node _ left right) = 1 + max (treeDepth left) (treeDepth right)

Define a data type Expression that can represent arithmetic expressions with addition, subtraction, multiplication, division, and integer constants. Then write a function evaluate that evaluates such an expression.

Answer:

data Expression = Const Int
                | Add Expression Expression
                | Sub Expression Expression
                | Mul Expression Expression
                | Div Expression Expression
 
evaluate :: Expression -> Int
evaluate (Const n) = n
evaluate (Add e1 e2) = evaluate e1 + evaluate e2
evaluate (Sub e1 e2) = evaluate e1 - evaluate e2
evaluate (Mul e1 e2) = evaluate e1 * evaluate e2
evaluate (Div e1 e2) = evaluate e1 `div` evaluate e2

Higher-Order Functions

Implement the map function using foldr.

Answer:

myMap :: (a -> b) -> [a] -> [b]
myMap f = foldr (\x acc -> f x : acc) []

Write a function countIf that counts the number of elements in a list that satisfy a predicate.

Answer:

countIf :: (a -> Bool) -> [a] -> Int
countIf p = length . filter p

Alternative solution:

countIf :: (a -> Bool) -> [a] -> Int
countIf p = foldr (\x acc -> if p x then acc + 1 else acc) 0

Implement the function compose that takes a list of functions and returns their composition.

Answer:

compose :: [a -> a] -> (a -> a)
compose = foldr (.) id

Recursion and Pattern Matching

Write a function takeWhile' that takes elements from a list as long as they satisfy a predicate.

Answer:

takeWhile' :: (a -> Bool) -> [a] -> [a]
takeWhile' _ [] = []
takeWhile' p (x:xs)
  | p x       = x : takeWhile' p xs
  | otherwise = []

Write a function zip3With that combines three lists using a supplied function.

Answer:

zip3With :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zip3With _ [] _ _ = []
zip3With _ _ [] _ = []
zip3With _ _ _ [] = []
zip3With f (a:as) (b:bs) (c:cs) = f a b c : zip3With f as bs cs

Type Classes

Define a data type Complex to represent complex numbers, and make it an instance of Num.

Answer:

data Complex = Complex Double Double
 
instance Num Complex where
  (Complex a b) + (Complex c d) = Complex (a + c) (b + d)
  (Complex a b) - (Complex c d) = Complex (a - c) (b - d)
  (Complex a b) * (Complex c d) = Complex (a*c - b*d) (a*d + b*c)
  negate (Complex a b) = Complex (-a) (-b)
  abs (Complex a b) = Complex (sqrt (a*a + b*b)) 0
  signum (Complex a b) 
    | a == 0 && b == 0 = Complex 0 0
    | otherwise = Complex (a / r) (b / r)
    where r = sqrt (a*a + b*b)
  fromInteger n = Complex (fromInteger n) 0

Create a typeclass Sizeable for containers that have a notion of size, with a method size. Implement it for lists, Maybe, and your own Tree type.

Answer:

class Sizeable a where
  size :: a -> Int
 
instance Sizeable [a] where
  size = length
 
instance Sizeable (Maybe a) where
  size Nothing = 0
  size (Just _) = 1
 
data Tree a = Empty | Node a (Tree a) (Tree a)
 
instance Sizeable (Tree a) where
  size Empty = 0
  size (Node _ left right) = 1 + size left + size right

Monads

Implement the sequence function for the Maybe monad. It should take a list of Maybe values and return a Maybe list of values.

Answer:

sequenceMaybe :: [Maybe a] -> Maybe [a]
sequenceMaybe [] = Just []
sequenceMaybe (Nothing:_) = Nothing
sequenceMaybe (Just x:xs) = do
  rest <- sequenceMaybe xs
  return (x:rest)

Alternative solution:

sequenceMaybe :: [Maybe a] -> Maybe [a]
sequenceMaybe = foldr combine (Just [])
  where combine Nothing _ = Nothing
        combine (Just x) (Just xs) = Just (x:xs)

Write a function safeDivide that performs division but returns a value wrapped in the Either monad, with error messages for division by zero.

Answer:

safeDivide :: Double -> Double -> Either String Double
safeDivide _ 0 = Left "Division by zero"
safeDivide x y = Right (x / y)

Implement the State monad from scratch.

Answer:

newtype State s a = State { runState :: s -> (a, s) }
 
instance Functor (State s) where
  fmap f (State g) = State $ \s ->
    let (a, s') = g s
    in (f a, s')
 
instance Applicative (State s) where
  pure a = State $ \s -> (a, s)
  (State f) <*> (State g) = State $ \s ->
    let (func, s') = f s
        (a, s'') = g s'
    in (func a, s'')
 
instance Monad (State s) where
  return = pure
  (State h) >>= f = State $ \s ->
    let (a, s') = h s
        (State g) = f a
    in g s'
 
get :: State s s
get = State $ \s -> (s, s)
 
put :: s -> State s ()
put s = State $ \_ -> ((), s)
 
modify :: (s -> s) -> State s ()
modify f = State $ \s -> ((), f s)

Parser Combinators

Using Parsec, write a parser for a simple CSV file format where fields are separated by commas and may be quoted with double quotes.

Answer:

import Text.Parsec
import Text.Parsec.String (Parser)
 
csvFile :: Parser [[String]]
csvFile = endBy line eol
 
line :: Parser [String]
line = sepBy cell (char ',')
 
cell :: Parser String
cell = quotedCell <|> simpleCell
 
quotedCell :: Parser String
quotedCell = do
  char '"'
  content <- many (noneOf "\"" <|> try (string "\"\"" >> return '"'))
  char '"'
  return content
 
simpleCell :: Parser String
simpleCell = many (noneOf ",\n\r")
 
eol :: Parser String
eol = try (string "\n\r")
  <|> try (string "\r\n")
  <|> string "\n"
  <|> string "\r"
  ‹?> "end of line"

Write a parser for a simple programming language with variable assignments and arithmetic expressions.

Answer:

import Text.Parsec
import Text.Parsec.String (Parser)
import Text.Parsec.Expr
import qualified Text.Parsec.Token as Token
import Text.Parsec.Language (emptyDef)
 
data Expr = Var String
          | Const Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mul Expr Expr
          | Div Expr Expr
          deriving Show
 
data Stmt = Assign String Expr
          | Seq [Stmt]
          deriving Show
 
-- Lexer
lexer = Token.makeTokenParser emptyDef {
  Token.commentLine = "//",
  Token.identStart = letter,
  Token.identLetter = alphaNum <|> char '_',
  Token.reservedNames = ["let"],
  Token.reservedOpNames = ["+", "-", "*", "/", "="]
}
 
identifier = Token.identifier lexer
reserved = Token.reserved lexer
reservedOp = Token.reservedOp lexer
parens = Token.parens lexer
integer = Token.integer lexer
whiteSpace = Token.whiteSpace lexer
semi = Token.semi lexer
 
-- Expression Parser
expr :: Parser Expr
expr = buildExpressionParser table term
  where
    table = [ [binary "*" Mul AssocLeft, binary "/" Div AssocLeft]
            , [binary "+" Add AssocLeft, binary "-" Sub AssocLeft]
            ]
    binary op fun assoc = Infix (reservedOp op >> return fun) assoc
    term = parens expr
        <|> Var <$> identifier
        <|> Const . fromIntegral <$> integer
 
-- Statement Parser
stmt :: Parser Stmt
stmt = assignStmt <|> seqStmt
 
assignStmt :: Parser Stmt
assignStmt = do
  reserved "let"
  var <- identifier
  reservedOp "="
  e <- expr
  semi
  return $ Assign var e
 
seqStmt :: Parser Stmt
seqStmt = Seq <$> many1 assignStmt
 
-- Program Parser
program :: Parser Stmt
program = do
  whiteSpace
  s <- seqStmt
  eof
  return s

Monad Transformers

Implement a function that reads a file, counts the occurrences of each word, and returns the results in a Map. Use the ReaderT monad transformer to pass configuration like case-sensitivity.

Answer:

import Control.Monad.Reader
import qualified Data.Map as Map
import Data.Char (toLower)
import Data.List (foldl')
 
data Config = Config {
  caseSensitive :: Bool,
  minWordLength :: Int
}
 
type WordCount = Map.Map String Int
type WordCountM = ReaderT Config IO WordCount
 
countWords :: FilePath -> WordCountM
countWords path = do
  config <- ask
  content <- liftIO $ readFile path
  let process = if caseSensitive config then id else map toLower
      validWord w = length w >= minWordLength config
      words' = filter validWord $ words $ process content
      
  return $ foldl' (\acc word -> Map.insertWith (+) word 1 acc) Map.empty words'
 
runWordCount :: FilePath -> Config -> IO WordCount
runWordCount path config = runReaderT (countWords path) config

Create a stack of monad transformers including StateT, ExceptT, and ReaderT to implement a simple evaluator for an arithmetic expression language with variables.

Answer:

import Control.Monad.State
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.Map as Map
 
data Expr = Var String 
          | Const Int
          | Add Expr Expr
          | Sub Expr Expr
          | Mul Expr Expr
          | Div Expr Expr
          deriving Show
 
data EvalError = UnknownVariable String
               | DivisionByZero
               deriving Show
 
type Variables = Map.Map String Int
type Environment = String  -- For example, file being processed
 
type Evaluator a = ExceptT EvalError (ReaderT Environment (StateT Variables IO)) a
 
lookupVar :: String -> Evaluator Int
lookupVar name = do
  vars <- lift $ lift get
  case Map.lookup name vars of
    Nothing -> throwError $ UnknownVariable name
    Just val -> return val
 
setVar :: String -> Int -> Evaluator ()
setVar name value = lift $ lift $ modify $ Map.insert name value
 
evaluate :: Expr -> Evaluator Int
evaluate (Const n) = return n
evaluate (Var name) = lookupVar name
evaluate (Add e1 e2) = (+) <$> evaluate e1 <*> evaluate e2
evaluate (Sub e1 e2) = (-) <$> evaluate e1 <*> evaluate e2
evaluate (Mul e1 e2) = (*) <$> evaluate e1 <*> evaluate e2
evaluate (Div e1 e2) = do
  n1 <- evaluate e1
  n2 <- evaluate e2
  if n2 == 0
    then throwError DivisionByZero
    else return $ n1 `div` n2
 
runEvaluator :: Evaluator a -> Environment -> Variables -> IO (Either EvalError a, Variables)
runEvaluator eval env vars = runStateT (runReaderT (runExceptT eval) env) vars

Equational Reasoning

Prove using equational reasoning that map f (filter p xs) = filter p (map f xs) is not true in general. Find the condition on f and p that would make it true.

Answer: Let’s disprove this by counter-example. Let:

• f x = x + 1
• p x = (x > 5)
• xs = [5]

Now:

• map f (filter p xs) = map f (filter p [5]) = map f [] = []
• filter p (map f xs) = filter p (map f [5]) = filter p [6] = [6]

These are not equal. For the equation to be true, we need: p (f x) = p x for all x.

That is, applying f must not change whether p is satisfied.

Prove using induction that reverse (reverse xs) = xs for any list xs.

Answer: Base case: xs = []

reverse (reverse []) 
= reverse [] 
= [] 

So the property holds for the base case.

Inductive step: Assume reverse (reverse xs) = xs for some list xs. We need to prove reverse (reverse (x:xs)) = x:xs.

reverse (reverse (x:xs))
= reverse (reverse xs ++ [x])  -- By definition of reverse
= reverse [x] ++ reverse (reverse xs)  -- reverse distributes over (++)
= [x] ++ xs  -- By induction hypothesis and definition of reverse
= x:xs  -- By definition of (:)

So the property holds for x:xs if it holds for xs, completing the proof.

Miscellaneous

Implement a function groupBy' that groups adjacent elements in a list according to a specified equivalence function.

Answer:

groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]
groupBy' _ [] = []
groupBy' eq (x:xs) = (x:ys) : groupBy' eq zs
  where
    (ys, zs) = span (eq x) xs

Write a function to calculate the powerset (set of all subsets) of a list.

Answer:

powerset :: [a] -> [[a]]
powerset [] = [[]]
powerset (x:xs) = powerset xs ++ map (x:) (powerset xs)

Implement a function that computes the transitive closure of a directed graph represented as a list of edges.

Answer:

type Graph a = [(a, a)]
 
transitiveClosure :: Eq a => Graph a -> Graph a
transitiveClosure g = until isFixedPoint expand g
  where
    expand g' = g' `union` [(a, c) | (a, b) <- g', (b', c) <- g', b == b']
    union xs ys = xs ++ [y | y <- ys, y `notElem` xs]
    isFixedPoint g' = expand g' == g'

Write a function to find the longest increasing subsequence of a list of numbers.

Answer:

longestIncreasing :: Ord a => [a] -> [a]
longestIncreasing = foldl combine []
  where
    combine [] x = [[x]]
    combine seqs@(curr:rest) x
      | last curr < x = (curr ++ [x]) : seqs
      | otherwise = [x] : seqs
    
    combine acc = maximumBy (comparing length) acc

Dynamic programming solution:

import Data.Array
import Data.List (maximumBy)
import Data.Ord (comparing)
 
longestIncreasing :: Ord a => [a] -> [a]
longestIncreasing xs = backtrack (length xs - 1)
  where
    arr = listArray (0, length xs - 1) xs
    
    -- DP array: dp[i] = length of LIS ending at i
    dp = listArray (0, length xs - 1) 
       [maximum [1 + dp!j | j <- [0..i-1], arr!j < arr!i] `max` 1 | i <- [0..length xs - 1]]
    
    -- Predecessor array: pred[i] = predecessor of i in LIS
    pred = listArray (0, length xs - 1)
         [maximumBy (comparing (\j -> if arr!j < arr!i then dp!j else 0)) [-1..i-1] | i <- [0..length xs - 1]]
    
    -- Backtrack to construct the sequence
    backtrack i
      | i < 0 = []
      | pred!i == -1 = [arr!i]
      | otherwise = backtrack (pred!i) ++ [arr!i]

Challenge Problems

Implement a function that finds all solutions to the 8-queens problem.

Answer:

type Board = [Int]  -- Positions of queens in each row
 
queens :: Int -> [Board]
queens n = queens' n
  where
    queens' 0 = [[]]
    queens' k = [q:qs | qs <- queens' (k-1), q <- [1..n], safe q qs]
    
    safe q qs = and [not (check q qs i) | i <- [1..length qs]]
    check q qs i = q == qs!!(i-1) ||            -- Same column
                   q == qs!!(i-1) + i ||        -- Same diagonal
                   q == qs!!(i-1) - i           -- Same diagonal

Implement a parser for JSON values using the Parsec library.

Answer:

import Text.Parsec
import Text.Parsec.String (Parser)
import Control.Applicative hiding ((<|>), many)
import qualified Data.Map as M
 
data JSON = JNull
          | JBool Bool
          | JNumber Double
          | JString String
          | JArray [JSON]
          | JObject (M.Map String JSON)
          deriving (Show, Eq)
 
jsonParser :: Parser JSON
jsonParser = spaces *> jsonValue <* spaces
 
jsonValue :: Parser JSON
jsonValue = choice [
    JNull <$ string "null",
    JBool <$> jsonBool,
    JNumber <$> jsonNumber,
    JString <$> jsonString,
    JArray <$> jsonArray,
    JObject <$> jsonObject
  ]
 
jsonBool :: Parser Bool
jsonBool = (True <$ string "true") <|> (False <$ string "false")
 
jsonNumber :: Parser Double
jsonNumber = do
  sign <- option 1 ((-1) <$ char '-')
  whole <- many1 digit
  frac <- option "0" (char '.' *> many1 digit)
  exp <- option 0 (do
    e <- oneOf "eE"
    expSign <- option 1 (1 <$ char '+' <|> (-1) <$ char '-')
    expDigits <- many1 digit
    return $ expSign * read expDigits)
  let num = read (whole ++ "." ++ frac) * (10 ^^ exp)
  return (sign * num)
 
jsonString :: Parser String
jsonString = char '"' *> many jsonChar <* char '"'
  where
    jsonChar = noneOf "\\\"\n\r\t\b\f" <|> 
              (char '\\' *> choice [
                char '"' *> pure '"',
                char '\\' *> pure '\\',
                char '/' *> pure '/',
                char 'b' *> pure '\b',
                char 'f' *> pure '\f',
                char 'n' *> pure '\n',
                char 'r' *> pure '\r',
                char 't' *> pure '\t',
                char 'u' *> count 4 hexDigit >>= return . read . ("0x" ++)
              ])
 
jsonArray :: Parser [JSON]
jsonArray = char '[' *> spaces *> sepBy (spaces *> jsonValue <* spaces) (char ',') <* spaces <* char ']'
 
jsonObject :: Parser (M.Map String JSON)
jsonObject = M.fromList <$> (char '{' *> spaces *> sepBy pair (char ',') <* spaces <* char '}')
  where
    pair = do
      key <- spaces *> jsonString <* spaces
      char ':'
      value <- spaces *> jsonValue <* spaces
      return (key, value)

Implement a functional red-black tree with insertion and deletion operations.

Answer:

data Color = Red | Black deriving (Show, Eq)
data RBTree a = Empty | Node Color (RBTree a) a (RBTree a) deriving (Show)
 
-- Insertion
insert :: Ord a => a -> RBTree a -> RBTree a
insert x t = makeBlack (ins t)
  where
    ins Empty = Node Red Empty x Empty
    ins n@(Node color left y right)
      | x < y = balance color (ins left) y right
      | x > y = balance color left y (ins right)
      | otherwise = n
    makeBlack (Node _ l v r) = Node Black l v r
    makeBlack Empty = Empty
 
balance :: Color -> RBTree a -> a -> RBTree a -> RBTree a
balance Black (Node Red (Node Red a x b) y c) z d = 
  Node Red (Node Black a x b) y (Node Black c z d)
balance Black (Node Red a x (Node Red b y c)) z d = 
  Node Red (Node Black a x b) y (Node Black c z d)
balance Black a x (Node Red (Node Red b y c) z d) = 
  Node Red (Node Black a x b) y (Node Black c z d)
balance Black a x (Node Red b y (Node Red c z d)) = 
  Node Red (Node Black a x b) y (Node Black c z d)
balance color a x b = Node color a x b
 
-- Helper functions for deletion (more complex)
delete :: Ord a => a -> RBTree a -> RBTree a
delete x t = makeBlack (del x t)
  where
    makeBlack Empty = Empty
    makeBlack (Node _ a y b) = Node Black a y b
 
    del _ Empty = Empty
    del x (Node _ a y b)
      | x < y = deleteLeft x a y b
      | x > y = deleteRight x a y b
      | otherwise = fuse a b
 
    deleteLeft x a y b
      | isBlack a = balanceLeft (del x a) y b
      | otherwise = Node Red (del x a) y b
 
    deleteRight x a y b
      | isBlack b = balanceRight a y (del x b)
      | otherwise = Node Red a y (del x b)
 
    isBlack Empty = True
    isBlack (Node Black _ _ _) = True
    isBlack _ = False
 
    balanceLeft :: RBTree a -> a -> RBTree a -> RBTree a
    -- Complex balancing cases omitted for brevity
 
    balanceRight :: RBTree a -> a -> RBTree a -> RBTree a
    -- Complex balancing cases omitted for brevity
 
    fuse :: RBTree a -> RBTree a -> RBTree a
    -- Complex fusion cases omitted for brevity