fpc-22-11-2017.hs

import Data.List
import Control.Monad
import Control.Monad.ST
import Data.STRef
import System.Random
 
newtype Reader r a = Reader { runReader :: r -> a }
 
instance Functor (Reader r) where
  -- fmap :: (a -> b) -> Reader r a -> Reader r b
  fmap f (Reader rx) = Reader $ \env -> f (rx env)
 
instance Applicative (Reader r) where
  pure x = Reader $ \_ -> x
  -- (<*>) :: Reader r (a -> b) -> Reader r a -> Reader r b
  Reader rf <*> Reader rx = Reader $ \env -> (rf env) (rx env)
 
instance Monad (Reader r) where
  -- (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b
  Reader ra >>= mf = Reader $ \env ->
    runReader (mf (ra env)) env
 
ask :: Reader r r
ask = Reader id
 
local :: (r -> r') -> Reader r' a -> Reader r a
local f (Reader ra) = Reader $ \env -> ra (f env)
 
testReader :: Reader Int (Int, Int, Int)
testReader = do
  x <- (+1) <$> ask
  y <- pure (+2) <*> ask
  z <- local (+3) ask
  pure (x, y, z)
 
newtype Writer w a = Writer { runWriter :: (a, w) }
 
instance Functor (Writer w) where
  -- fmap :: (a -> b) -> Writer w a -> Writer w b
  fmap f (Writer (a, w)) = Writer (f a, w)
 
instance Monoid w => Applicative (Writer w) where
  -- pure :: a -> Writer w a
  pure x = Writer (x, mempty)
  -- (<*>) :: Writer w (a -> b) -> Writer w a -> Writer w b
  Writer (f, wf) <*> Writer (x, wx) = Writer (f x, wf `mappend` wx)
  
instance Monoid w => Monad (Writer w) where
  -- (>>=) :: Writer w a -> (a -> Writer w b) -> Writer w b
  Writer (a, wa) >>= mf =
    let (b, wb) = runWriter (mf a)
    in Writer (b, wa `mappend` wb)
 
tell :: w -> Writer w ()
tell x = Writer ((), x)
 
listen :: Writer w a -> Writer w (a, w)
listen (Writer (a, w)) = Writer ((a, w), w)
 
testWriter :: Writer [String] String
testWriter = do
  tell ["a"]
  x <- (show . snd) <$> listen (tell ["b"])
  y <- pure (show . snd) <*> listen (tell ["c"])
  pure $ "x = " ++ x ++ "; y = " ++ y
 
newtype State s a = State { runState :: s -> (a, s) }
 
instance Functor (State s) where
  fmap f (State xs) = State $ \s ->
    let (a, s') = xs s
    in (f a, s')
 
instance Applicative (State s) where
  pure x = State $ \s -> (x, s)
  State fs <*> State xs = State $ \s ->
    let (f, s') = fs s
        (x, s'') = xs s'
    in (f x, s'')
 
instance Monad (State s) where
  State as >>= mf = State $ \s ->
    let (a, s') = as s
    in runState (mf a) 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 = do
  s <- get
  put (f s)
  
testState :: State Int (Int, Int, Int)
testState = do
  x <- (+1) <$> get
  y <- pure (+2) <*> get
  modify (+3)
  z <- get
  pure (x, y, z)
 
randomRState :: (RandomGen g, Random a) => (a, a) -> State g a
randomRState range = do
  g <- get
  let (x, g') = randomR range g
  put g'
  pure x
 
fib :: Int -> Integer
fib n = head $ drop n fibs
 where fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
 
fib' :: Int -> Integer
fib' 0 = 0
fib' 1 = 1
fib' n = runST $ do
  ppRef <- newSTRef 0
  pRef <- newSTRef 1
  forM_ [1..n] $ \_ -> do
    pp <- readSTRef ppRef
    p <- readSTRef pRef
    writeSTRef ppRef p
    let newP = p + pp
    writeSTRef pRef (newP `seq` newP)
  readSTRef ppRef
 
fib'' :: Int -> Integer
fib'' n = fst $ foldl' go (0,1) [1..n]
 where go (pp, p) _ = let newP = p + pp in newP `seq` (p, newP)
 
fib''' :: Int -> Integer
fib''' 0 = 0
fib''' 1 = 1
fib''' n = runST $ do
  ppRef <- newSTRef 0
  pRef <- newSTRef 1
  forM_ [1..n] $ \_ -> do
    pp <- readSTRef ppRef
    p <- readSTRef pRef
    writeSTRef ppRef p
    modifySTRef' pRef (+pp)
  readSTRef ppRef