    -- 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'"
    -}