Haskell Exercises

acrobat.hs

type Move = (Char, Int)
type Pole = (Int, Int)
type State = ([Move], Pole)

newtype Akr a = K (State -> (a, State))

threshold :: Int
threshold = 4

isBalanced :: Pole -> Bool
isBalanced (l, r) = abs (l - r) < threshold

move :: Pole -> Move -> (Int, Int)
move (l, r) ('L', n) = (l + n, r)
move (l, r) ('R', n) = (l, r + n)

acrobat' :: (State -> (Bool, State))

acrobat' ([], pole) = (isBalanced pole, ([], pole))

acrobat' ((m:ms), pole) = let
  pole' = move pole m
  isOk = isBalanced pole'
  in if isOk then acrobat' (ms, pole')
             else (False, ((m:ms), pole))

acrobat :: Akr Bool
acrobat = K (acrobat')

-- execute the following sequence of birds landings.
-- 2 on the left, 4 on the right, -1 left, 1 right
moves :: [Move]
moves = [('L', 2), ('R', 4), ('L', -1), ('R', 1)]

app :: Akr a -> State -> (a, State)
app (K s) st = s st

-- execute a call in which the pole has no birds on it
main = do
  let res = app acrobat (moves, (0, 0))
  putStrLn $ show res

altMap.hs

altMap :: (a -> b) -> (a -> b) -> [a] -> [b]
altMap f g = fst . foldr (\x (xs, useF) ->
                      if useF then ((f x) : xs, False)
                              else ((g x) : xs, True)
                          ) ([], True)

arrow.hs

instance Functor ((->) a) where
  -- fmap :: (b -> c) -> (a -> b) -> (a -> c)
  fmap = (.)
  
instance Applicative ((->) a) where
  -- pure :: b -> (a -> b)
  pure x = \_ -> x -- aka const
  
  -- (<*>) :: (a -> b -> c) -> (a -> b) -> (a -> c)
  g <*> h = \x -> g x (h x)
                
instance Monad ((->) a) where
  -- (>>=) :: (a -> b) -> (b -> a -> c) -> a -> c     
  g >>= h = \x -> h (g x) x

dec2int.hs

dec2int :: [Int] -> Int
dec2int = foldl (\acc x -> acc*10 + x) 0

Expr.hs

module Expr where

data Expr a = Var a | Val Int | Add (Expr a) (Expr a)
  deriving Show

instance Functor Expr where
  -- fmap :: (a -> b) -> Expr a -> Expr b
  fmap f (Var x)   = Var $ f x
  fmap _ (Val n)   = Val n
  fmap f (Add l r) = Add (fmap f l) (fmap f r)

instance Applicative Expr where
  -- pure :: a -> Expr a
  pure = Var

  -- (<*>) :: Expr (a -> b) -> Expr a -> Expr b
  (Var f)   <*> x = fmap f x
  (Val n)   <*> _ = Val n
  (Add l r) <*> x = Add (l <*> x) (r <*> x)

instance Monad Expr where
  -- (>>=) :: Expr a -> (a -> Expr b) -> Expr b
  (Var x)   >>= f = f x
  (Val n)   >>= f = Val n
  (Add l r) >>= f = Add (l >>= f) (r >>= f)

fold.hs

foldr :: (a -> b -> b) -> b -> [a] -> b
foldr f v [] = v
foldr f v (x:xs) = f x (foldr f v xs)

foldl :: (a -> b -> a) -> a -> [b] -> a
foldl f v []     = v
foldl f v (x:xs) = foldl f (f v x) xs

foldr.hs

all' :: (a -> Bool) -> [a] -> Bool
all' p = foldr (\x acc -> acc && p x) True

any' :: (a -> Bool) -> [a] -> Bool
any' p = foldr (\x acc -> acc || p x) False

takeWhile' :: (a -> Bool) -> [a] -> [a]
takeWhile' _ []     = []
takeWhile' p (x:xs) = if p x then x:(takeWhile' p xs) else []

dropWhile' :: (a -> Bool) -> [a] -> [a]
dropWhile' _ []     = []
dropWhile' p (x:xs) = if p x then dropWhile' p xs else x:xs

listComprehension.hs

l :: (a -> b) -> (a -> Bool) -> [a] -> [b]
l f p xs = [f x | x <- xs, p x]

l' :: (a -> b) -> (a -> Bool) -> [a] -> [b]
l' f p = map f . filter p

mapFilter.hs

-- define map and filter with foldr

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

filter' :: (a -> Bool) -> [a] -> [a]
filter' p = foldr (\x acc -> if p x then x : acc else acc) []

ParensBalanceMonadParse.hs

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Main where

type State = String
type Input = String

newtype Pila a = P (State -> [(a, State)])

app :: Pila a -> State -> [(a, State)]
app (P p) st = p st

instance Functor Pila where
    -- fmap :: (a -> b) -> Pila a -> Pila b
    fmap f pila = P (\s -> case app pila s of
        []           -> []
        [(v, stack)] -> [(f v, stack)])

