{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE QuasiQuotes           #-}

{- |
Module      : Language.Egison.Math.Expr
Licence     : MIT

This module defines the internal representation of mathematic objects such as
polynominals, and some useful patterns.
-}

module Language.Egison.Math.Expr
    ( ScalarData (..)
    , PolyExpr (..)
    , TermExpr (..)
    , Monomial
    , SymbolExpr (..)
    , Printable (..)
    , pattern ZeroExpr
    , pattern SingleSymbol
    , pattern SingleTerm
    , ScalarM (..)
    , TermM (..)
    , SymbolM (..)
    , term
    , termM
    , symbol
    , symbolM
    , func
    , funcM
    , apply1
    , apply1M
    , apply2
    , apply2M
    , apply3
    , apply3M
    , apply4
    , apply4M
    , quote
    , negQuote
    , negQuoteM
    , quoteFunction
    , quoteFunctionM
    , equalMonomial
    , equalMonomialM
    , zero
    , zeroM
    , singleTerm
    , singleTermM
    , mathScalarMult
    , mathNegate
    , makeApplyExpr
    ) where

import           Data.List             (intercalate)
import           Prelude               hiding (foldr, mappend, mconcat)

import           Control.Egison
import           Control.Monad         (MonadPlus (..))

import           Language.Egison.IExpr (Index (..))
import {-# SOURCE #-} Language.Egison.Data (WHNFData, prettyFunctionName)

--
-- Data
--


data ScalarData
  = Div PolyExpr PolyExpr
 deriving ScalarData -> ScalarData -> Bool
(ScalarData -> ScalarData -> Bool)
-> (ScalarData -> ScalarData -> Bool) -> Eq ScalarData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScalarData -> ScalarData -> Bool
== :: ScalarData -> ScalarData -> Bool
$c/= :: ScalarData -> ScalarData -> Bool
/= :: ScalarData -> ScalarData -> Bool
Eq

newtype PolyExpr
  = Plus [TermExpr]

data TermExpr
  = Term Integer Monomial

-- We choose the definition 'monomials' without its coefficients.
-- ex. 2 x^2 y^3 is *not* a monomial. x^2 t^3 is a monomial.
type Monomial = [(SymbolExpr, Integer)]

data SymbolExpr
  = Symbol Id String [Index ScalarData]
  | Apply1 ScalarData ScalarData
  | Apply2 ScalarData ScalarData ScalarData
  | Apply3 ScalarData ScalarData ScalarData ScalarData
  | Apply4 ScalarData ScalarData ScalarData ScalarData ScalarData
  | Quote ScalarData                     -- For backtick quote: `expr
  | QuoteFunction WHNFData              -- For single quote on functions: 'func
  | FunctionData ScalarData [ScalarData] -- fnname args

-- Manual Eq instance (QuoteFunction comparison always returns False)
instance Eq SymbolExpr where
  Symbol Id
id1 Id
s1 [Index ScalarData]
js1 == :: SymbolExpr -> SymbolExpr -> Bool
== Symbol Id
id2 Id
s2 [Index ScalarData]
js2 = Id
id1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
id2 Bool -> Bool -> Bool
&& Id
s1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
s2 Bool -> Bool -> Bool
&& [Index ScalarData]
js1 [Index ScalarData] -> [Index ScalarData] -> Bool
forall a. Eq a => a -> a -> Bool
== [Index ScalarData]
js2
  Apply1 ScalarData
f1 ScalarData
a1 == Apply1 ScalarData
f2 ScalarData
a2 = ScalarData
f1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
f2 Bool -> Bool -> Bool
&& ScalarData
a1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
a2
  Apply2 ScalarData
f1 ScalarData
a1 ScalarData
b1 == Apply2 ScalarData
f2 ScalarData
a2 ScalarData
b2 = ScalarData
f1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
f2 Bool -> Bool -> Bool
&& ScalarData
a1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
a2 Bool -> Bool -> Bool
&& ScalarData
b1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
b2
  Apply3 ScalarData
f1 ScalarData
a1 ScalarData
b1 ScalarData
c1 == Apply3 ScalarData
f2 ScalarData
a2 ScalarData
b2 ScalarData
c2 = ScalarData
f1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
f2 Bool -> Bool -> Bool
&& ScalarData
a1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
a2 Bool -> Bool -> Bool
&& ScalarData
b1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
b2 Bool -> Bool -> Bool
&& ScalarData
c1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
c2
  Apply4 ScalarData
f1 ScalarData
a1 ScalarData
b1 ScalarData
c1 ScalarData
d1 == Apply4 ScalarData
f2 ScalarData
a2 ScalarData
b2 ScalarData
c2 ScalarData
d2 = ScalarData
f1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
f2 Bool -> Bool -> Bool
&& ScalarData
a1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
a2 Bool -> Bool -> Bool
&& ScalarData
b1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
b2 Bool -> Bool -> Bool
&& ScalarData
c1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
c2 Bool -> Bool -> Bool
&& ScalarData
d1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
d2
  Quote ScalarData
m1 == Quote ScalarData
m2 = ScalarData
m1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
m2
  QuoteFunction WHNFData
whnf1 == QuoteFunction WHNFData
whnf2 = 
    case (WHNFData -> Maybe Id
prettyFunctionName WHNFData
whnf1, WHNFData -> Maybe Id
prettyFunctionName WHNFData
whnf2) of
      (Just Id
n1, Just Id
n2) -> Id
n1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
n2
      (Maybe Id, Maybe Id)
_ -> Bool
False  -- Anonymous functions are never equal
  FunctionData ScalarData
n1 [ScalarData]
k1 == FunctionData ScalarData
n2 [ScalarData]
k2 = ScalarData
n1 ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
n2 Bool -> Bool -> Bool
&& [ScalarData]
k1 [ScalarData] -> [ScalarData] -> Bool
forall a. Eq a => a -> a -> Bool
== [ScalarData]
k2
  SymbolExpr
_ == SymbolExpr
_ = Bool
False

-- Helper function to create Apply constructors based on argument count
makeApplyExpr :: ScalarData -> [ScalarData] -> SymbolExpr
makeApplyExpr :: ScalarData -> [ScalarData] -> SymbolExpr
makeApplyExpr ScalarData
fn [ScalarData
a1] = ScalarData -> ScalarData -> SymbolExpr
Apply1 ScalarData
fn ScalarData
a1
makeApplyExpr ScalarData
fn [ScalarData
a1, ScalarData
a2] = ScalarData -> ScalarData -> ScalarData -> SymbolExpr
Apply2 ScalarData
fn ScalarData
a1 ScalarData
a2
makeApplyExpr ScalarData
fn [ScalarData
a1, ScalarData
a2, ScalarData
a3] = ScalarData -> ScalarData -> ScalarData -> ScalarData -> SymbolExpr
Apply3 ScalarData
fn ScalarData
a1 ScalarData
a2 ScalarData
a3
makeApplyExpr ScalarData
fn [ScalarData
a1, ScalarData
a2, ScalarData
a3, ScalarData
a4] = ScalarData
-> ScalarData
-> ScalarData
-> ScalarData
-> ScalarData
-> SymbolExpr
Apply4 ScalarData
fn ScalarData
a1 ScalarData
a2 ScalarData
a3 ScalarData
a4
makeApplyExpr ScalarData
_ [ScalarData]
_ = Id -> SymbolExpr
forall a. HasCallStack => Id -> a
error Id
"makeApplyExpr: unsupported number of arguments (must be 1-4)"

type Id = String

-- Matchers

data ScalarM = ScalarM
instance Matcher ScalarM ScalarData

data TermM = TermM
instance Matcher TermM TermExpr

data SymbolM = SymbolM
instance Matcher SymbolM SymbolExpr

term :: Pattern (PP Integer, PP Monomial) TermM TermExpr (Integer, Monomial)
term :: Pattern
  (PP Integer, PP Monomial) TermM TermExpr (Integer, Monomial)
term (PP Integer, PP Monomial)
_ TermM
_ (Term Integer
a Monomial
mono) = (Integer, Monomial) -> [(Integer, Monomial)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
a, Monomial
mono)
termM :: TermM -> TermExpr -> (Eql, Multiset (SymbolM, Eql))
termM :: TermM -> TermExpr -> (Eql, Multiset (SymbolM, Eql))
termM TermM
TermM TermExpr
_ = (Eql
Eql, (SymbolM, Eql) -> Multiset (SymbolM, Eql)
forall m. m -> Multiset m
Multiset (SymbolM
SymbolM, Eql
Eql))

symbol :: Pattern (PP String) SymbolM SymbolExpr String
symbol :: Pattern (PP Id) SymbolM SymbolExpr Id
symbol PP Id
_ SymbolM
_ (Symbol Id
_ Id
name []) = Id -> [Id]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
name
symbol PP Id
_ SymbolM
_ SymbolExpr
_                  = [Id]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
symbolM :: SymbolM -> p -> Eql
symbolM :: forall p. SymbolM -> p -> Eql
symbolM SymbolM
SymbolM p
_ = Eql
Eql

func :: Pattern (PP ScalarData, PP [ScalarData])
                SymbolM SymbolExpr (ScalarData, [ScalarData])
func :: Pattern
  (PP ScalarData, PP [ScalarData])
  SymbolM
  SymbolExpr
  (ScalarData, [ScalarData])
func (PP ScalarData, PP [ScalarData])
_ SymbolM
_ (FunctionData ScalarData
name [ScalarData]
args) = (ScalarData, [ScalarData]) -> [(ScalarData, [ScalarData])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarData
name, [ScalarData]
args)
func (PP ScalarData, PP [ScalarData])
_ SymbolM
_ SymbolExpr
_                        = [(ScalarData, [ScalarData])]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM)
funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM)
funcM SymbolM
SymbolM SymbolExpr
_ = (ScalarM
ScalarM, ScalarM -> List ScalarM
forall m. m -> List m
List ScalarM
ScalarM)

apply1 :: Pattern (PP String, PP WHNFData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData)
apply1 :: Pattern
  (PP Id, PP WHNFData, PP ScalarData)
  SymbolM
  SymbolExpr
  (Id, WHNFData, ScalarData)
apply1 (PP Id, PP WHNFData, PP ScalarData)
_ SymbolM
_ (Apply1 (SingleSymbol (QuoteFunction WHNFData
fnWhnf)) ScalarData
a1) =
  case WHNFData -> Maybe Id
prettyFunctionName WHNFData
fnWhnf of
    Just Id
fn -> (Id, WHNFData, ScalarData) -> [(Id, WHNFData, ScalarData)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
fn, WHNFData
fnWhnf, ScalarData
a1)
    Maybe Id
Nothing -> [(Id, WHNFData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply1 (PP Id, PP WHNFData, PP ScalarData)
_ SymbolM
_ SymbolExpr
_ = [(Id, WHNFData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply1M :: SymbolM -> p -> (Eql, Something, ScalarM)
apply1M :: forall p. SymbolM -> p -> (Eql, Something, ScalarM)
apply1M SymbolM
SymbolM p
_ = (Eql
Eql, Something
Something, ScalarM
ScalarM)

apply2 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData)
apply2 :: Pattern
  (PP Id, PP WHNFData, PP ScalarData, PP ScalarData)
  SymbolM
  SymbolExpr
  (Id, WHNFData, ScalarData, ScalarData)
apply2 (PP Id, PP WHNFData, PP ScalarData, PP ScalarData)
_ SymbolM
_ (Apply2 (SingleSymbol (QuoteFunction WHNFData
fnWhnf)) ScalarData
a1 ScalarData
a2) =
  case WHNFData -> Maybe Id
prettyFunctionName WHNFData
fnWhnf of
    Just Id
fn -> (Id, WHNFData, ScalarData, ScalarData)
-> [(Id, WHNFData, ScalarData, ScalarData)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
fn, WHNFData
fnWhnf, ScalarData
a1, ScalarData
a2)
    Maybe Id
Nothing -> [(Id, WHNFData, ScalarData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply2 (PP Id, PP WHNFData, PP ScalarData, PP ScalarData)
_ SymbolM
_ SymbolExpr
_ = [(Id, WHNFData, ScalarData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply2M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM)
apply2M :: forall p. SymbolM -> p -> (Eql, Something, ScalarM, ScalarM)
apply2M SymbolM
SymbolM p
_ = (Eql
Eql, Something
Something, ScalarM
ScalarM, ScalarM
ScalarM)

apply3 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData, ScalarData)
apply3 :: Pattern
  (PP Id, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData)
  SymbolM
  SymbolExpr
  (Id, WHNFData, ScalarData, ScalarData, ScalarData)
apply3 (PP Id, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData)
_ SymbolM
_ (Apply3 (SingleSymbol (QuoteFunction WHNFData
fnWhnf)) ScalarData
a1 ScalarData
a2 ScalarData
a3) =
  case WHNFData -> Maybe Id
prettyFunctionName WHNFData
fnWhnf of
    Just Id
fn -> (Id, WHNFData, ScalarData, ScalarData, ScalarData)
-> [(Id, WHNFData, ScalarData, ScalarData, ScalarData)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
fn, WHNFData
fnWhnf, ScalarData
a1, ScalarData
a2, ScalarData
a3)
    Maybe Id
Nothing -> [(Id, WHNFData, ScalarData, ScalarData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply3 (PP Id, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData)
_ SymbolM
_ SymbolExpr
_ = [(Id, WHNFData, ScalarData, ScalarData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply3M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM)
apply3M :: forall p.
SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM)
apply3M SymbolM
SymbolM p
_ = (Eql
Eql, Something
Something, ScalarM
ScalarM, ScalarM
ScalarM, ScalarM
ScalarM)

apply4 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)
apply4 :: Pattern
  (PP Id, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData,
   PP ScalarData)
  SymbolM
  SymbolExpr
  (Id, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)
apply4 (PP Id, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData,
 PP ScalarData)
_ SymbolM
_ (Apply4 (SingleSymbol (QuoteFunction WHNFData
fnWhnf)) ScalarData
a1 ScalarData
a2 ScalarData
a3 ScalarData
a4) =
  case WHNFData -> Maybe Id
prettyFunctionName WHNFData
fnWhnf of
    Just Id
fn -> (Id, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)
-> [(Id, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
fn, WHNFData
fnWhnf, ScalarData
a1, ScalarData
a2, ScalarData
a3, ScalarData
a4)
    Maybe Id
Nothing -> [(Id, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply4 (PP Id, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData,
 PP ScalarData)
_ SymbolM
_ SymbolExpr
_ = [(Id, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
apply4M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM, ScalarM)
apply4M :: forall p.
SymbolM
-> p -> (Eql, Something, ScalarM, ScalarM, ScalarM, ScalarM)
apply4M SymbolM
SymbolM p
_ = (Eql
Eql, Something
Something, ScalarM
ScalarM, ScalarM
ScalarM, ScalarM
ScalarM, ScalarM
ScalarM)

quote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData
quote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData
quote PP ScalarData
_ SymbolM
_ (Quote ScalarData
m) = ScalarData -> [ScalarData]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScalarData
m
quote PP ScalarData
_ SymbolM
_ SymbolExpr
_         = [ScalarData]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero

negQuote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData
negQuote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData
negQuote PP ScalarData
_ SymbolM
_ (Quote ScalarData
m) = ScalarData -> [ScalarData]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarData -> ScalarData
mathNegate ScalarData
m)
negQuote PP ScalarData
_ SymbolM
_ SymbolExpr
_         = [ScalarData]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
negQuoteM :: SymbolM -> p -> ScalarM
negQuoteM :: forall p. SymbolM -> p -> ScalarM
negQuoteM SymbolM
SymbolM p
_ = ScalarM
ScalarM

quoteFunction :: Pattern (PP String, PP WHNFData) SymbolM SymbolExpr (String, WHNFData)
quoteFunction :: Pattern (PP Id, PP WHNFData) SymbolM SymbolExpr (Id, WHNFData)
quoteFunction (PP Id, PP WHNFData)
_ SymbolM
_ (QuoteFunction WHNFData
whnf) = case WHNFData -> Maybe Id
prettyFunctionName WHNFData
whnf of
  Just Id
name -> (Id, WHNFData) -> [(Id, WHNFData)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
name, WHNFData
whnf)
  Maybe Id
Nothing   -> [(Id, WHNFData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
quoteFunction (PP Id, PP WHNFData)
_ SymbolM
_ SymbolExpr
_ = [(Id, WHNFData)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
quoteFunctionM :: SymbolM -> p -> Eql
quoteFunctionM :: forall p. SymbolM -> p -> Eql
quoteFunctionM SymbolM
SymbolM p
_ = Eql
Eql

equalMonomial :: Pattern (PP Integer, PP Monomial) (Multiset (SymbolM, Eql)) Monomial (Integer, Monomial)
equalMonomial :: Pattern
  (PP Integer, PP Monomial)
  (Multiset (SymbolM, Eql))
  Monomial
  (Integer, Monomial)
equalMonomial (PP Integer
_, VP Monomial
xs) Multiset (SymbolM, Eql)
_ Monomial
ys = case Monomial -> Monomial -> Maybe Integer
isEqualMonomial Monomial
xs Monomial
ys of
                                  Just Integer
sgn -> (Integer, Monomial) -> [(Integer, Monomial)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
sgn, Monomial
xs)
                                  Maybe Integer
Nothing  -> [(Integer, Monomial)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
equalMonomial (PP Integer, PP Monomial)
_ Multiset (SymbolM, Eql)
_ Monomial
_ = [(Integer, Monomial)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
equalMonomialM :: Multiset (SymbolM, Eql) -> p -> (Eql, Multiset (SymbolM, Eql))
equalMonomialM :: forall p.
Multiset (SymbolM, Eql) -> p -> (Eql, Multiset (SymbolM, Eql))
equalMonomialM (Multiset (SymbolM
SymbolM, Eql
Eql)) p
_ = (Eql
Eql, (SymbolM, Eql) -> Multiset (SymbolM, Eql)
forall m. m -> Multiset m
Multiset (SymbolM
SymbolM, Eql
Eql))

zero :: Pattern () ScalarM ScalarData ()
zero :: Pattern () ScalarM ScalarData ()
zero ()
_ ScalarM
_ (Div (Plus []) PolyExpr
_) = () -> [()]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
zero ()
_ ScalarM
_ ScalarData
_                 = [()]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
zeroM :: ScalarM -> p -> ()
zeroM :: forall p. ScalarM -> p -> ()
zeroM ScalarM
ScalarM p
_ = ()

singleTerm :: Pattern (PP Integer, PP Integer, PP Monomial) ScalarM ScalarData (Integer, Integer, Monomial)
singleTerm :: Pattern
  (PP Integer, PP Integer, PP Monomial)
  ScalarM
  ScalarData
  (Integer, Integer, Monomial)
singleTerm (PP Integer, PP Integer, PP Monomial)
_ ScalarM
_ (Div (Plus [Term Integer
c Monomial
mono]) (Plus [Term Integer
c2 []])) = (Integer, Integer, Monomial) -> [(Integer, Integer, Monomial)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
c, Integer
c2, Monomial
mono)
singleTerm (PP Integer, PP Integer, PP Monomial)
_ ScalarM
_ ScalarData
_                                              = [(Integer, Integer, Monomial)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
singleTermM :: ScalarM -> p -> (Eql, Eql, Multiset (SymbolM, Eql))
singleTermM :: forall p. ScalarM -> p -> (Eql, Eql, Multiset (SymbolM, Eql))
singleTermM ScalarM
ScalarM p
_ = (Eql
Eql, Eql
Eql, (SymbolM, Eql) -> Multiset (SymbolM, Eql)
forall m. m -> Multiset m
Multiset (SymbolM
SymbolM, Eql
Eql))


instance ValuePattern ScalarM ScalarData where
  value :: ScalarData -> Pattern () ScalarM ScalarData ()
value ScalarData
e () ScalarM
ScalarM ScalarData
v = if ScalarData
e ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
v then () -> [()]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else [()]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ValuePattern SymbolM SymbolExpr where
  value :: SymbolExpr -> Pattern () SymbolM SymbolExpr ()
value SymbolExpr
e () SymbolM
SymbolM SymbolExpr
v = if SymbolExpr
e SymbolExpr -> SymbolExpr -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolExpr
v then () -> [()]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else [()]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero


pattern ZeroExpr :: ScalarData
pattern $mZeroExpr :: forall {r}. ScalarData -> ((# #) -> r) -> ((# #) -> r) -> r
$bZeroExpr :: ScalarData
ZeroExpr = (Div (Plus []) (Plus [Term 1 []]))

pattern SingleSymbol :: SymbolExpr -> ScalarData
pattern $mSingleSymbol :: forall {r}. ScalarData -> (SymbolExpr -> r) -> ((# #) -> r) -> r
$bSingleSymbol :: SymbolExpr -> ScalarData
SingleSymbol sym = Div (Plus [Term 1 [(sym, 1)]]) (Plus [Term 1 []])

-- Product of a coefficient and a monomial
pattern SingleTerm :: Integer -> Monomial -> ScalarData
pattern $mSingleTerm :: forall {r}.
ScalarData -> (Integer -> Monomial -> r) -> ((# #) -> r) -> r
$bSingleTerm :: Integer -> Monomial -> ScalarData
SingleTerm coeff mono = Div (Plus [Term coeff mono]) (Plus [Term 1 []])

instance Eq PolyExpr where
  Plus [TermExpr]
xs == :: PolyExpr -> PolyExpr -> Bool
== Plus [TermExpr]
ys =
    ((Multiset Eql, [TermExpr]) -> DFS (Multiset Eql, [TermExpr]))
-> [TermExpr]
-> Multiset Eql
-> [(Multiset Eql, [TermExpr]) -> DFS Bool]
-> Bool
forall m t (s :: * -> *) r.
(Matcher m t, MonadSearch s) =>
((m, t) -> s (m, t)) -> t -> m -> [(m, t) -> s r] -> r
match (Multiset Eql, [TermExpr]) -> DFS (Multiset Eql, [TermExpr])
forall a. a -> DFS a
dfs [TermExpr]
ys (Eql -> Multiset Eql
forall m. m -> Multiset m
Multiset Eql
Eql)
      [ (Multiset Eql, [TermExpr]) -> DFS Bool
[mc| #xs -> True |]
      , (Multiset Eql, [TermExpr]) -> DFS Bool
[mc| _   -> False |] ]

instance Eq TermExpr where
  Term Integer
a Monomial
xs == :: TermExpr -> TermExpr -> Bool
== Term Integer
b Monomial
ys
    | Integer
a Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
b    = Monomial -> Monomial -> Maybe Integer
isEqualMonomial Monomial
xs Monomial
ys Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1
    | Integer
a Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
b   = Monomial -> Monomial -> Maybe Integer
isEqualMonomial Monomial
xs Monomial
ys Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just (-Integer
1)
    | Bool
otherwise = Bool
False

isEqualMonomial :: Monomial -> Monomial -> Maybe Integer
isEqualMonomial :: Monomial -> Monomial -> Maybe Integer
isEqualMonomial Monomial
xs Monomial
ys =
  (((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
  (Monomial, Monomial))
 -> DFS
      ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
       (Monomial, Monomial)))
-> (Monomial, Monomial)
-> (Multiset (SymbolM, Eql), Multiset (SymbolM, Eql))
-> [((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
     (Monomial, Monomial))
    -> DFS (Maybe Integer)]
-> Maybe Integer
forall m t (s :: * -> *) r.
(Matcher m t, MonadSearch s) =>
((m, t) -> s (m, t)) -> t -> m -> [(m, t) -> s r] -> r
match ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
 (Monomial, Monomial))
-> DFS
     ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
      (Monomial, Monomial))
forall a. a -> DFS a
dfs (Monomial
xs, Monomial
ys) ((SymbolM, Eql) -> Multiset (SymbolM, Eql)
forall m. m -> Multiset m
Multiset (SymbolM
SymbolM, Eql
Eql), (SymbolM, Eql) -> Multiset (SymbolM, Eql)
forall m. m -> Multiset m
Multiset (SymbolM
SymbolM, Eql
Eql))
    [ ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
 (Monomial, Monomial))
-> DFS (Maybe Integer)
[mc| ((quote $s, $n) : $xss, (negQuote #s, #n) : $yss) ->
             case isEqualMonomial xss yss of
               Nothing -> Nothing
               Just sgn -> return (if even n then sgn else - sgn) |]
    , ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
 (Monomial, Monomial))
-> DFS (Maybe Integer)
[mc| (($x, $n) : $xss, (#x, #n) : $yss) -> isEqualMonomial xss yss |]
    , ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
 (Monomial, Monomial))
-> DFS (Maybe Integer)
[mc| ([], []) -> return 1 |]
    , ((Multiset (SymbolM, Eql), Multiset (SymbolM, Eql)),
 (Monomial, Monomial))
-> DFS (Maybe Integer)
[mc| _ -> Nothing |]
    ]

--
--  Arithmetic operations
--

mathScalarMult :: Integer -> ScalarData -> ScalarData
mathScalarMult :: Integer -> ScalarData -> ScalarData
mathScalarMult Integer
c (Div PolyExpr
m PolyExpr
n) = PolyExpr -> PolyExpr -> ScalarData
Div (Integer -> PolyExpr -> PolyExpr
f Integer
c PolyExpr
m) PolyExpr
n
  where
    f :: Integer -> PolyExpr -> PolyExpr
f Integer
c (Plus [TermExpr]
ts) = [TermExpr] -> PolyExpr
Plus ((TermExpr -> TermExpr) -> [TermExpr] -> [TermExpr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Term Integer
a Monomial
xs) -> Integer -> Monomial -> TermExpr
Term (Integer
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
a) Monomial
xs) [TermExpr]
ts)

mathNegate :: ScalarData -> ScalarData
mathNegate :: ScalarData -> ScalarData
mathNegate = Integer -> ScalarData -> ScalarData
mathScalarMult (-Integer
1)

--
-- Pretty printing
--

class Printable a where
  isAtom :: a -> Bool
  pretty :: a -> String

pretty' :: Printable a => a -> String
pretty' :: forall a. Printable a => a -> Id
pretty' a
e | a -> Bool
forall a. Printable a => a -> Bool
isAtom a
e = a -> Id
forall a. Printable a => a -> Id
pretty a
e
pretty' a
e            = Id
"(" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ a -> Id
forall a. Printable a => a -> Id
pretty a
e Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Id
")"

instance Printable ScalarData where
  isAtom :: ScalarData -> Bool
isAtom (Div PolyExpr
p (Plus [Term Integer
1 []])) = PolyExpr -> Bool
forall a. Printable a => a -> Bool
isAtom PolyExpr
p
  isAtom ScalarData
_                          = Bool
False

  pretty :: ScalarData -> Id
pretty (Div PolyExpr
p1 (Plus [Term Integer
1 []])) = PolyExpr -> Id
forall a. Printable a => a -> Id
pretty PolyExpr
p1
  pretty (Div PolyExpr
p1 PolyExpr
p2)                 = PolyExpr -> Id
pretty'' PolyExpr
p1 Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Id
" / " Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ PolyExpr -> Id
forall a. Printable a => a -> Id
pretty' PolyExpr
p2
    where
      pretty'' :: PolyExpr -> String
      pretty'' :: PolyExpr -> Id
pretty'' p :: PolyExpr
p@(Plus [TermExpr
_]) = PolyExpr -> Id
forall a. Printable a => a -> Id
pretty PolyExpr
p
      pretty'' PolyExpr
p            = Id
"(" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ PolyExpr -> Id
forall a. Printable a => a -> Id
pretty PolyExpr
p Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Id
")"

instance Printable PolyExpr where
  isAtom :: PolyExpr -> Bool
isAtom (Plus [])           = Bool
True
  isAtom (Plus [Term Integer
_ []])  = Bool
True
  isAtom (Plus [Term Integer
1 [(SymbolExpr, Integer)
_]]) = Bool
True
  isAtom PolyExpr
_                   = Bool
False

  pretty :: PolyExpr -> Id
pretty (Plus []) = Id
"0"
  pretty (Plus (TermExpr
t:[TermExpr]
ts)) = TermExpr -> Id
forall a. Printable a => a -> Id
pretty TermExpr
t Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ (TermExpr -> Id) -> [TermExpr] -> Id
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TermExpr -> Id
withSign [TermExpr]
ts
    where
      withSign :: TermExpr -> Id
withSign (Term Integer
a Monomial
xs) | Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = Id
" - " Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ TermExpr -> Id
forall a. Printable a => a -> Id
pretty (Integer -> Monomial -> TermExpr
Term (- Integer
a) Monomial
xs)
      withSign TermExpr
t                   = Id
" + " Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ TermExpr -> Id
forall a. Printable a => a -> Id
pretty TermExpr
t

instance Printable SymbolExpr where
  isAtom :: SymbolExpr -> Bool
isAtom Symbol{}        = Bool
True
  isAtom Quote{}         = Bool
True
  isAtom QuoteFunction{} = Bool
True
  isAtom SymbolExpr
_               = Bool
False

  pretty :: SymbolExpr -> Id
pretty (Symbol Id
_ (Char
':':Char
':':Char
':':Id
_) []) = Id
"#"
  pretty (Symbol Id
_ Id
s [])               = Id
s
  pretty (Symbol Id
_ Id
s [Index ScalarData]
js)               = Id
s Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ (Index ScalarData -> Id) -> [Index ScalarData] -> Id
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Index ScalarData -> Id
forall a. Show a => a -> Id
show [Index ScalarData]
js
  pretty (Apply1 ScalarData
fn ScalarData
a1)                = [Id] -> Id
unwords ((ScalarData -> Id) -> [ScalarData] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> Id
forall a. Printable a => a -> Id
pretty' [ScalarData
fn, ScalarData
a1])
  pretty (Apply2 ScalarData
fn ScalarData
a1 ScalarData
a2)             = [Id] -> Id
unwords ((ScalarData -> Id) -> [ScalarData] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> Id
forall a. Printable a => a -> Id
pretty' [ScalarData
fn, ScalarData
a1, ScalarData
a2])
  pretty (Apply3 ScalarData
fn ScalarData
a1 ScalarData
a2 ScalarData
a3)          = [Id] -> Id
unwords ((ScalarData -> Id) -> [ScalarData] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> Id
forall a. Printable a => a -> Id
pretty' [ScalarData
fn, ScalarData
a1, ScalarData
a2, ScalarData
a3])
  pretty (Apply4 ScalarData
fn ScalarData
a1 ScalarData
a2 ScalarData
a3 ScalarData
a4)       = [Id] -> Id
unwords ((ScalarData -> Id) -> [ScalarData] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> Id
forall a. Printable a => a -> Id
pretty' [ScalarData
fn, ScalarData
a1, ScalarData
a2, ScalarData
a3, ScalarData
a4])
  pretty (Quote ScalarData
mExprs)                = Id
"`" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ ScalarData -> Id
forall a. Printable a => a -> Id
pretty' ScalarData
mExprs
  pretty (QuoteFunction WHNFData
whnf)          = Id
"'" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Id -> (Id -> Id) -> Maybe Id -> Id
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Id
"<function>" Id -> Id
forall a. a -> a
id (WHNFData -> Maybe Id
prettyFunctionName WHNFData
whnf)
  pretty (FunctionData ScalarData
name [ScalarData]
args)      = [Id] -> Id
unwords (ScalarData -> Id
forall a. Printable a => a -> Id
pretty ScalarData
name Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: (ScalarData -> Id) -> [ScalarData] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> Id
forall a. Printable a => a -> Id
pretty' [ScalarData]
args)

instance Printable TermExpr where
  isAtom :: TermExpr -> Bool
isAtom (Term Integer
_ [])  = Bool
True
  isAtom (Term Integer
1 [(SymbolExpr, Integer)
_]) = Bool
True
  isAtom TermExpr
_            = Bool
False

  pretty :: TermExpr -> Id
pretty (Term Integer
a [])    = Integer -> Id
forall a. Show a => a -> Id
show Integer
a
  pretty (Term Integer
1 Monomial
xs)    = Id -> [Id] -> Id
forall a. [a] -> [[a]] -> [a]
intercalate Id
" * " (((SymbolExpr, Integer) -> Id) -> Monomial -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolExpr, Integer) -> Id
prettyPoweredSymbol Monomial
xs)
  pretty (Term (-1) Monomial
xs) = Id
"- " Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Id -> [Id] -> Id
forall a. [a] -> [[a]] -> [a]
intercalate Id
" * " (((SymbolExpr, Integer) -> Id) -> Monomial -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolExpr, Integer) -> Id
prettyPoweredSymbol Monomial
xs)
  pretty (Term Integer
a Monomial
xs)    = Id -> [Id] -> Id
forall a. [a] -> [[a]] -> [a]
intercalate Id
" * " (Integer -> Id
forall a. Show a => a -> Id
show Integer
a Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: ((SymbolExpr, Integer) -> Id) -> Monomial -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolExpr, Integer) -> Id
prettyPoweredSymbol Monomial
xs)

