<<"TenReS.m"

Basic definitions

Specialization={ℛ->{𝒦,(OverTilde[ℛ])},Φ->{"E",(OverTilde[Φ])}};

CyclicModules={{𝒦,1},{"E",Eval},{D,Diff},{"I",Int}};

Bimodule structure

Prod[a___,b:Diff|Int|Eval,(c_?(Subscript[MemberQ, 𝒦]))Prod[],d___]:=Prod[a,c Prod[],b,d]
Prod[a___,b_?(Subscript[MemberQ, Φ]),(c_?(Subscript[MemberQ, 𝒦]))Prod[],d___]:=Prod[a,c Prod[],b,d]
Prod[a___,b_?(Subscript[MemberQ, ℛ]),(c_?(Subscript[MemberQ, 𝒦]))Prod[],d___]:=Prod[a,mul[b,c],d]
Prod[a___,(b_?(Subscript[MemberQ, 𝒦]))Prod[],(c_?(Subscript[MemberQ, 𝒦]))Prod[],d___]:=Prod[a,mul[b,c]Prod[],d]

Prod[(a_?(Subscript[MemberQ, 𝒦]))Prod[],b_?(Subscript[MemberQ, ℛ]),c___]:=Prod[mul[a,b],c]

Membership checks

Check for constants:

(Subscript[MemberQ, 𝒦])[f_]:=(Diff[f]===0)

Check for membership in the function algebra:

(Subscript[MemberQ, ℛ])[f_?(Subscript[MemberQ, 𝒦])]:=True
(Subscript[MemberQ, ℛ])[ℛ[_Integer]]:=True
(Subscript[MemberQ, ℛ])[Diff[f_?(Subscript[MemberQ, ℛ])]]:=True
(Subscript[MemberQ, ℛ])[Int[f_?(Subscript[MemberQ, ℛ])]]:=True
(Subscript[MemberQ, ℛ])[f_mul]:=And@@((Subscript[MemberQ, ℛ])/@(List@@f))

Check for functionals:

(Subscript[MemberQ, Φ])[Eval]:=True
(Subscript[MemberQ, Φ])[Φ[_Integer]]:=True
(*(Subscript[MemberQ, Φ])[mul[f__/;(Subscript[MemberQ, 𝒦])[mul[f]],φ_?(Subscript[MemberQ, Φ])]]:=True*)

Check for membership in the other cyclic modules:

(Subscript[MemberQ, D])[Diff]:=True

(Subscript[MemberQ, "I"])[Int]:=True

(Subscript[MemberQ, "E"])[Eval]:=True
(Subscript[MemberQ, "E"])[mul[f__/;(Subscript[MemberQ, 𝒦])[mul[f]],Eval]]:=True

Function algebra

Multiplication