instance Applicative Pila where
    -- pure :: a -> Pila a
    pure x = P (\s -> [(x, s)])

    -- (<*>) :: Pila (a -> b) -> Pila a -> Pila b
    pf <*> pila = P (\s -> case app pf s of
        [] -> []
        [(f, s')] -> app (fmap f pila) s')

instance Monad Pila where
    -- return :: a -> Pila a
    return = pure

    -- (>>=) :: Pila a -> (a -> Pila b) -> Pila b
    pila >>= f = P (\s -> case app pila s of
        []           -> []
        [(v, stack)] -> app (f v) stack)

push :: Char -> Pila ()
push c = P (\s -> [((), c:s)])

pop :: Pila Char
pop = P (\s -> case s of
    []     -> []
    (x:xs) -> [(x, xs)])

balance :: Input -> Pila Bool

balance [] = P (\s -> case s of
    "" -> [(True, "")]
    _  -> [(False, s)])

balance ('(':xs) = push '(' >> balance xs
balance (')':xs) = pop >> balance xs
balance (_:xs)   = balance xs

input :: Input
input = "((+)v(+))"

main :: IO ()
main = do
    let pila = balance input
    case app pila [] of
        []           -> putStrLn "No, too many closed parenthesis"
        [(False, _)] -> putStrLn "No, too many open parenthesis"
        [(True, "")] -> putStrLn $ input ++ " is balanced"
        _            -> error "Should not happen"

ParensBalanceSimpleSt.hs

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Main where
type Pds = String
type Input = String
type State = (Pds, Input)

newtype PDA a = P (State -> (a, State))

app :: PDA a -> State -> (a, State)
app (P p) st = p st

balance' :: State -> (Bool, State)
balance' s@([], []) = (True, s)
balance' s@(_, []) = (False, s)

balance' (s, '(':inp) = balance' ('(':s, inp) -- push

balance' s@([], ')':_) = (False, s)
balance' (_:ss, ')':inp) = balance' (ss, inp) -- pop

balance' (s, _:inp)   = balance' (s, inp) -- skip other characters

balance :: PDA Bool
balance = P (balance')

input :: Input
input = "(()())()()"

main :: IO ()
main = do
    case app balance ("", input) of
        (False, ([], _)) -> putStrLn "No, too many closed parenthesis"
        (False, (_, [])) -> putStrLn "No, too many open parenthesis"
        (True, _)        -> putStrLn $ input ++ " is balanced"

pole.hs

type Pole = (Int, Int) -- number of birds on left and right

newtype Line a = L (Pole -> (Maybe a, Pole))

-- i) apply the function contained in a (Line a) value to a Pole
app :: Line a -> Pole -> (Maybe a, Pole)
app (L l) pole = l pole

-- ii) functor, applicative, monad

instance Monad Line where
    -- (>>=) :: Line a -> (a -> Line b) -> Line b
    l >>= f = L (\p ->
        let (x, p') = app l p
        in case x of
            Nothing  -> (Nothing, p)
            (Just y) -> app (f y) p')

instance Functor Line where
    -- fmap :: (a -> b) -> Line a -> Line b
    fmap f l = do
        x <- l
        return $ f x

instance Applicative Line where
    -- pure :: a -> Line a
    pure x = L (\p -> (Just x, p))

    -- (<*>) :: Line (a -> b) -> Line a -> Line b
    lf <*> l = do
        f <- lf
        fmap f l

-- iii) landLeft, landRight that model the landing of birds
landLeft :: Int -> Line ()
landLeft n = L (\(nl, nr) ->
    if abs (nl + n - nr) < 4
        then (Just (), (nl + n, nr))
        else (Nothing, (nl, nr)))

landRight :: Int -> Line ()
landRight n = L (\(nl, nr) ->
    if abs (nr + n - nl) < 4
        then (Just (), (nl, nr + n))
        else (Nothing, (nl, nr)))

-- iv) execute the following sequence of birds landings.
-- 2 on the left, 4 on the right, -1 left, 1 right

g :: Line ()
g = do
    landLeft 2
    landRight 4
    landLeft (-1)
    landRight 1

-- v) execute a call in which the pole has no birds on it
-- app g (0,0)
-- > (Nothing, (1,4))

RelabelInfix.hs

module RelabelInfix where

type State = Int

newtype ST a = S (State -> (a, State))

app :: ST a -> State -> (a, State)
app (S st) x = st x

