FibonacciStack.hs

{-# LANGUAGE TemplateHaskell #-}
module Data.Integer.FibonacciStack where

import Control.Monad.State
import Control.Lens

naiveFib :: Int -> Integer
naiveFib 0 = 0
naiveFib 1 = 1
naiveFib n = naiveFib (n-1) + naiveFib (n-2)

data FibInstruction = Fib Int

data FibState = FibState
  { _instructions :: [FibInstruction]
  , _accumulator :: Integer
  }

makeLenses ''FibState

startState :: Int -> FibState
startState i =
  FibState { _instructions = [Fib i]
           , _accumulator = 0
           }

type FibonacciStack = State FibState

push :: FibInstruction -> FibonacciStack ()
push inst = instructions %= (inst:)

runStack :: FibonacciStack Integer
runStack = do
  stack <- use instructions
  value <- use accumulator
  case stack of
    [] -> return value  -- stack.empty?
    x:xs -> do          -- pop
      instructions .= xs
      case x of
        Fib 0 -> accumulator .= value + 0
        Fib 1 -> accumulator .= value + 1
        Fib n -> push (Fib (n-1)) >> push (Fib (n-2))
      runStack

fibStack :: Int -> Integer
fibStack i = evalState runStack (startState i)

FibonacciStackSpec.hs

module Data.Integer.FibonacciStackSpec (main, spec) where

import Test.Hspec
import Test.QuickCheck

import Data.Integer.FibonacciStack

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  describe "naiveFib" $
    it "returns as expected for small n" $ do
      naiveFib 0 `shouldBe` 0
      naiveFib 1 `shouldBe` 1
      naiveFib 2 `shouldBe` 1
      naiveFib 3 `shouldBe` 2
      naiveFib 4 `shouldBe` 3
      naiveFib 5 `shouldBe` 5
      naiveFib 6 `shouldBe` 8
  describe "fibStack" $ do
    it "returns the same as naiveFib" $ property $
      \i -> i >= 0 && i < 20 ==> fibStack i === naiveFib i