(* ::Package:: *)

(* ::Title:: *)
(*程序包*)


(* ::Chapter:: *)
(*Begin*)


Begin["Tensor`"]


(* ::Chapter:: *)
(*具体计算封装*)


(* ::Section:: *)
(*定义封装*)


(* ::Subsection:: *)
(*Operator*)


(* ::Subsubsection:: *)
(*定义子值*)


Operator[op:Except[_List]][exprs_List] := op/@exprs

Operator[ops_List][expr:Except[_List]] := #@expr&/@ops

Operator[ops_List][exprs_List] := Outer[Construct, ops, exprs]


(* ::Subsubsection:: *)
(*定义输出格式*)


Operator /: MakeBoxes[Operator[ops_], form_] := MakeBoxes[ops, form]


(* ::Subsection:: *)
(*DerivativeOperator*)


(* ::Subsubsection:: *)
(*定义子值*)


DerivativeOperator[var_][expr_] := D[expr, var]


(* ::Subsubsection:: *)
(*定义输出格式*)


DerivativeOperator /: MakeBoxes[DerivativeOperator@var_, form_] := SubscriptBox["\[PartialD]", MakeBoxes[var, form]]


(* ::Subsubsection:: *)
(*定义输入格式*)


(* ::Text:: *)
(*没必要*)


(* ::Subsubsection:: *)
(*测试*)


DerivativeOperator[x]
DerivativeOperator[x][x^2]


(* ::Subsection:: *)
(*DelOperator*)


(* ::Subsubsection:: *)
(*定义下值*)


DelOperator[l_List] := DerivativeOperator /@ l //Operator


(* ::Subsubsection:: *)
(*定义输入格式*)


(* ::Text:: *)
(*不去修改内置定义的 Del ，而是定义 EmptyDownTriangle 。*)


SetOptions[$FrontEndSession, InputAliases -> {"nab" -> "\[EmptyDownTriangle]"}]


MakeExpression[SubscriptBox["\[EmptyDownTriangle]", box_], StandardForm] := HoldComplete@DelOperator@# &@ToExpression[box, StandardForm]


(* ::Subsubsection:: *)
(*测试*)


\!\(\*SubscriptBox[\(\[EmptyDownTriangle]\), \({x, y, z}\)]\)@f
Subscript[\[EmptyDownTriangle], v].f
\!\(\*SubscriptBox[\(\[EmptyDownTriangle]\), \({x, y, z}\)]\)\[CenterDot]f


\!\(\*SubscriptBox[\(\[EmptyDownTriangle]\), \({x, y, z}\)]\)@Through@{f,g,h}[x,y,z]
Grad[Through@{f,g,h}[x,y,z],{x,y,z}]
Outer[D,Through@{f,g,h}[x,y,z],{x,y,z}]


(* ::Subsection:: *)
(*CenterDot*)


(* ::Text:: *)
(*不去修改 Dot 的内置定义，而是利用空置定义的 CenterDot 。*)


(* ::Subsubsection:: *)
(*定义下值*)


CenterDot[Operator[ops_], l_List] := Inner[Construct, ops, l]

