Classes.hs

{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,
             MultiParamTypeClasses, FunctionalDependencies, 
             TypeFamilies, DataKinds, GeneralizedNewtypeDeriving
  #-}
module Math.RootLoci.Motivic.Classes where

--------------------------------------------------------------------------------

import Data.Char
import Data.List
import Data.Ord
import Data.Maybe

import GHC.TypeLits

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

import qualified Math.Algebra.Polynomial.FreeModule as ZMod 
import Math.Algebra.Polynomial.FreeModule (ZMod,QMod,FreeMod)
import Math.Algebra.Polynomial.Pretty

import Math.Combinat.Classes hiding (empty)
import Math.Combinat.Tuples
import Math.Combinat.Partitions
import Math.Combinat.Permutations hiding (permute)

import Math.Algebra.Polynomial.Class
import Math.Algebra.Polynomial.Monomial.Indexed 

import Math.RootLoci.Misc.Common

--------------------------------------------------------------------------------
-- * Dimensions

-- | A dimension (@d@ in @Sym^d(X)@)
newtype Dim 
  = Dim Int
  deriving (Eq,Ord,Show,Num)

unDim :: Dim -> Int
unDim (Dim d) = d

dimVector :: Partition -> [Dim]
dimVector = map Dim . exponentVector

dimTuples :: [Dim] -> [[Dim]]
dimTuples  
  = (map . map) Dim
  . tuples'
  . map unDim 

--------------------------------------------------------------------------------
-- * Classes

-- | Degree of something
class Degree a where
  type MultiDegree a :: *
  totalDegree :: a -> Int
  multiDegree :: a -> MultiDegree a

instance (KnownNat n) => Degree (XS v n) where
  type MultiDegree (XS v n) = [Int]
  totalDegree = totalDegXS
  multiDegree = xsToExponents

--------------------------------------------------------------------------------

class Empty a where
  empty :: a

instance Empty [a] where
  empty = []

instance Empty (Maybe a) where
  empty = Nothing

instance Empty Int where
  empty = 0

instance KnownNat n => Empty (XS v n) where
  empty = emptyXS

--------------------------------------------------------------------------------

-- | Normalize terms and lambdas
class Normalize a where
  normalize :: a -> a

-- | This is a hack because there is some issue when this is included in normalize that i don't want to debug right now
class SuperNormalize a where
  superNormalize :: a -> a 
  
--------------------------------------------------------------------------------

-- | Exterior (or cross) product
class Cross a where
  cross :: a -> a -> a
  crossMany :: [a] -> a
  crossMany = foldl1' cross
  crossInterleave :: a -> a -> a       -- ^ interleaved cross product of vectors

instance Cross [a] where
  cross     = (++)
  crossMany = concat 
  crossInterleave xs ys = interleave xs ys

-------------------------------------------------------------------------------

-- | Conversion from scalar to vector
class SingleToMulti s t | s->t, t->s where
  singleToMulti :: s -> t

--------------------------------------------------------------------------------

omegaZeroError :: a
omegaZeroError = error "Omega^0 should not appear in the algorithm"

-- | replicating points (power map)
class Omega a where
  omega :: Int -> a -> a

--------------------------------------------------------------------------------

-- | @Omega^{1,2,3,...}@
class Omega123 a where
  omega123 :: a -> a

--------------------------------------------------------------------------------

-- | The merging (or multiplication) map
class Psi t s | t->s where
  psi :: t -> s

--------------------------------------------------------------------------------

-- | The interleaved pairwise merging map
class PsiEvenOdd t where
  psiEvenOdd :: t -> t

--------------------------------------------------------------------------------

-- | Pontrjagin ring
class Pontrjagin a where
  pontrjaginOne :: a 
  pontrjaginMul :: a -> a -> a

--------------------------------------------------------------------------------

class ExtendToCommonSize a where
  extendToCommonSize :: (a,a) -> (a,a)

instance Empty a => ExtendToCommonSize [a] where
  extendToCommonSize (xs,ys) = (xs',ys') where
    a = length xs
    b = length ys
    n = max a b
    xs' = xs ++ replicate (n-a) empty
    ys' = ys ++ replicate (n-b) empty

--------------------------------------------------------------------------------

-- | Applying permutations
class Permute a where
  permute :: Permutation -> a -> a

instance Permute [a] where
  permute = permuteList

--------------------------------------------------------------------------------

-- | The custom pusforward @Theta@ appearing in the algorithm
--
-- we subdivide the input as @[z;x1,y1,x2,y2,x3,y3...]@
-- and then duplicate each of @y1,y2,y3...@, then combine the left copies of @y_i@ with
-- @z@, and the right copies of @y_i@ with the corresponding @x_i@-s, resulting in
-- @[z*y1*y2*...;x1*y1,x2*y2,...]@
class Theta a where
  theta :: a -> a       --mypf :: a -> a

--------------------------------------------------------------------------------