prettyPoweredSymbol :: (SymbolExpr, Integer) -> String
prettyPoweredSymbol :: (SymbolExpr, Integer) -> Id
prettyPoweredSymbol (SymbolExpr
x, Integer
1) = SymbolExpr -> Id
forall a. Show a => a -> Id
show SymbolExpr
x
prettyPoweredSymbol (SymbolExpr
x, Integer
n) = SymbolExpr -> Id
forall a. Printable a => a -> Id
pretty' SymbolExpr
x Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Id
"^" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ Integer -> Id
forall a. Show a => a -> Id
show Integer
n

instance Show ScalarData where
  show :: ScalarData -> Id
show = ScalarData -> Id
forall a. Printable a => a -> Id
pretty

instance Show PolyExpr where
  show :: PolyExpr -> Id
show = PolyExpr -> Id
forall a. Printable a => a -> Id
pretty

instance Show TermExpr where
  show :: TermExpr -> Id
show = TermExpr -> Id
forall a. Printable a => a -> Id
pretty

instance Show SymbolExpr where
  show :: SymbolExpr -> Id
show = SymbolExpr -> Id
forall a. Printable a => a -> Id
pretty

instance {-# OVERLAPPING #-} Show (Index ScalarData) where
  show :: Index ScalarData -> Id
show (Sup ScalarData
i)    = Id
"~" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ ScalarData -> Id
forall a. Printable a => a -> Id
pretty' ScalarData
i
  show (Sub ScalarData
i)    = Id
"_" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ ScalarData -> Id
forall a. Printable a => a -> Id
pretty' ScalarData
i
  show (SupSub ScalarData
i) = Id
"~_" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ ScalarData -> Id
forall a. Printable a => a -> Id
pretty' ScalarData
i
  show (DF Integer
_ Integer
_)   = Id
""
  show (User ScalarData
i)   = Id
"|" Id -> Id -> Id
forall a. [a] -> [a] -> [a]
++ ScalarData -> Id
forall a. Printable a => a -> Id
pretty' ScalarData
i