cao-0.1: src/Language/CAO/Common/Polynomial.hs

{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveTraversable #-}
{-
Module      :  $Header$
Description :  CAO Polynomials
Copyright   :  (c) SMART Team / HASLab
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable (<reason>)

CAO Polynomials
-}
module Language.CAO.Common.Polynomial where

import Data.Foldable                  (Foldable)
import Data.List                      (intersperse, intercalate)
import Data.Maybe                     (catMaybes)
import Data.Traversable               (Traversable)

import Language.CAO.Common.Outputable
import Language.CAO.Common.Representation
import Language.CAO.Common.Utils

import Language.CAO.Index


newtype Pol id = Pol { monomials :: [Mon id] }
    deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord)

instance PP id => PP (Pol id) where
    ppr = hsep . intersperse (char '+') . map ppr . monomials

instance PP id => StringRepresentation (Pol id) where
    toString = intercalate "_" . map toString . monomials

-------------------------
-- Building polynomials
-------------------------

infixl 6 .+.
infixl 7 .*.
infixl 8 .^.

mon :: Mon id -> Pol id
mon (Mon (CoefP p) EZero) = p
mon m                     = Pol [m]

intC :: Integer -> MCoef id
intC i = CoefI (IInt i)

polC :: Pol id -> MCoef id
polC = CoefP

(.+.) :: Mon id -> Pol id -> Pol id
m .+. (Pol ms) = Pol (ms ++ [m])

(.*.) :: MCoef id -> MBase id -> Mon id
c .*. b = Mon c b

(.^.) :: id -> Integer -> MBase id
_ .^. 0 = EZero
n .^. i = MExpI n i

data Mon id = Mon !(MCoef id) !(MBase id)
    deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord)

instance PP id => PP (Mon id) where
    ppr = pprMon

pprMon :: PP id => Mon id -> CDoc
pprMon (Mon c EZero)
    = ppr c
pprMon (Mon (CoefI (IInt 1)) b)
    = ppr b
pprMon (Mon c b)
    = ppr c <> char '*' <> ppr b

instance PP id => StringRepresentation (Mon id) where
    toString = monStrRepresentation
    
monStrRepresentation :: PP id => Mon id -> String
monStrRepresentation m = 
    case m of
        Mon (CoefI (IInt 1)) (MExpI i 1) -> showPpr i
        Mon (CoefI (IInt c)) EZero       -> intString c
        Mon (CoefI c) EZero       -> showPpr c
        Mon (CoefI (IInt 1)) (MExpI i e) -> showPpr i ++ "_" ++ intString e
        Mon (CoefI (IInt c)) (MExpI i 1) -> intString c ++ "_" ++ showPpr i
        Mon (CoefI c) (MExpI i 1) -> showPpr c ++ "_" ++ showPpr i
        Mon (CoefI (IInt c)) (MExpI i e) -> intString c ++ "_" ++ showPpr i ++ "_" ++ intString e
        Mon (CoefI c) (MExpI i e) -> showPpr c ++ "_" ++ showPpr i ++ "_" ++ intString e
        Mon (CoefP p) EZero       -> "_" ++ toString p ++ "_"
        Mon (CoefP p) (MExpI i 1) -> "_" ++ toString p ++ "_" ++ showPpr i
        Mon (CoefP p) (MExpI i e) -> "_" ++ toString p ++ "_" ++ showPpr i ++ "_" ++ intString e

data MCoef id
    = CoefI !(IExpr id)
    | CoefP !(Pol id)
    deriving (Show, Read, Functor, Foldable, Traversable, Eq)

instance Ord id => Ord (MCoef id) where
    CoefI (IInt i) <= CoefI (IInt i') = i <= i'
    CoefI _ <= CoefI _  = error "<<TODO>><Ord>: non literal"
    CoefP p <= CoefP p' = p <= p'
    CoefI _ <= CoefP _  = True
    _ <= _              = False

instance PP id => PP (MCoef id) where
    ppr = pprMCoef

pprMCoef :: PP id => MCoef id -> CDoc
pprMCoef (CoefI i)
    = ppr i
pprMCoef (CoefP pol)
    = parens (ppr pol)

data MBase id
    = EZero
    | MExpI id Integer -- XXX: Symbolic exponent??
    deriving (Show, Read, Functor, Foldable, Traversable, Eq, Ord)

instance PP id => PP (MBase id) where
    ppr = pprMBase

pprMBase :: PP id => MBase id -> CDoc
pprMBase EZero = empty
pprMBase (MExpI n 1) = ppr n
pprMBase (MExpI n e) = ppr n <> text "**" <> integer e

-- * Auxiliary functions
-- XXX: Consider moving this to another module
degree :: Pol id -> Integer
degree (Pol []) = 0
degree (Pol ms) = maximum $ map polExp ms
    where 
    polExp (Mon _ EZero)       = 0
    polExp (Mon _ (MExpI _ e)) = e

neg :: Mon id -> Mon id
neg (Mon (CoefI (IInt i)) e) = Mon (CoefI (IInt (-i))) e
neg (Mon (CoefI i) e) = Mon (CoefI (ISym i)) e
neg (Mon (CoefP (Pol p)) e) = Mon (CoefP $ Pol $ map neg p) e

coeficiente :: Mon id -> Pol id
coeficiente (Mon (CoefI c) _) = Pol [Mon (CoefI c) EZero]
coeficiente (Mon (CoefP p) _) = p

getMonVar :: Mon id -> Maybe id
getMonVar (Mon _ EZero) = Nothing
getMonVar (Mon _ (MExpI n _)) = Just n

getMonExp :: Mon id -> Integer
getMonExp (Mon _ EZero) = 0
getMonExp (Mon _ (MExpI _ e)) = e

polyToMono :: Maybe id -> Pol id -> Integer -> Maybe (Mon id)
polyToMono _        (Pol [Mon (CoefI (IInt 0)) EZero]) _ = Nothing
polyToMono (Just i) (Pol [Mon (CoefI c) EZero]) e =
    Just $ Mon (CoefI c) (MExpI i e)
polyToMono (Just i) p                                          e =
    Just $ Mon (CoefP p) (MExpI i e)
polyToMono _ _ _ = error "<Language.CAO.Semantics>:<polyToMono>:\
    \ unexpected input"   
    
normMonos :: [Maybe (Mon id)] -> [Mon id]
normMonos = ifM null (const [Mon (CoefI (IInt 0)) EZero]) reverse . catMaybes
      
isValid :: Eq id => [Mon id] -> Bool
isValid (m:ms) = checkPol_ (getMonVar m) (m:ms)
isValid _      = False

checkPol_ :: Eq id => Maybe id -> [Mon id] -> Bool
checkPol_ ind     [m]
    = (getMonVar m == Nothing && getMonExp m == 0) || getMonVar m == ind
checkPol_ ind (m1:m0:ms)
    =  (getMonExp m1 > getMonExp m0)
    && (getMonVar m1 == ind)
    && checkMon_ m1
    && checkPol_ ind (m0:ms)
checkPol_ _ _ = error "<Language.CAO.Common>:<checkPol_>: \ 
    \ unexpected empty list of monomials"

checkMon_ :: Eq id => Mon id -> Bool
checkMon_ (Mon (CoefI _) _) = True
checkMon_ (Mon (CoefP p) _) = isValid (monomials p)