(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\APAI"];
Once[<<KnotTheory`; <<Rot.m];


(* ::Input::Initialization:: *)
CCF[\[ScriptCapitalE]_] := ExpandDenominator@ExpandNumerator@Together[\[ScriptCapitalE]];
CF[\[ScriptCapitalE]_List]:=CF/@\[ScriptCapitalE]; CF[\[ScriptCapitalE]_EPD]:=CF/@\[ScriptCapitalE];
CF[\[ScriptCapitalE]_] := Module[{vs=Cases[\[ScriptCapitalE],Subscript[(x|p), _],\[Infinity]]\[Union]{x,p},ps,c},
Total[CoefficientRules[Expand[\[ScriptCapitalE]], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))] ];
CF[eqp_EQP]:=CF/@eqp


(* ::Input::Initialization:: *)
EQP/:c_*EQP[Q_,P_]:=EQP[Q,CF[c P]];


(* ::Input::Initialization:: *)
{SuperStar[p],SuperStar[x]}={\[Pi],\[Xi]};  SuperStar[(Subscript[z_, i__])]:=Subscript[(SuperStar[z]), i]; SuperStar[vs_List]:=(v|->SuperStar[v])/@vs;
\!\(\*SubscriptBox[\(Zip\), \({}\)]\)[\[ScriptCapitalE]_]:=\[ScriptCapitalE];
\!\(\*SubscriptBox[\(Zip\), \({z_, zs___}\)]\)[\[ScriptCapitalE]_] := (Collect[\[ScriptCapitalE]//\!\(\*SubscriptBox[\(Zip\), \({zs}\)]\),z] /. f_. z^d_.:>(D[f,{SuperStar[z],d}]))/.SuperStar[z]->0


(* ::Input::Initialization:: *)
FI[EQP[Q_,P_]]:=FI[EQP[Q,P],Union@Cases[Q,Subscript[p, _],\[Infinity]],Union@Cases[Q,Subscript[x, _],\[Infinity]]];
FI[EQP[Q_,P_],ps_List,xs_List]:=Module[{u,v},
A=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(u, v\)]Q\),{u,ps},{v,xs}];
Factor[Det[A]^-1 Subscript[Zip, ps\[Union]xs][P E^-SuperStar[xs] . Inverse[A] . SuperStar[ps]]]]


(* ::Input::Initialization:: *)
\[Rho]0i[K_]:=\[Rho]0i[K,False]; \[Rho]0i[Flip@K_]:=\[Rho]0i[K,True];
\[Rho]0i[K_,flip_]:=Module[{Cs,\[CurlyPhi],n,s,i,j,k,vs,Q,Qp},
{Cs,\[CurlyPhi]}=Rot[K]; n=Length[Cs];
If[flip, Cs=Cs[[All,{1,3,2}]]; \[CurlyPhi]=-\[CurlyPhi]];
Q=-Subscript[p, 2n+1] Subscript[x, 2n+1]; Qp=0;
Cases[Cs,{s_,i_,j_}:>(Q-=Subscript[x, i] (Subscript[p, i]-T^s Subscript[p, i+1]+(T^s-1) Subscript[p, j+1])+Subscript[x, j] (Subscript[p, j]-Subscript[p, j+1]); Qp-=s T^(s-1) Subscript[x, i](Subscript[p, j+1]-Subscript[p, i+1]))];
EQP[Q,-T^((Total[\[CurlyPhi]]+Total[Cs[[All,1]]])/2)Qp-(Total[\[CurlyPhi]]+Total[Cs[[All,1]]])T^((Total[\[CurlyPhi]]+Total[Cs[[All,1]]])/2-1)/2]
];


(* ::Input::Initialization:: *)
Subscript[r, 1][s_,i_,j_]:=s (-1+2 Subscript[p, i] Subscript[x, i]-2 Subscript[p, j] Subscript[x, i]+(-1+T^s) Subscript[p, i] Subscript[p, j] \!\(\*SubsuperscriptBox[\(x\), \(i\), \(2\)]\)+(1-T^s) \!\(\*SubsuperscriptBox[\(p\), \(j\), \(2\)]\) \!\(\*SubsuperscriptBox[\(x\), \(i\), \(2\)]\)-2 Subscript[p, i] Subscript[p, j] Subscript[x, i] Subscript[x, j]+2 \!\(\*SubsuperscriptBox[\(p\), \(j\), \(2\)]\) Subscript[x, i] Subscript[x, j])/2;
Subscript[\[Gamma], 1][\[CurlyPhi]_,k_]:=\[CurlyPhi] (1/2-Subscript[p, k] Subscript[x, k]);
\[Rho]1i[K_]:=\[Rho]1i[K,False]; \[Rho]1i[Flip@K_]:=\[Rho]1i[K,True];
\[Rho]1i[K_,flip_]:=Module[{Cs,\[CurlyPhi],n,s,i,j,k,vs,Q,P},
{Cs,\[CurlyPhi]}=Rot[K]; n=Length[Cs];
If[flip, Cs=Cs[[All,{1,3,2}]]; \[CurlyPhi]=-\[CurlyPhi]];
Q=-Subscript[x, 2n+1] Subscript[p, 2n+1];
Cases[Cs,{s_,i_,j_}:>(Q-=Subscript[x, i] (Subscript[p, i]-T^s Subscript[p, i+1]+(T^s-1) Subscript[p, j+1])+Subscript[x, j] (Subscript[p, j]-Subscript[p, j+1]))];
P=Sum[Subscript[r, 1]@@Cs[[k]],{k,n}]+Sum[Subscript[\[Gamma], 1][\[CurlyPhi][[k]],k],{k,2n}];
CF@EQP[Q,P]
];


(* ::Input::Initialization:: *)
Module[{i,j,k},
AllMonomials[{},0]={1};
AllMonomials[{},d_Integer] /; d>0 := {};
AllMonomials[{v_,vs___},d_Integer] := Join@@Table[v^(d-k) AllMonomials[{vs},k],{k,0,d}];
AllMonomials[vs_List, {d_}] := Join@@Table[AllMonomials[vs,k],{k,0,d}];
Basis[js_List,m_]:=Flatten@Outer[Times,AllMonomials[Table[Subscript[p, j],{j,js}],m],AllMonomials[Table[Subscript[x, j],{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,0,m}];
GenericCombination[bas_,c_]:=bas . Table[Subscript[c, j],{j,Length@bas}];
GenericCombination[bas_,Subscript[c_, k_]]:=bas . Table[Subscript[c, k,j],{j,Length@bas}];
]



