http://blog.tmorris.net/posts/20-intermediate-haskell-exercises/

20-intermediate-haskell-exercises.hs

-- http://blog.tmorris.net/posts/20-intermediate-haskell-exercises/
module Main where

class Fluffy f where
  furry :: (a -> b) -> f a -> f b

-- Exercise 1
-- Relative Difficulty: 1
instance Fluffy [] where
  furry _ [] = []
  furry f (x:xs) = f x:furry f xs

-- Exercise 2
-- Relative Difficulty: 1
instance Fluffy Maybe where
  furry _ Nothing = Nothing
  furry f (Just x) = Just (f x)

-- Exercise 3
-- Relative Difficulty: 5
instance Fluffy ((->) t) where
  furry f g = f . g
--  furry f fa = \t -> f (fa t)

newtype EitherLeft b a = EitherLeft (Either a b)
newtype EitherRight a b = EitherRight (Either a b)

instance (Show a, Show b) => Show (EitherLeft b a) where
  show (EitherLeft (Left x)) = "EitherLeft (Left " ++ show x ++ ")"
  show (EitherLeft (Right x)) = "EitherLeft (Right " ++ show x ++ ")"

instance (Show a, Show b) => Show (EitherRight b a) where
  show (EitherRight (Left x)) = "EitherRight (Left " ++ show x ++ ")"
  show (EitherRight (Right x)) = "EitherRight (Right " ++ show x ++ ")"

-- Exercise 4
-- Relative Difficulty: 5
instance Fluffy (EitherLeft t) where
  furry f (EitherLeft (Left a)) = EitherLeft (Left (f a))
  furry _ (EitherLeft (Right t)) = EitherLeft (Right t)

-- Exercise 5
-- Relative Difficulty: 5
instance Fluffy (EitherRight t) where
  furry _ (EitherRight (Left t)) = EitherRight (Left t)
  furry f (EitherRight (Right a)) = EitherRight (Right (f a))

class Misty m where
  banana :: (a -> m b) -> m a -> m b
  unicorn :: a -> m a
  -- Exercise 6
  -- Relative Difficulty: 3
  -- (use banana and/or unicorn)
  furry' :: (a -> b) -> m a -> m b
  furry' f ma = banana (unicorn . f) ma

-- Exercise 7
-- Relative Difficulty: 2
instance Misty [] where
  banana _ [] = []
  banana f (x:xs) = f x ++ banana f xs
  unicorn x = [x]

-- Exercise 8
-- Relative Difficulty: 2
instance Misty Maybe where
  banana _ Nothing = Nothing
  banana f (Just x) = f x
  unicorn x = Just x

-- Exercise 9
-- Relative Difficulty: 6
instance Misty ((->) t) where
  banana f fa = \t -> f (fa t) t
  unicorn x = const x


-- Exercise 10
-- Relative Difficulty: 6
instance Misty (EitherLeft t) where
  banana = error "todo"
  unicorn = error "todo"

-- Exercise 11
-- Relative Difficulty: 6
instance Misty (EitherRight t) where
  banana = error "todo"
  unicorn = error "todo"

-- Exercise 12
-- Relative Difficulty: 3
jellybean :: (Misty m) => m (m a) -> m a
jellybean mma = banana id mma

-- Exercise 13
-- Relative Difficulty: 6
apple :: (Misty m) => m a -> m (a -> b) -> m b
apple ma mf = banana (\a -> banana (\f -> unicorn (f a)) mf) ma

-- Exercise 14
-- Relative Difficulty: 6
moppy :: (Misty m) => [a] -> (a -> m b) -> m [b]
moppy [] _ = unicorn []
-- mb -> m [b] -> m [b]
moppy (a:as) f = banana (\b -> banana (\bs -> unicorn (b:bs)) (moppy as f)) (f a)

-- Exercise 15
-- Relative Difficulty: 6
-- (bonus: use moppy)
sausage :: (Misty m) => [m a] -> m [a]
sausage xs = moppy xs id

-- Exercise 16
-- Relative Difficulty: 6
-- (bonus: use apple + furry')
-- furry' (a -> (b -> c)) m a = m (b -> c)
-- apple m b m (b -> c) = m c
banana2 :: (Misty m) => (a -> b -> c) -> m a -> m b -> m c
banana2 f ma mb = apple mb (furry' f ma)

-- Exercise 17
-- Relative Difficulty: 6
-- (bonus: use apple + banana2)
-- banana2 (a -> b -> c -> d) ma mb = m (c -> d)
banana3 :: (Misty m) => (a -> b -> c -> d) -> m a -> m b -> m c -> m d
banana3 f ma mb mc = apple mc (banana2 f ma mb)

-- Exercise 18
-- Relative Difficulty: 6
-- (bonus: use apple + banana3)
banana4 :: (Misty m) => (a -> b -> c -> d -> e) -> m a -> m b -> m c -> m d -> m e
banana4 f ma mb mc md = apple md (banana3 f ma mb mc)

newtype State s a = State {
  state :: (s -> (s, a))
}

-- Exercise 19
-- Relative Difficulty: 9
instance Fluffy (State s) where
  furry f st = State $ \s -> let (s', a) = (state st s) in (s', f a)

-- Exercise 20
-- Relative Difficulty: 10
instance Misty (State s) where
-- banana :: (a -> m b) -> m a -> m b
-- unicorn :: a -> m a
  banana f s0 = State $ \s -> let (s', a) = state s0 s in state (f a) s'
  unicorn x = State $ \s -> (s, x)

main :: IO ()
main = do
  print $ furry (+1) []
  print $ furry (+1) [1..10]
  print $ furry (+1) Nothing
  print $ furry (+1) (Just 10)
  print $ furry show (+1) $ 10
  print $ furry show (EitherLeft (Left 10::Either Int Double))
  print $ furry show (EitherLeft (Right 0.1::Either Int Double))
  print $ furry show (EitherRight (Left 10::Either Int Double))
  print $ furry show (EitherRight (Right 0.1::Either Int Double))
  print $ (unicorn 10 :: [Int])
  print $ banana (\x -> [x+1, x*10]) [1..10]
  print $ (unicorn 10 :: Maybe Int)
  print $ banana (\x -> Just (x+1)) Nothing
  print $ banana (\x -> Just (x+1)) (Just 100)
  print $ jellybean [[10,11],[12,13]]
  print $ moppy [1..10] Just
  print $ sausage [Just 1, Just 2, Just 3, Nothing, Just 5]
  print $ banana2 (+) [1..9] [100,200..900]
  print $ banana3 (\a b c -> a + b + c) [1..9] [100,200] [10000,20000]
  print $ banana4 (\a b c d -> a + b + c + d) [1..3] [10,20,30] [100,200,300] [1000,2000,3000]
  print $ state (furry (+100000) (State (\s -> (s ++ "ed", read s :: Int)))) "101"
  print $ state (unicorn 0) "hahha"
  print $ state (banana (\i -> State (\s -> (s ++ "2;", i+101))) (State (\s -> (s++"1;", 1)))) ">_<"
  print $ sausage [[1,2,3],[4,5,6],[7,8,9]]