{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Numeric.Monoid.Multiplicative.Internal
  ( Unital(..)
  , product
  , FreeUnitalAlgebra(..)
  ) where

import Data.Foldable hiding (product)
import Data.Int
import Data.Word
import Prelude hiding ((*), foldr, product)
import Numeric.Semiring.Internal
import Numeric.Natural.Internal

infixr 8 `pow`

class Multiplicative r => Unital r where
  one :: r
  pow :: Whole n => r -> n -> r
  pow _ 0 = one
  pow x0 y0 = f x0 y0 where
    f x y 
      | even y = f (x * x) (y `quot` 2)
      | y == 1 = x
      | otherwise = g (x * x) ((y - 1) `quot` 2) x
    g x y z 
      | even y = g (x * x) (y `quot` 2) z
      | y == 1 = x * z
      | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z)
  productWith :: Foldable f => (a -> r) -> f a -> r
  productWith f = foldl' (\b a -> b * f a) one

product :: (Foldable f, Unital r) => f r -> r
product = productWith id

instance Unital Bool where one = True
instance Unital Integer where one = 1
instance Unital Int where one = 1
instance Unital Int8 where one = 1
instance Unital Int16 where one = 1
instance Unital Int32 where one = 1
instance Unital Int64 where one = 1
instance Unital Natural where one = 1
instance Unital Word where one = 1
instance Unital Word8 where one = 1
instance Unital Word16 where one = 1
instance Unital Word32 where one = 1
instance Unital Word64 where one = 1
instance Unital () where one = ()
instance (Unital a, Unital b) => Unital (a,b) where
  one = (one,one)

instance (Unital a, Unital b, Unital c) => Unital (a,b,c) where
  one = (one,one,one)

instance (Unital a, Unital b, Unital c, Unital d) => Unital (a,b,c,d) where
  one = (one,one,one,one)

instance (Unital a, Unital b, Unital c, Unital d, Unital e) => Unital (a,b,c,d,e) where
  one = (one,one,one,one,one)

-- | An associative unital algebra over a semiring, built using a free module
class (Unital r, FreeAlgebra r a) => FreeUnitalAlgebra r a where
  unit :: r -> a -> r

instance (FreeUnitalAlgebra r a) => Unital (a -> r) where
  one = unit one

instance FreeUnitalAlgebra () a where
  unit _ _ = ()

instance (FreeUnitalAlgebra r a, FreeUnitalAlgebra r b) => FreeUnitalAlgebra (a -> r) b where
  unit f b a = unit (f a) b

instance (FreeUnitalAlgebra r a, FreeUnitalAlgebra r b) => FreeUnitalAlgebra r (a,b) where
  unit r (a,b) = unit r a * unit r b

instance (FreeUnitalAlgebra r a, FreeUnitalAlgebra r b, FreeUnitalAlgebra r c) => FreeUnitalAlgebra r (a,b,c) where
  unit r (a,b,c) = unit r a * unit r b * unit r c

instance (FreeUnitalAlgebra r a, FreeUnitalAlgebra r b, FreeUnitalAlgebra r c, FreeUnitalAlgebra r d) => FreeUnitalAlgebra r (a,b,c,d) where
  unit r (a,b,c,d) = unit r a * unit r b * unit r c * unit r d

instance (FreeUnitalAlgebra r a, FreeUnitalAlgebra r b, FreeUnitalAlgebra r c, FreeUnitalAlgebra r d, FreeUnitalAlgebra r e) => FreeUnitalAlgebra r (a,b,c,d,e) where
  unit r (a,b,c,d,e) = unit r a * unit r b * unit r c * unit r d * unit r e