module SubHask.Category.Finite
(
SparseFunction
, proveSparseFunction
, list2sparseFunction
, SparseFunctionMonoid
, DenseFunction
, proveDenseFunction
, FiniteType (..)
, ZIndex
)
where
import Control.Monad
import GHC.Prim
import GHC.TypeLits
import Data.Proxy
import qualified Data.Map as Map
import qualified Data.Vector.Unboxed as VU
import qualified Prelude as P
import SubHask.Algebra
import SubHask.Algebra.Group
import SubHask.Category
import SubHask.Internal.Prelude
import SubHask.SubType
import SubHask.TemplateHaskell.Deriving
class KnownNat (Order a) => FiniteType a where
type Order a :: Nat
index :: a -> ZIndex a
deZIndex :: ZIndex a -> a
enumerate :: [a]
getOrder :: a -> Integer
instance KnownNat n => FiniteType (Z n) where
type Order (Z n) = n
index i = ZIndex i
deZIndex (ZIndex i) = i
enumerate = [ mkQuotient i | i <- [0..n 1] ]
where
n = natVal (Proxy :: Proxy n)
getOrder z = natVal (Proxy :: Proxy n)
newtype ZIndex a = ZIndex (Z (Order a))
deriveHierarchy ''ZIndex [ ''Eq_, ''P.Ord ]
swapZIndex :: Order a ~ Order b => ZIndex a -> ZIndex b
swapZIndex (ZIndex i) = ZIndex i
data SparseFunction a b where
SparseFunction ::
( FiniteType a
, FiniteType b
, Order a ~ Order b
) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunction a b
instance Category SparseFunction where
type ValidCategory SparseFunction a =
( FiniteType a
)
id = SparseFunction $ Map.empty
(SparseFunction f1).(SparseFunction f2) = SparseFunction
(Map.map (\a -> find a f1) f2)
where
find k map = case Map.lookup k map of
Just v -> v
Nothing -> swapZIndex k
proveSparseFunction ::
( ValidCategory SparseFunction a
, ValidCategory SparseFunction b
, Order a ~ Order b
) => (a -> b) -> SparseFunction a b
proveSparseFunction f = SparseFunction
$ Map.fromList
$ P.map (\a -> (index a,index $ f a)) enumerate
list2sparseFunction ::
( ValidCategory SparseFunction a
, ValidCategory SparseFunction b
, Order a ~ Order b
) => [Z (Order a)] -> SparseFunction a b
list2sparseFunction xs = SparseFunction $ Map.fromList $ go xs
where
go (y:[]) = [(ZIndex y, ZIndex $ P.head xs)]
go (y1:y2:ys) = (ZIndex y1,ZIndex y2):go (y2:ys)
data SparseFunctionMonoid a b where
SparseFunctionMonoid ::
( FiniteType a
, FiniteType b
, Monoid a
, Monoid b
, Order a ~ Order b
) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunctionMonoid a b
instance Category SparseFunctionMonoid where
type ValidCategory SparseFunctionMonoid a =
( FiniteType a
, Monoid a
)
id :: forall a. ValidCategory SparseFunctionMonoid a => SparseFunctionMonoid a a
id = SparseFunctionMonoid $ Map.fromList $ P.zip xs xs
where
xs = P.map index (enumerate :: [a])
(SparseFunctionMonoid f1).(SparseFunctionMonoid f2) = SparseFunctionMonoid
(Map.map (\a -> find a f1) f2)
where
find k map = case Map.lookup k map of
Just v -> v
Nothing -> index zero
data DenseFunction (a :: *) (b :: *) where
DenseFunction ::
( FiniteType a
, FiniteType b
) => VU.Vector Int -> DenseFunction a b
instance Category DenseFunction where
type ValidCategory DenseFunction (a :: *) =
( FiniteType a
)
id :: forall a. ValidCategory DenseFunction a => DenseFunction a a
id = DenseFunction $ VU.generate n id
where
n = fromIntegral $ natVal (Proxy :: Proxy (Order a))
(DenseFunction f).(DenseFunction g) = DenseFunction $ VU.map (f VU.!) g
proveDenseFunction :: forall a b.
( ValidCategory DenseFunction a
, ValidCategory DenseFunction b
) => (a -> b) -> DenseFunction a b
proveDenseFunction f = DenseFunction $ VU.generate n (index2int . index . f . deZIndex . int2index)
where
n = fromIntegral $ natVal (Proxy :: Proxy (Order a))
int2index :: Int -> ZIndex a
int2index i = ZIndex $ Mod $ fromIntegral i
index2int :: ZIndex a -> Int
index2int (ZIndex (Mod i)) = fromIntegral i