instance Monad ST where
  -- (>>=) :: ST a -> (a -> ST b) -> ST b
  stx >>= f = S (\s ->
    let (x, s') = app stx s
    in app (f x) s')

instance Functor ST where
  -- fmap :: (a -> b) -> ST a -> ST b
  fmap f st = do
    x <- st
    return $ f x
  
instance Applicative ST where
  -- pure :: a -> ST a
  pure x = S (\s -> (x, s))

  -- (<*>) :: ST (a -> b) -> ST a -> ST b
  stf <*> st = do
    f <- stf
    fmap f st

data Tree a = Leaf a | Node (Tree a) a (Tree a)
            deriving Show

tree :: Tree Char
tree = Node (Node (Leaf 'c') 'b' (Leaf 'd')) 'a' (Leaf 'e')

-- infix: left, root, right
rlabel :: Tree a -> Int -> (Tree Int, Int)
rlabel (Leaf _) n     = (Leaf n, n + 1)
rlabel (Node l x r) n = ((Node l' n' r'), n'')
  where
    (l', n')  = rlabel l n
    (r', n'') = rlabel r (n' + 1)

-- state transformer that returns the current state as
-- its result, and the next integer as the new state.
fresh :: ST Int
fresh = S (\n -> (n, n+1))

-- applicative version
alabel :: Tree a -> ST (Tree Int)
alabel (Leaf _)     = fmap Leaf fresh
alabel (Node l _ r) = pure Node <*> alabel l <*> fresh <*> alabel r

-- monadic version
mlabel :: Tree a -> ST (Tree Int)

mlabel (Leaf _) = do
  n <- fresh
  return $ Leaf n
  
mlabel (Node l _ r) = do
  l' <- mlabel l
  n' <- fresh
  r' <- mlabel r
  return $ Node l' n' r'

RelabelST.hs

module RelabelST where

type State = Int

newtype ST a = S (State -> (a, State))

app :: ST a -> State -> (a, State)
app (S st) x = st x

instance Monad ST where
  -- (>>=) :: ST a -> (a -> ST b) -> ST b
  stx >>= f = S (\s ->
    let (x, s') = app stx s
    in app (f x) s')

instance Functor ST where
  -- fmap :: (a -> b) -> ST a -> ST b
  fmap f st = do
    x <- st
    return $ f x
  
instance Applicative ST where
  -- pure :: a -> ST a
  pure x = S (\s -> (x, s))

  -- (<*>) :: ST (a -> b) -> ST a -> ST b
  stf <*> st = do
    f <- stf
    fmap f st

data Tree a = Leaf a | Node (Tree a) (Tree a)
            deriving Show

-- state transformer that returns the current state as
-- its result, and the next integer as the new state.
fresh :: ST Int
fresh = S (\n -> (n, n+1))

-- applicative version
alabel :: Tree a -> ST (Tree Int)
alabel (Leaf x)   = fmap Leaf fresh
alabel (Node l r) = pure Node <*> alabel l <*> alabel r

-- monadic version
mlabel :: Tree a -> ST (Tree Int)

mlabel (Leaf x) = do
  n <- fresh
  return $ Leaf n

mlabel (Node l r) = do
  l' <- mlabel l
  r' <- mlabel r
  return $ Node l' r'

state.hs

-- state monad starting from monad

type State = Int

newtype ST a = S (State -> (a, State))

app :: ST a -> State -> (a, State)
app (S f) s = f s

instance Monad ST where
    -- (>>=) :: ST a -> (a -> ST b) -> ST b
    st >>= f = S (\s ->
        let (x, s') = app st s
        in app (f x) s')

    return = pure

instance Functor ST where
    -- fmap :: (a -> b) -> ST a -> ST b
    fmap f st = do
        x <- st
        return $ f x

instance Applicative ST where
    -- pure :: a -> ST a
    pure x = S (\s -> (x, s))

    -- (<*>) :: ST (a -> b) -> ST a -> ST b
    stf <*> stx = do
        f <- stf
        fmap f stx

zipList.hs

-- pure: makes an infinite list of copies of its argument
-- <*>: applies each argument function to the corresponding argument value at the same position

newtype ZipList a = Z [a] deriving Show

repeat' :: a -> [a]
repeat' x = x : repeat' x

instance Functor ZipList where
    -- fmap :: (a -> b) -> ZipList a -> ZipList b
    fmap f (Z xs) = Z $ map f xs

instance Applicative ZipList where
    -- pure :: a -> ZipList a
    pure x = Z $ repeat' x

    -- (<*>) :: ZipList (a -> b) -> ZipList a -> ZipList b
    (Z gs) <*> (Z xs) = Z $ [g x | (g, x) <- zip gs xs]

ziplist.hs

-- pure: makes an infinite list of copies of its argument
-- <*>: applies each argument function to the corresponding argument value at the same position

newtype ZipList a = Z [a] deriving Show

repeat' :: a -> [a]
repeat' x = x : repeat' x

instance Functor ZipList where
    -- fmap :: (a -> b) -> ZipList a -> ZipList b
    fmap f (Z xs) = Z $ map f xs

instance Applicative ZipList where
    -- pure :: a -> ZipList a
    pure x = Z $ repeat' x

    -- (<*>) :: ZipList (a -> b) -> ZipList a -> ZipList b
    (Z gs) <*> (Z xs) = Z $ [g x | (g, x) <- zip gs xs]