-- Copyright (c) 2010, David Amos. All rights reserved.

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}


module Math.Algebras.LaurentPoly where


import Math.Algebra.Field.Base hiding (powers)

import Math.Algebras.VectorSpace
import Math.Algebras.TensorProduct
import Math.Algebras.Structures
import qualified Data.List as L

import Math.Algebras.Commutative -- for DivisionBasis and quotRemMP


-- LAURENT MONOMIALS

data LaurentMonomial = LM Int [(String,Int)] deriving (LaurentMonomial -> LaurentMonomial -> Bool
(LaurentMonomial -> LaurentMonomial -> Bool)
-> (LaurentMonomial -> LaurentMonomial -> Bool)
-> Eq LaurentMonomial
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LaurentMonomial -> LaurentMonomial -> Bool
$c/= :: LaurentMonomial -> LaurentMonomial -> Bool
== :: LaurentMonomial -> LaurentMonomial -> Bool
$c== :: LaurentMonomial -> LaurentMonomial -> Bool
Eq,Eq LaurentMonomial
Eq LaurentMonomial =>
(LaurentMonomial -> LaurentMonomial -> Ordering)
-> (LaurentMonomial -> LaurentMonomial -> Bool)
-> (LaurentMonomial -> LaurentMonomial -> Bool)
-> (LaurentMonomial -> LaurentMonomial -> Bool)
-> (LaurentMonomial -> LaurentMonomial -> Bool)
-> (LaurentMonomial -> LaurentMonomial -> LaurentMonomial)
-> (LaurentMonomial -> LaurentMonomial -> LaurentMonomial)
-> Ord LaurentMonomial
LaurentMonomial -> LaurentMonomial -> Bool
LaurentMonomial -> LaurentMonomial -> Ordering
LaurentMonomial -> LaurentMonomial -> LaurentMonomial
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LaurentMonomial -> LaurentMonomial -> LaurentMonomial
$cmin :: LaurentMonomial -> LaurentMonomial -> LaurentMonomial
max :: LaurentMonomial -> LaurentMonomial -> LaurentMonomial
$cmax :: LaurentMonomial -> LaurentMonomial -> LaurentMonomial
>= :: LaurentMonomial -> LaurentMonomial -> Bool
$c>= :: LaurentMonomial -> LaurentMonomial -> Bool
> :: LaurentMonomial -> LaurentMonomial -> Bool
$c> :: LaurentMonomial -> LaurentMonomial -> Bool
<= :: LaurentMonomial -> LaurentMonomial -> Bool
$c<= :: LaurentMonomial -> LaurentMonomial -> Bool
< :: LaurentMonomial -> LaurentMonomial -> Bool
$c< :: LaurentMonomial -> LaurentMonomial -> Bool
compare :: LaurentMonomial -> LaurentMonomial -> Ordering
$ccompare :: LaurentMonomial -> LaurentMonomial -> Ordering
$cp1Ord :: Eq LaurentMonomial
Ord)
{-
instance Ord LaurentMonomial where
    compare (LM si xis) (LM sj yjs) = compare (-si, xis) (-sj, yjs)
-}
instance Show LaurentMonomial where
    show :: LaurentMonomial -> String
