project euler #2

pe2.hs

-- http://projecteuler.net/index.php?section=problems&id=2
--
-- Each new term in the Fibonacci sequence is generated by adding the previous
-- two terms. By starting with 1 and 2, the first 10 terms will be:
--
-- 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
--
-- Find the sum of all the even-valued terms in the sequence which do not
-- exceed four million.

import Criterion.Main (bench, defaultMain, whnf)

main :: IO ()
main = do
    print $ answer0   m
    print $ answer1   m
    print $ answer1'  m
    print $ answer2   m
    print $ answer2'  m
    print $ answer2'' m

    defaultMain $ drop 4 $
      [ bench "answer0"   (whnf answer0   m)
      , bench "answer1"   (whnf answer1   m)
      , bench "answer1'"  (whnf answer1'  m)
      , bench "answer2"   (whnf answer2   m)
      , bench "answer2'"  (whnf answer2'  m)
      , bench "answer2''" (whnf answer2'' m)
      ]
  where
    -- m = 10^(100 :: Integer)
    m = 4 * 10^(20 :: Integer)

-- reference solution
answer0 :: Integer -> Integer
answer0 m =
    sum . filter even . takeWhile (< m) $ fibs
  where
    fibs = 1 : 2 : zipWith (+) fibs (tail fibs)

-- don't use lists
answer1 :: Integer -> Integer
answer1 m =
    calc 1 2 0
  where
    calc p0 p1 acc =
        if p1 > m
          then acc
          else let n = p0 + p1
               in if even p1
                    then calc p1 n (acc + p1)
                    else calc p1 n acc

-- answer1 with seq
answer1' :: Integer -> Integer
answer1' m =
    calc 1 2 0
  where
    calc p0 p1 acc =
        if p1 > m
          then acc
          else let n = p0 + p1
               in seq n (if even p1
                           then let acc' = (acc + p1)
                                in seq acc' (calc p1 n acc')
                           else calc p1 n acc
                        )

-- don't test for evenness; evens fall in a regular pattern:
-- Prelude> let fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
-- Prelude> concatMap (\e -> if even e then "x" else ".") . takeWhile (< 4000000) $ fibs
-- "x..x..x..x..x..x..x..x..x..x..x..x"
answer2 :: Integer -> Integer
answer2 m =
    calc0 0 1 0
  where
    calc0 p q acc
        | q >= m    = acc
        | otherwise = calc1 q (p + q) (acc + p)

    calc1 p q acc
        | q >= m    = acc
        | otherwise = calc2 q (p + q) acc

    calc2 p q acc
        | q >= m    = acc
        | otherwise = calc0 q (p + q) acc

-- answer2' with fewer calls
answer2' :: Integer -> Integer
answer2' m =
    calc0 0 1 0
  where
    calc0 p q acc
        | q >= m    = acc
        | otherwise = calc1 q (p + q) (acc + p)

    calc1 p q acc =
        if q >= m
          then acc
          else let p' = q
                   q' = p + q
               in if q' >= m
                    then acc
                    else calc0 q' (p' + q') acc

-- answer2' with seq
answer2'' :: Integer -> Integer
answer2'' m =
    calc0 0 1 0
  where
    calc0 p q acc
        | q >= m    = acc
        | otherwise = let n    = p + q
                          acc' = acc + p
                      in seq n    $
                         seq acc' $
                         calc1 q n acc'

    calc1 p q acc =
        if q >= m
          then acc
          else let q' = p + q
               in seq q' $
                  if q' >= m
                    then acc
                    else let n = q + q'
                         in seq n $
                            calc0 q' n acc