CenterDot[l_List, Operator[ops_List]] := Operator@Inner[
	Function[{expr, func}, Composition[expr*#&, func]],
	l,
	ops,
	Function[{arg}, Through@Plus[##]@arg]&
]

CenterDot[Operator[ops1_List], Operator[ops2_List]] := Operator@Inner[Composition, ops1, ops2]

CenterDot[l1_List, l2_List] := Inner[Times, l1, l2]

(* 从右向左结合 *)
CenterDot[args:Repeated[_, {3, Infinity}]] := Fold[CenterDot[#2,#1] &]@Reverse@{args}


(* ::Text:: *)
(*如果对 Calculate@CenterDot[___] 进行定义，即可保持表达式的抽象性，仅当进行替换 expr /.c_CenterDot -> Calculate@c，以上定义才生效。张量表达式的抽象性有利于代数化简，尤其是维度未知的情况。*)


(* ::Subsubsection:: *)
(*测试*)


DelOperator[{x,y,z}]\[CenterDot]{x^2+y^2, x^2+y^2, z^2}
Div[{x^2+y^2, x^2+y^2, z^2},{x,y,z}]


\!\(\*SubscriptBox[\(\[EmptyDownTriangle]\), \({x, y, z}\)]\).{x^2+y^2, x^2+y^2, z^2}
Subscript[\[EmptyDownTriangle], v]\[CenterDot]{x^2+y^2, x^2+y^2, z^2}
Block[{v={x,y,z}}, %]


DelOperator[{x,y,z}]\[CenterDot]({
 {a, b, c},
 {d, e, f},
 {x, y, z}
})\[CenterDot]{x^2+y^2, x^2+y^2, z^2}


(DelOperator[{x,y,z}]\[CenterDot]({
 {a, b, c},
 {d, e, f},
 {x, y, z}
}))\[CenterDot]{x^2+y^2, x^2+y^2, z^2}


(* ::Subsection:: *)
(*Tensor`Cross*)


(* ::Subsubsection:: *)
(*定义下值*)


(* ::Text:: *)
(*定义广义向量积*)


Tensor`GeneralizedCross[head_, l1_List, l2_List] := With[{len = Length@l1},
	If[len > 3, Identity, Normal]@TensorContract[
		Outer[Times, LeviCivitaTensor@len, Outer[head, l1, l2]]
	, {{1,5},{3,4}}]
]


(* ::Text:: *)
(*测试此广义向量积函数*)


Tensor`GeneralizedCross[Construct, {a,b,c}, {x,y,z}]


Tensor`Cross[Operator[ops_List], l_List] := GeneralizedCross[Construct, ops, l]

Tensor`Cross[l_List, Operator[ops_List]] := Operator@GeneralizedCross[Function[{expr, func}, Composition[expr*#&, func]], l, ops]

Tensor`Cross[Operator[ops1_List], Operator[ops2_List]] := Operator@GeneralizedCross[Composition, ops1, ops2]

Tensor`Cross[l1_List, l2_List] := GeneralizedCross[Times, l1, l2]

(* 从右向左结合 *)
Tensor`Cross[args:Repeated[_, {3, Infinity}]] := Fold[Tensor`Cross[#2,#1] &]@Reverse@{args}


(* ::Subsubsection:: *)
(*定义输出格式*)


Tensor`Cross /: MakeBoxes[Tensor`Cross[args___], form_] := MakeBoxes[System`Cross[args], form]


(* ::Subsubsection:: *)
(*定义输入格式*)


MakeExpression[RowBox@{left_, "\[Cross]", right_}, StandardForm] := HoldComplete@*Tensor`Cross @@ (ToExpression[#, StandardForm]&/@{left, right})


(* ::Subsubsection:: *)
(*测试*)


\!\(\*SubscriptBox[\(\[EmptyDownTriangle]\), \({x, y, z}\)]\)\[Cross]{x,y,z}
Grad[{x,y,z},{x,y,z}]


(* ::Chapter:: *)
(*抽象计算封装*)


(* ::Text:: *)
(*尚未实现*)


(* ::Chapter:: *)
(*End*)


End[]


(* ::Title:: *)
(*其他*)


(* ::Chapter:: *)
(*测试*)


(* ::Text:: *)
(*在三维验证*)
(*\[Del](A.B)=B\[Cross](\[Del]\[Cross]A)+A\[Cross](\[Del]\[Cross]B)+(A.\[Del])B+(B.\[Del])A*)


r = {x,y,z}
A = Array[a[#]@@r&, 3]
B = Array[b[#]@@r&, 3]


B\[Cross](Subscript[\[EmptyDownTriangle], r]\[Cross]A)+A\[Cross](Subscript[\[EmptyDownTriangle], r]\[Cross]B)+(A\[CenterDot]Subscript[\[EmptyDownTriangle], r])@B+(B\[CenterDot]Subscript[\[EmptyDownTriangle], r])@A-Subscript[\[EmptyDownTriangle], r]@(A\[CenterDot]B) //Simplify


(* ::Chapter:: *)
(*清除定义*)


Remove@"Tensor`*"
ClearAll@CenterDot
TagUnset[MakeExpression, #]& /@ Keys@FormatValues@MakeExpression