Project Euler Problem 073

import Control.Monad
import Control.Applicative
import Control.Arrow
import Data.Ord
import Data.Char
import qualified Data.Map as M
import Data.List
import Data.Array
import Data.Maybe
import Data.Ratio
import Debug.Trace

primes :: [Integer]
primes = 2:f [3] [3,5..] where
  f (x:xs) ys = ps ++ f (xs++ps) [z | z<-qs,z`rem`x/=0] where
    (ps,qs) = span (< x*x) ys
factor :: Integer -> [Integer]
factor nn = factorimpl nn primes where
  factorimpl n pri@(p:xs) =
    if p*p>n then [n]
    else if n`rem` p == 0 then
      p:factorimpl (n `quot` p) pri
         else
           factorimpl n xs

tot 0 = 0
tot 1 = 1
tot n = foldl' (\a l@(x:xs) -> a*(x^(length l) - x^(length l-1))) 1 $ group $ factor n
fn n = -1 + (sum $ map tot [1..n])
dlength = fn 12000
-- ファレイ数列
far n = imp [(0,1),(1,1)] where
  imp ((x,y):l@((a,b):_)) =
    case y+b of
      v | v>n -> (x,y):imp l
      _ -> imp $ (x,y):(x+a,y+b):l
  imp l = l
ans = length $ takeWhile (<(1%2)) $ dropWhile(<=(1%3)) $ map (\(l,r)->l%r) $ far 12000
-- 7295372
main = print $ ans