mul[a___,b_Plus,c___]:=(mul[a,#,c]&/@b)
mul[a___,b_Integer,c__]:=b mul[a,c]
mul[a__,b_Integer,c___]:=b mul[a,c]
mul[a___,d_Integer*b_,c___]:=d mul[a,b,c]
mul[a___,mul[b__],c___]:=mul[a,b,c]
mul[a_]:=a

Differentiation

Diff[f_?NumericQ]:=0
Diff[(φ_?(Subscript[MemberQ, Φ]))[f_]]:=0
Diff[Int[f_?(Subscript[MemberQ, ℛ])]]:=f
Diff[a_mul]:=Sum[MapAt[Diff,a,i],{i,Length[a]}]

Integration

Int[f_?((Subscript[MemberQ, 𝒦])[#]&&(#=!=1)&)]:=mul[f, Int[1]]
Int[mul[f__,c_?(Subscript[MemberQ, 𝒦])]]:=mul[Int[mul[f]],c]
Int[Diff[f_?(Subscript[MemberQ, ℛ])]]:=f-Eval[f]

Int/:mul[a___,Int[f_],Int[g_],b___]:=mul[a,Int[mul[Int[f],g]],b]+mul[a,Int[mul[f,Int[g]]],b]+mul[a,Eval[Hold[mul[Int[f],Int[g]]]],b]

mul[a___,Int[1],c_?(Subscript[MemberQ, 𝒦]),b___]:=mul[a,c,Int[1],b]

Induced evaluation

Eval[f_?(Subscript[MemberQ, 𝒦])]:=f
Eval[Int[f_?(Subscript[MemberQ, ℛ])]]:=0

Functionals

Φ/:Φ[i_Integer][mul[f__,c_?(Subscript[MemberQ, 𝒦])]]:=mul[Φ[i][mul[f]],c]
Φ/:Φ[i_Integer][mul[c_?(Subscript[MemberQ, 𝒦]),f__]]:=mul[c,Φ[i][mul[f]]]

Φ/:Φ[i_Integer][f_?((Subscript[MemberQ, 𝒦])[#]&&(#=!=1)&)]:=mul[f,Φ[i][1]]
(*Φ/:Φ[i_Integer][f_?((Subscript[MemberQ, 𝒦])[#]&&(#=!=1)&)]:=mul[Φ[i][1],f]*)

mul[a___,Except[Φ[_Integer][1],c_?(Subscript[MemberQ, 𝒦])],Φ[i_Integer][1],b___]:=mul[a,Φ[i][1],c,b]
(*mul[a___,Φ[i_Integer][1],Except[Φ[_Integer][1],c_?(Subscript[MemberQ, 𝒦])],b___]:=mul[a,c,Φ[i][1],b]*)
mul[a___,Φ[j_Integer][1],Φ[i_Integer][1],b___]/;j>i:=mul[a,Φ[i][1],Φ[j][1],b]

Defining reduction system

(Subscript[h, ℛℛ])[f_,g_]:=Prod[mul[f,g]]
(Subscript[h, Dℛ])[Diff,f_]:=Prod[Diff[f]]+Prod[f,Diff]
(Subscript[h, DI])[Diff,Int]:=Prod[]
(Subscript[h, ID])[Int,Diff]:=Prod[]-Prod[Eval]
(Subscript[h, DℛΦ])[Diff,f_,φ_]:=Prod[Diff[f],φ]
(Subscript[h, IℛΦ])[Int,f_,φ_]:=Prod[Int[f],φ]
(Subscript[h, ΦℛΦ])[φ_,f_,ψ_]:=Prod[φ[f]Prod[],ψ]

(Subscript[h, 𝒦])[k_]:=Prod[k Prod[]]

RedSys={{{ℛ,ℛ},(Subscript[h, ℛℛ])},{{D,ℛ},(Subscript[h, Dℛ])},{{D,"I"},(Subscript[h, DI])},{{"I",D},(Subscript[h, ID])},{{D,ℛ,Φ},(Subscript[h, DℛΦ])},{{"I",ℛ,Φ},(Subscript[h, IℛΦ])},{{Φ,ℛ,Φ},(Subscript[h, ΦℛΦ])},{{𝒦},(Subscript[h, 𝒦])}};

Complete reduction system

(Subscript[h, EI])[e_,Int]:=0
(Subscript[h, DΦ])[Diff,φ_]:=0
(Subscript[h, IΦ])[Int,φ_]:=Prod[Int[1],φ]
(Subscript[h, ΦΦ])[φ_,ψ_]:=Prod[φ[1]Prod[],ψ]
(Subscript[h, IℛD])[Int,f_,Diff]:=Prod[f]-Prod[Eval,f]-Prod[Int,Diff[f]]
(Subscript[h, IℛI])[Int,f_,Int]:=Prod[Int[f],Int]-Prod[Int,Int[f]]-Prod[Eval,Int[f],Int]
(Subscript[h, II])[Int,Int]:=Prod[Int[1],Int]-Prod[Int,Int[1]]-Prod[Eval,Int[1],Int]

RedSys={{{𝒦},(Subscript[h, 𝒦])},{{ℛ,ℛ},(Subscript[h, ℛℛ])},{{D,ℛ},(Subscript[h, Dℛ])},{{D,Φ},(Subscript[h, DΦ])},{{D,"I"},(Subscript[h, DI])},{{Φ,ℛ,Φ},(Subscript[h, ΦℛΦ])},{{Φ,Φ},(Subscript[h, ΦΦ])},{{"E","I"},(Subscript[h, EI])},{{"I",ℛ,D},(Subscript[h, IℛD])},{{"I",ℛ,Φ},(Subscript[h, IℛΦ])},{{"I",ℛ,"I"},(Subscript[h, IℛI])},{{"I",D},(Subscript[h, ID])},{{"I",Φ},(Subscript[h, IΦ])},{{"I","I"},(Subscript[h, II])}};

CheckResolvability[RedSys,Count->True,Print->True]

Include multiplicativity of some functionals

New basic definitions

Specialization={ℛ->{𝒦,(OverTilde[ℛ])},Φ->{"E",Φm,(OverTilde[Φ])}};

Membership checks

(Subscript[MemberQ, Φ])[φ_?(Subscript[MemberQ, Φm])]:=True

(Subscript[MemberQ, Φm])[Φm[_Integer]]:=True

Function algebra

Φm/:(Φm[i_Integer])[f_mul]:=Map[Φm[i],f]
Φm/:(Φm[_Integer])[f_?(Subscript[MemberQ, 𝒦])]:=f

Additional reduction rule

(Subscript[h, (Subscript[Φ, m])ℛ])[φ_,f_]:=Prod[φ[f]Prod[],φ]

AppendTo[RedSys,{{Φm,ℛ},(Subscript[h, (Subscript[Φ, m])ℛ])}]

CheckResolvability[RedSys,Count->True]

Multiplicative induced evaluation

Specialization={ℛ->{𝒦,(OverTilde[ℛ])},Φ->{"E",Φm,(OverTilde[Φ])},Φm->{"E"}};

(Subscript[MemberQ, Φm])[Eval]:=True

CheckResolvability[RedSys,Count->True]