Reverse State Monad from Luke Palmer's blog

RState.hs

{-

 from http://lukepalmer.wordpress.com/2008/08/10/mindfuck-the-reverse-state-monad/

 also look at https://github.com/luqui/backward-state

-}
module RState where

newtype RState s a = RState { runRState :: s -> (a,s) }

evalRState :: s -> RState s a -> a
evalRState s f = fst (runRState f s)

instance Monad (RState s) where
    return x = RState $ (,) x
    RState sf >>= f = RState $ \s ->
        let (a,s'') = sf s'
            (b,s') = runRState (f a) s
        in (b,s'')

get :: RState s s
get = RState $ \s -> (s,s)

modify :: (s -> s) -> RState s ()
modify f = RState $ \s -> ((),f s)

put :: s -> RState s ()
put = modify . const

-- cumulativeSums [1,2,3,4,5] = [0,1,3,6,10,15]
cumulativeSums = scanl (+) 0

computeFibs = evalRState [] $ do
    -- here the state is what we want: the fibonacci numbers
    fibs <- get
    modify cumulativeSums
    -- now the state is the difference sequence of
    -- fibs, [1,0,1,1,2,3,5,8,13,...], because the
    -- cumulativeSums of that sequence is fibs.  Notice
    -- that this sequence is the same as 1:fibs, so
    -- just put that to get here.
    put (1:fibs)
    -- And here the state is empty (or whatever else
    -- we want it to be, because we just overwrite it on
    -- the previous line -- but we defined it to be
    -- empty on the evalRState line)
    return fibs


{-
    computeFibs = get >>= \fibs -> (modify cumulativeSums
                      >> put (1:fibs) >> return fibs)

   computeFibs = RState $ \s -> (s, s)
               >>= \fibs -> RState $ \s -> (fibs, cum $ 1:fibs)
    =>
       RState $ \s2 -> let (a, s0) = (s1, s1)
                           (b, s1) = (a, cum $ 1:a)
                       in  (b, s0)
    =>
       RState $ \s -> (a, cum $ 1:a)

    => a = cumulativeSums $ 1:a

    n  | 1:xs                | cum $ 1:xs
    0  | [1 ..               | [0 ..
    1  | [1, 0 ..            | [0, 1 ..
    2  | [1, 0, 1 ..         | [0, 1, 1 ..
    3  | [1, 0, 1, 1 ..      | [0, 1, 1, 2 ..
    4  | [1, 0, 1, 1, 2..    | [0, 1, 1, 2, 3 ..

   f_n = f_(n - 1) + f_(n - 2)

   g_0 = 1, g_n = f_(n - 1) for all n > 0

   h_0 = 0, h_n = sum [g_0, g_1 .. g_(n - 1)] for all n > 0

  =>
   h_0 = 0, h_1 = 1, h_2 = 1, h_3 = 2, h_4 = 3, h_5 = 5
               h_n = 1 + sum [f_0, f_1, f_(n - 2)]

  Theorem : f_n - sum [f_0, f_1 .. f_(n - 2)] = 1 for all n > 1

  Proof :
         base case : n = 2
         induction step : Assume true for n = k. Hence
          f_k - sum [f_0, f_1 .. f_(k -2)] = 1
         when n = k + 1
         we have f_(k + 1) - sum [f_0, f_1 .. f_(k - 2), f_(k - 1)]
          = (f_k + f_(k - 1) - sum [ f_0, .. f_(k - 2)] - f_(k - 1))
          = 1

  Intution
     f2 = 1 + f_0
     f3 = 1 + f_0 + f_1
     f4 = 1 + f_0 + f_1 + f_2
     ...

f fibs = ((modify cum >> put (1:fibs)) >> return fibs)
  =>
  RState $ \s2 -> let (a, s0) = ((), cum s1)
                      (b, s1) = ((), 1:fibs)
                  in (b, s0)

=> RState $ \s -> ((), cum (1:fibs)) >> return fibs
=> RState $ \s2 -> let (a, s0) = ((), cum (1:fibs))
                       (b, s1) = (fibs, s2)
                   in (b, s0)
=> RState $ \s -> (fibs, cum $ 1:fibs)

-}