{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Semimodule where
import safe Data.Bool
import safe Data.Complex
import safe Data.Semifield
import safe Data.Fixed
import safe Data.Functor.Compose
import safe Data.Functor.Rep
import safe Data.Int
import safe Data.Semiring
import safe Data.Semigroup.Foldable as Foldable1
import safe Data.Tuple
import safe Data.Word
import safe GHC.Real hiding (Fractional(..))
import safe Numeric.Natural
import safe Foreign.C.Types (CFloat(..),CDouble(..))
import safe Prelude hiding (Num(..), Fractional(..), sum, product)
import safe qualified Prelude as N
import safe Data.Semigroup.Additive as A
import safe Data.Semigroup.Multiplicative as M
import safe Prelude (fromInteger)
type Free f = (Representable f, Eq (Rep f))
type Basis b f = (Free f, Rep f ~ b)
type Module r a = (Ring r, Group a, Semimodule r a)
infixl 7 .*, *.
class (Semiring r, Semigroup a) => Semimodule r a where
(*.) :: r -> a -> a
(*.) = flip (.*)
(.*) :: a -> r -> a
(.*) = flip (*.)
multl :: Semiring a => Functor f => a -> f a -> f a
multl a f = (a *) <$> f
multr :: Semiring a => Functor f => f a -> a -> f a
multr f a = (* a) <$> f
negateDef :: Semimodule Integer a => a -> a
negateDef a = (-1 :: Integer) *. a
lerp :: Module r a => r -> a -> a -> a
lerp r f g = r *. f <> (one - r) *. g
{-# INLINE lerp #-}
infix 6 .*.
(.*.) :: Free f => Foldable f => Semiring a => f a -> f a -> a
(.*.) x y = sum $ liftR2 (*) x y
{-# INLINE (.*.) #-}
quadrance :: Free f => Foldable f => Semiring a => f a -> a
quadrance f = f .*. f
{-# INLINE quadrance #-}
qd :: Free f => Foldable f => Module a (f a) => f a -> f a -> a
qd f g = quadrance $ f << g
{-# INLINE qd #-}
dirac :: Eq i => Semiring a => i -> i -> a
dirac i j = bool zero one (i == j)
{-# INLINE dirac #-}
idx :: Free f => Semiring a => Rep f -> f a
idx i = tabulate $ dirac i
{-# INLINE idx #-}
instance Semiring r => Semimodule r () where
_ *. _ = ()
instance Semigroup a => Semimodule () a where
_ *. a = a
instance Monoid a => Semimodule Natural a where
(*.) = mreplicate
instance Group a => Semimodule Integer a where
(*.) = greplicate
instance Semimodule r a => Semimodule r (e -> a) where
a *. f = (a *.) <$> f
instance (Semimodule r a, Semimodule r b) => Semimodule r (a, b) where
n *. (a, b) = (n *. a, n *. b)
instance (Semimodule r a, Semimodule r b, Semimodule r c) => Semimodule r (a, b, c) where
n *. (a, b, c) = (n *. a, n *. b, n *. c)
instance (Semiring a, Semimodule r a) => Semimodule r (Additive (Ratio a)) where
a *. (Additive (x :% y)) = Additive $ (a *. x) :% y
instance (Ring a, Semimodule r a) => Semimodule r (Additive (Complex a)) where
a *. (Additive (x :+ y)) = Additive $ (a *. x) :+ (a *. y)
#define deriveSemimodule(ty) \
instance Semiring ty => Semimodule ty (Additive ty) where { \
r *. (Additive a) = Additive $ r * a \
; {-# INLINE (*.) #-} \
}
deriveSemimodule(Bool)
deriveSemimodule(Int)
deriveSemimodule(Int8)
deriveSemimodule(Int16)
deriveSemimodule(Int32)
deriveSemimodule(Int64)
deriveSemimodule(Word)
deriveSemimodule(Word8)
deriveSemimodule(Word16)
deriveSemimodule(Word32)
deriveSemimodule(Word64)
deriveSemimodule(Uni)
deriveSemimodule(Deci)
deriveSemimodule(Centi)
deriveSemimodule(Milli)
deriveSemimodule(Micro)
deriveSemimodule(Nano)
deriveSemimodule(Pico)
deriveSemimodule(Float)
deriveSemimodule(Double)
deriveSemimodule(CFloat)
deriveSemimodule(CDouble)