{-# LANGUAGE
BangPatterns, PatternSynonyms, KindSignatures, DataKinds,
FlexibleInstances, TypeSynonymInstances
#-}
module Math.Singular.Factory.Domains where
import Data.Ratio
import GHC.TypeLits
import Data.Proxy
import Data.IORef
import Control.Monad
import System.IO.Unsafe as Unsafe
import Math.Singular.Factory.Internal.CanonicalForm
import Math.Singular.Factory.Internal.Factory hiding ( FF , GF )
type Prime = Int
data FactoryChar
= CharZero
| CharFp !Prime
| CharGF !Prime !Int
deriving (Eq,Show)
theFactoryChar :: IORef FactoryChar
theFactoryChar = Unsafe.unsafePerformIO $ newIORef CharZero
setFactoryChar :: FactoryChar -> IO ()
setFactoryChar new = do
old <- readIORef theFactoryChar
when (new /= old) $ do
writeIORef theFactoryChar new
case new of
CharZero -> setCharacteristic1 0
CharFp p -> setCharacteristic1 p
CharGF p n -> setCharacteristic3 p n '@'
mapIntoCF :: FactoryChar -> CF -> CF
mapIntoCF char cf = Unsafe.unsafePerformIO $ do
setFactoryChar char
mapIntoIO cf
newtype Fp (p :: Nat)
= Fp Int
deriving (Eq)
fpPrime :: KnownNat p => Fp p -> Int
fpPrime = fromIntegral . natVal . proxyP where
proxyP :: Fp p -> Proxy p
proxyP _ = Proxy
modp :: (KnownNat p, Integral a) => a -> Fp p
modp k = fp where
fp = Fp $ mod (fromIntegral k) (fpPrime fp)
instance Show (Fp p) where
show (Fp k) = show k
instance KnownNat p => Num (Fp p) where
fromInteger = modp
negate fp@(Fp k) = if k==0 then Fp 0 else Fp (fpPrime fp - k)
(Fp a) + (Fp b) = modp (a+b)
(Fp a) - (Fp b) = modp (a-b)
(Fp a) * (Fp b) = modp (a*b)
abs = id
signum = const (Fp 1)
fpToFF :: KnownNat p => Fp p -> FF p
fpToFF (Fp k) = mkFF k
newtype FF (p :: Nat)
= FF { unFF :: CF }
mkFF :: (KnownNat p, Integral a) => a -> FF p
mkFF !k = ff where
ff = Unsafe.unsafePerformIO $ do
setBaseDomain (mkProxy ff)
cf <- (mapIntoIO =<< makeIntegerCF (fromIntegral k))
return (FF cf)
instance Eq (FF p) where
(FF a) == (FF b) = nativeEqCF a b
instance Show (FF p) where
show (FF cf) = show (valueFF cf)
ffPrime :: KnownNat p => FF p -> Int
ffPrime = fromIntegral . natVal . proxyP where
proxyP :: FF p -> Proxy p
proxyP _ = Proxy
instance KnownNat p => Num (FF p) where
fromInteger = mkFF
negate (FF a) = FF (negate a)
(FF a) + (FF b) = FF (a + b)
(FF a) - (FF b) = FF (a - b)
(FF a) * (FF b) = FF (a * b)
abs = id
signum = const 1
instance (KnownNat p) => Fractional (FF p) where
fromRational q = mkFF (numerator q) / mkFF (denominator q)
(FF a) / (FF b) = FF (divCF a b)
newtype GF (p :: Nat) (n :: Nat) (x :: Symbol)
= GF { unGF :: CF }
mkGF :: (KnownNat p, KnownNat n, KnownSymbol x, Integral a) => a -> GF p n x
mkGF !k = gf where
gf = Unsafe.unsafePerformIO $ do
setBaseDomain (mkProxy gf)
cf <- (mapIntoIO =<< makeIntegerCF (fromIntegral k))
return (GF cf)
genGF :: (KnownNat p, KnownNat n, KnownSymbol x) => GF p n x
genGF = gf where
gf = Unsafe.unsafePerformIO $ do
setBaseDomain (mkProxy gf)
cf <- getGFGenerator
return (GF cf)
genPowGF :: (KnownNat p, KnownNat n, KnownSymbol x) => Int -> GF p n x
genPowGF e = powGF genGF e
powGF :: (KnownNat p, KnownNat n, KnownSymbol x) => GF p n x -> Int -> GF p n x
powGF (GF cf) e = GF (powCF cf e)
instance Eq (GF p n x) where
(GF a) == (GF b) = nativeEqCF a b
instance (KnownNat p, KnownNat n, KnownSymbol x) => Show (GF p n x) where
show gf@(GF cf) = showGFValue1 (gfSymbol gf) (valueGF cf)
instance (KnownNat p, KnownNat n, KnownSymbol x) => Num (GF p n x) where
fromInteger = mkGF
negate (GF a) = GF (negate a)
(GF a) + (GF b) = GF (a + b)
(GF a) - (GF b) = GF (a - b)
(GF a) * (GF b) = GF (a * b)
abs = id
signum = const 1
instance (KnownNat p, KnownNat n, KnownSymbol x) => Fractional (GF p n x) where
fromRational q = mkGF (numerator q) / mkGF (denominator q)
(GF a) / (GF b) = GF (divCF a b)
gfPrime :: KnownNat p => GF p n x -> Int
gfPrime = fromIntegral . natVal . proxyP where
proxyP :: GF p n x -> Proxy p
proxyP _ = Proxy
gfExponent :: KnownNat n => GF p n x -> Int
gfExponent = fromIntegral . natVal . proxyE where
proxyE :: GF p n x -> Proxy n
proxyE _ = Proxy
gfSymbol :: KnownSymbol x => GF p n x -> String
gfSymbol = symbolVal . proxyX where
proxyX :: GF p n x -> Proxy x
proxyX _ = Proxy
class (Eq a, Show a, Num a) => BaseDomain a where
characteristic :: Proxy a -> Int
charExponent :: Proxy a -> Int
baseDomainName :: Proxy a -> String
factoryChar :: Proxy a -> FactoryChar
baseToCF :: a -> CF
unsafeCfToBase :: CF -> a
isZero :: a -> Bool
isOne :: a -> Bool
setBaseDomain :: BaseDomain a => Proxy a -> IO ()
setBaseDomain = setFactoryChar . factoryChar
instance BaseDomain Integer where
characteristic _ = 0
charExponent _ = 1
baseDomainName _ = "ZZ"
factoryChar _ = CharZero
baseToCF x = Unsafe.unsafePerformIO (makeIntegerCF x)
unsafeCfToBase = valueZZ
isZero n = (n == 0)
isOne n = (n == 1)
instance BaseDomain Rational where
characteristic _ = 0
charExponent _ = 1
baseDomainName _ = "QQ"
factoryChar _ = CharZero
baseToCF x = Unsafe.unsafePerformIO (makeRationalCF x)
unsafeCfToBase = valueQQ
isZero q = (q == 0)
isOne q = (q == 1)
instance KnownNat p => BaseDomain (Fp p) where
characteristic pxy = (fpPrime $ proxyUndef pxy)
charExponent _ = 1
baseDomainName pxy = "F_" ++ show (characteristic pxy)
factoryChar pxy = CharFp (characteristic pxy)
baseToCF x = baseToCF (fpToFF x)
unsafeCfToBase cf = Fp (valueFF cf)
isZero (Fp k) = (k == 0)
isOne (Fp k) = (k == 1)
instance KnownNat p => BaseDomain (FF p) where
characteristic pxy = (ffPrime $ proxyUndef pxy)
charExponent pxy = 1
baseDomainName pxy = "FF(" ++ show (characteristic pxy) ++ ")" where
factoryChar pxy = CharFp (characteristic pxy)
baseToCF (FF cf) = cf
unsafeCfToBase = FF
isZero (FF cf) = isZeroCF cf
isOne (FF cf) = isOneCF cf
instance (KnownNat p, KnownNat n, KnownSymbol x) => BaseDomain (GF p n x) where
characteristic pxy = (gfPrime $ proxyUndef pxy)
charExponent pxy = (gfExponent $ proxyUndef pxy)
baseDomainName pxy = "GF(" ++ show (characteristic pxy) ++ ")" where
factoryChar pxy = CharGF (characteristic pxy) (charExponent pxy)
baseToCF (GF cf) = cf
unsafeCfToBase = GF
isZero (GF cf) = isZeroCF cf
isOne (GF cf) = isOneCF cf
class BaseDomain domain => FiniteDomain domain where
domainSize :: Proxy domain -> Int
enumerateDomain :: [domain]
instance KnownNat p => FiniteDomain (Fp p) where
domainSize pxy = characteristic pxy
enumerateDomain = list where
list = [ Fp i | i<-[0..p-1] ]
p = characteristic $ mkProxy (head list)
instance KnownNat p => FiniteDomain (FF p) where
domainSize pxy = characteristic pxy
enumerateDomain = list where
list = [ mkFF i | i<-[0..p-1] ]
p = characteristic $ mkProxy (head list)
instance (KnownNat p, KnownNat n, KnownSymbol x) => FiniteDomain (GF p n x) where
domainSize pxy = characteristic pxy ^ charExponent pxy
enumerateDomain = list where
list = 0 : [ genPowGF i | i<-[0..n-2] ] where
pxy = mkProxy (head list)
n = domainSize pxy
mkProxy :: a -> Proxy a
mkProxy _ = Proxy
proxyUndef :: Proxy a -> a
proxyUndef _ = undefined