{-# LANGUAGE BangPatterns, ScopedTypeVariables, FlexibleContexts, StandaloneDeriving #-}

module Euler
  ( Digit
  , Decimal
  , integerPart
  , prefixDigits
  , repeatingDigits
  , whenM
  , unlessM
  , primesTo
  , isPrimeArray
  , primes
  , zipArraysWith
  , RangeIx(..)
  , divisors
  , properDivisors
  , toDecimal
  , fromDecimal
  , toDigits
  , toDigitsBase
  , fromDigits
  , fromDigitsBase
  , isPalindrome
  , module Control.Applicative
  , module Control.Arrow
  , module Control.Monad
  , module Data.Function
  , module Data.List
  , module Data.Ratio
  , module Data.Tuple
  , module Data.Word
  ) where

import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.ST
import Control.Monad.Writer
import Data.Array.ST
import Data.Array.Unboxed
import Data.Function
import Data.List
import Data.Ratio
import Data.Tuple
import Data.Word

import qualified Control.Monad.ST.Lazy as LST

type Digit   = Word8
data Decimal = Decimal { integerPart     :: Integer
                       , prefixDigits    :: [Digit]
                       , repeatingDigits :: [Digit]
                       }

whenM, unlessM :: Monad m => m Bool -> m () -> m ()
whenM   mc m = mc >>= (\c -> when   c m)
unlessM mc m = mc >>= (\c -> unless c m)

primesTo n = LST.runST $ do
   isPrime <- LST.strictToLazyST (newArray (2, n) 1 :: ST s (STUArray s Integer Word8))
   let primesFrom m = if m > n then return [] else do
         p <- LST.strictToLazyST (readArray isPrime m)
         if p == 0 then primesFrom (m+1) else do
            LST.strictToLazyST $ forM_ [2*m,3*m..n] $ \i -> writeArray isPrime i 0
            (m:) <$> primesFrom (m+1)
   primesFrom 2

isPrimeArray n = runSTUArray $ do
   isPrime <- newArray (2, n) 1 :: ST s (STUArray s Integer Word8)
   forM_ [2..n] $ \m -> whenM ((/= 0) <$> readArray isPrime m) $ do
      forM_ [2*m,3*m..n] $ \i -> writeArray isPrime i 0
   return isPrime

primes :: [Integer]
primes = let go (!p:xs) = p : go [ x | x <- xs, x `mod` p /= 0 ] in go [2..]

class Ix a => RangeIx a where
   intersectBounds :: (a, a) -> (a, a) -> (a, a)

instance RangeIx Int where
   intersectBounds (al, au) (bl, bu) = (max al bl, min au bu)

instance (RangeIx a, RangeIx b) => RangeIx (a, b) where
   intersectBounds ((al,bl),(au,bu)) ((cl,dl),(cu,du)) =
      ((max al cl, max bl dl), (min au cu, min bu du))

zipArraysWith :: (IArray arrA a, IArray arrB b, IArray arrC c, RangeIx i)
              => (a -> b -> c) -> arrA i a -> arrB i b -> arrC i c
zipArraysWith f as bs = array newRange $ [ (i, f (as!i) (bs!i)) | i <- range newRange ]
   where newRange = intersectBounds (bounds as) (bounds bs)

divisors :: Integral a => a -> [a]
divisors n = nub $ concat [ [m, q] | m <- takeWhile (\x -> x^2 <= n) [1..], let (q, r) = n `divMod` m, r == 0 ]

properDivisors :: Integral a => a -> [a]
properDivisors n | n < 1 = []
properDivisors n = nub $ 1 : concat [ [m, q] | m <- takeWhile (\x -> x^2 <= n) [2..], let (q, r) = n `divMod` m, r == 0 ]

toDecimal :: Rational -> Decimal
toDecimal rat = Decimal q ps rs
   where
      (n,  m)  = (numerator rat, denominator rat)
      (q,  r)  = n `divMod` m
      (ps, rs) = toDecimal' r m

toDecimal' :: Integer -> Integer -> ([Digit], [Digit])
toDecimal' n m = first (map fst) $ second (map fst) $ collect [] xs
   where
      xs = [ first fromInteger ((10*x) `divMod` m)
           | x <- takeWhile (/= 0) $ (n:) $ map snd xs ]
      collect ps []     = (ps, [])
      collect ps (x:xs) = if x `elem` ps then break (== x) ps else collect (ps ++ [x]) xs

fromDecimal :: Decimal -> Rational
fromDecimal (Decimal n ps rs) = (n % 1) + (p + r) * (1 % 10 ^ length ps)
   where (p, r) = (fromDigits ps % 1, fromDigits rs % (10 ^ length rs - 1))

deriving instance Eq Decimal
deriving instance Ord Decimal

instance Show Decimal where
   show (Decimal n ps rs)
      | null (ps ++ rs) = show n
      | null rs         = show n ++ "." ++ concat (map show ps)
      | otherwise       = show n ++ "." ++ concat (map show ps)
                                 ++ "(" ++ concat (map show rs) ++ ")"

toDigits :: (Integral a, Integral b) => a -> [b]
toDigits = toDigitsBase 10

toDigitsBase :: (Integral a, Integral b) => a -> a -> [b]
toDigitsBase n = reverse . unfoldr (\x ->
   if x == 0 then Nothing else Just (first fromIntegral $ swap (x `divMod` n)))

fromDigits :: (Integral a, Integral b) => [a] -> b
fromDigits = fromDigitsBase 10

fromDigitsBase :: (Integral a, Integral b) => b -> [a] -> b
fromDigitsBase n = foldl' (\a b -> n * a + fromIntegral b) 0

isPalindrome :: Eq a => [a] -> Bool
isPalindrome xs = xs == reverse xs