show (LM 0 []) = "1"
    show (LM _ xis :: [(String, Int)]
xis) = ((String, Int) -> String) -> [(String, Int)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(x :: String
x,i :: Int
i) -> if Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==1 then String
x else String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ "^" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [(String, Int)]
xis

instance Mon LaurentMonomial where
    munit :: LaurentMonomial
munit = Int -> [(String, Int)] -> LaurentMonomial
LM 0 []
    mmult :: LaurentMonomial -> LaurentMonomial -> LaurentMonomial
mmult (LM si :: Int
si xis :: [(String, Int)]
xis) (LM sj :: Int
sj yjs :: [(String, Int)]
yjs) = Int -> [(String, Int)] -> LaurentMonomial
LM (Int
siInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sj) ([(String, Int)] -> LaurentMonomial)
-> [(String, Int)] -> LaurentMonomial
forall a b. (a -> b) -> a -> b
$ [(String, Int)] -> [(String, Int)] -> [(String, Int)]
forall a b.
(Ord a, Num b, Eq b) =>
[(a, b)] -> [(a, b)] -> [(a, b)]
addmerge [(String, Int)]
xis [(String, Int)]
yjs

instance (Eq k, Num k) => Algebra k LaurentMonomial where
    unit :: k -> Vect k LaurentMonomial
unit 0 = Vect k LaurentMonomial
forall k b. Vect k b
zerov -- V []
    unit x :: k
x = [(LaurentMonomial, k)] -> Vect k LaurentMonomial
forall k b. [(b, k)] -> Vect k b
V [(LaurentMonomial
forall m. Mon m => m
munit,k
x)] 
    mult :: Vect k (Tensor LaurentMonomial LaurentMonomial)
-> Vect k LaurentMonomial
mult (V ts :: [(Tensor LaurentMonomial LaurentMonomial, k)]
ts) = Vect k LaurentMonomial -> Vect k LaurentMonomial
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect k LaurentMonomial -> Vect k LaurentMonomial)
-> Vect k LaurentMonomial -> Vect k LaurentMonomial
forall a b. (a -> b) -> a -> b
$ (Tensor LaurentMonomial LaurentMonomial -> LaurentMonomial)
-> Vect k (Tensor LaurentMonomial LaurentMonomial)
-> Vect k LaurentMonomial
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a :: LaurentMonomial
a,b :: LaurentMonomial
b) -> LaurentMonomial
a LaurentMonomial -> LaurentMonomial -> LaurentMonomial
forall m. Mon m => m -> m -> m
`mmult` LaurentMonomial
b) ([(Tensor LaurentMonomial LaurentMonomial, k)]
-> Vect k (Tensor LaurentMonomial LaurentMonomial)
forall k b. [(b, k)] -> Vect k b
V [(Tensor LaurentMonomial LaurentMonomial, k)]
ts)
    -- mult (V ts) = nf $ V [(a `mmult` b, x) | (T a b, x) <- ts]

{-
-- This is just the Set Coalgebra, so better to use a generic instance
-- Also, not used anywhere. Hence commented out
instance Num k => Coalgebra k LaurentMonomial where
    counit (V ts) = sum [x | (m,x) <- ts] -- trace
    comult = fmap (\m -> T m m)
-}

type LaurentPoly k = Vect k LaurentMonomial

lvar :: String -> LaurentPoly Q
lvar v :: String
v = [(LaurentMonomial, Q)] -> LaurentPoly Q
forall k b. [(b, k)] -> Vect k b
V [(Int -> [(String, Int)] -> LaurentMonomial
LM 1 [(String
v,1)], 1)] :: LaurentPoly Q

instance (Eq k, Fractional k) => Fractional (LaurentPoly k) where
    recip :: LaurentPoly k -> LaurentPoly k
recip (V [(LM si :: Int
si xis :: [(String, Int)]
xis,c :: k
c)]) = [(LaurentMonomial, k)] -> LaurentPoly k
forall k b. [(b, k)] -> Vect k b
V [(Int -> [(String, Int)] -> LaurentMonomial
LM (-Int
si) ([(String, Int)] -> LaurentMonomial)
-> [(String, Int)] -> LaurentMonomial
forall a b. (a -> b) -> a -> b
$ ((String, Int) -> (String, Int))
-> [(String, Int)] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: String
x,i :: Int
i)->(String
x,-Int
i)) [(String, Int)]
xis, k -> k
forall a. Fractional a => a -> a
recip k
c)]
    recip _ = String -> LaurentPoly k
forall a. HasCallStack => String -> a
error "LaurentPoly.recip: only defined for single terms"

q :: LaurentPoly Q
q = String -> LaurentPoly Q
lvar "q"
q' :: LaurentPoly Q
q' = 1LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Fractional a => a -> a -> a
/LaurentPoly Q
q


{-
-- division doesn't terminate with the derived Ord instance
-- if we use the graded Ord instance instead, division doesn't continue into negative powers
-- so we get the negative powers as remained, even if they're divisible
instance DivisionBasis LaurentMonomial where
    dividesB (LM si xis) (LM sj yjs) = si <= sj && dividesB' xis yjs where
        dividesB' ((x,i):xis) ((y,j):yjs) =
            case compare x y of
            LT -> False
            GT -> dividesB' ((x,i):xis) yjs
            EQ -> if i<=j then dividesB' xis yjs else False
        dividesB' [] _ = True
        dividesB' _ [] = False
    divB (LM si xis) (LM sj yjs) = LM (si-sj) $ divB' xis yjs where
        divB' ((x,i):xis) ((y,j):yjs) =
            case compare x y of
            LT -> (x,i) : divB' xis ((y,j):yjs)
            EQ -> if i == j then divB' xis yjs else (x,i-j) : divB' xis yjs -- we don't bother to check i > j
            GT -> error "divB'" -- (y,-j) : divB' ((x,i):xis) yjs
        divB' xis [] = xis
        divB' [] yjs = error "divB'"
-}