(* $Id: FoxCalc.m,v 1.5 1998/03/08 00:30:23 tjchol01 Exp $*)

(******************************************************************
 *
 * FoxCalc.m - calculates Fox derivative of a given fundamental
 *             group automorphism, detects a chaos,
 *
 * authors: Rafal Komendarczyk, Waclaw Marzantowicz, Tomasz Cholewo
 *
 ******************************************************************)

BeginPackage["FoxCalc`FoxCalc`","Braids`Braids`"]

Term::usage = "Term[a,b] defines a single generator either of B_n or F_n group, a - is a generator's index, b - is it's power"

Aword::usage = "Aword[Term[a1,b1],Term[a2,b2],... ] represents a list of genertors corresponding to
		the single word in F_n group"

Bword::usage = "Bword[Term[a1,b1],Term[a2,b2],... ] represents a list of genertors corresponding to the single word in B_n group, Bword is also interpreted as the automorphism of fundamental group thus is's values on the given word p can be calculated in the following style: Bword[...][p]"

Char::usage = "Char[a1,a2,a3,...] represents a character which is a homomorphism of F_n to {-1,1} group, ai numbers are either 1 or -1 and represent a values of the character on generators of F_n"

NonCommutativeMultiply::usage = "NonCommutativeMultiply operator is overloaded and accepts Aword lists and Bword lists: b1 ** b2 ** ... ** bn and corresponds to the multiplication in the groups B_n and F_n"

Power::usage = "Power[p,i] returns a power of p, where p is either Bword or Aword in sense of multiplication in B_n and F_n"

ArtinBraid::usage= "ArtinBraid[Aword[...],Aword[...],...] represents a list of words in F_n which are treated as values of so defined automorphism on F_n group generators, where first word corresponds to the value on the first generator and so on ..."

DFox::usage= "DFox[p] calculates a Fox matrix of a given automorphism p, which can be defined as ArinBraid or a Bword"

Norm::usage= "Norm[p] calculates a norm of a given matrix p with coefficients in a Z[F_n] ring"

GenArtinBraid::usage = "GenArinBraid[Bword[...],n] converts a word in B_n (Bword) to an Artin automorphism (ArtinBraid),n denotes a number of generators in F_n"

GenGraphicsBraid::usage = " GenGraphicsBraid[Bword[...],n] converts a word in B_n (Bword) to a list of braid's crossings accepted by package Braids.m."

BChaos::usage = "BChaos[f,c] - first it checks if c is an invariant character and if it is, procedure determine whether braid f (Bword or ArinBraid) implies a chaos. "

ReadBraid::usage ="ReadBraid[filename] - reads files in the obsolete format"

Begin["`Private`"]

Unprotect[NonCommutativeMultiply];

Term[x_Integer]:=Term[x,1];
Term /: NonCommutativeMultiply[Term[x_Integer, ix_Integer], Term[y_Integer, iy_Integer]] := Aword[Term[x, ix + iy]] /; x == y && ix != -iy;
Term /: NonCommutativeMultiply[Term[x_Integer, ix_Integer], Term[y_Integer, iy_Integer]] := Aword[] /; x == y && ix == -iy;
Term /: NonCommutativeMultiply[x_Term, y_Term] := Aword[x, y];
Term /: Power[Term[x_, ix_], y_Integer] := Term[x, ix * y];
Format[Term[x_,xi_]] := StyleForm[Subscripted["a"[x,xi], {1}, {2}],FontSlant->Italic];
Format[Term[x_,1]] := StyleForm[Subscripted["a"[x]],FontSlant->Italic];

NonCommutativeMultiply[x_Term, y_] := NonCommutativeMultiply[Aword[x], y];
NonCommutativeMultiply[x_, y_Term] := NonCommutativeMultiply[x, Aword[y]];

Aword /: NonCommutativeMultiply[x_Aword, Aword[]] := x;
Aword /: NonCommutativeMultiply[Aword[], y_Aword] := y;
Aword /: NonCommutativeMultiply[x_Aword, y_Aword] := NonCommutativeMultiply[Drop[x, -1], Drop[y, 1]] /; (NonCommutativeMultiply[Last[x],First[y]] === Aword[]);
Aword /: NonCommutativeMultiply[x_Aword,y_Plus] := Map[NonCommutativeMultiply[x, #]&,y];
Aword /: NonCommutativeMultiply[x_Aword,Times[xi_Integer,y_Aword]]:=xi NonCommutativeMultiply[x,y];
Aword /: NonCommutativeMultiply[x_Aword, y_Aword] := Join[ Drop[x, -1], NonCommutativeMultiply[Last[x], First[y]], Drop[y, 1]] /; (NonCommutativeMultiply[Last[x],First[y]] =!= Aword[]);
Aword /: NonCommutativeMultiply[x_Aword,m_Integer]:=Times[m,x];
Aword /: NonCommutativeMultiply[m_Integer,x_Aword]:=Times[m,x];
Aword /: Power[x_Aword, y_Integer] := Fold[NonCommutativeMultiply, Aword[], Table[x,{y}]] /; y > 0;
Aword/: Power[x_Aword, y_Integer] := Fold[NonCommutativeMultiply, Aword[],
  Table[Reverse[Map[Power[#, -1]&, x]], {Abs[y]}]] /; y < 0;
Aword /: Plus[x_Aword, Aword[]] := x + 1;
Format[Aword[x___Term]] := SequenceForm[x];

ArtinBraid[x___Aword][y_ArtinBraid] := Map[ArtinBraid[x], y];
ArtinBraid[x___Aword][y_Aword] := Fold[NonCommutativeMultiply, Aword[], Map[ArtinBraid[x], y]];
ArtinBraid[y___Aword][Term[x_, ix_]] := Power[List[y][[x]], ix];
Format[ArtinBraid[x___Aword]] := StyleForm[ColumnForm[MapIndexed[SequenceForm[Subscripted["a"[First[#2]]],
" \[RightArrow] ", #1]&, {x}], Left, Center],FontSlant->Italic];

DFox[Term[x_Integer,ix_Integer],i_Integer]:=0 /; x!=i;
DFox[Term[x_Integer,0],i_Integer]:=0;
DFox[Term[x_Integer,ix_Integer],i_Integer]:=1+NonCommutativeMultiply[Aword[Term[x,1]],DFox[Term[x,ix-1],i]] /; (x==i && ix>0);
DFox[Term[x_Integer,ix_Integer],i_Integer]:= - Aword[Term[x,-1]]+NonCommutativeMultiply[Aword[Term[x,-1]],DFox[Term[x,ix+1],i]] /; (x==i && ix<0);
DFox[Aword[],i_]:=0;
DFox[x_Aword,i_Integer]:=DFox[First[x],i]+NonCommutativeMultiply[First[x],DFox[Drop[x,1],i]];
DFox[x_ArtinBraid]:=Outer[DFox, List @@ x, Range[Length[x]]];
DFox[x_Bword]:=DFox[GenArtinBraid[x]];

Norm[Times[m_Integer,x_Aword]]:=Abs[m];
Norm[x_Aword]:=1;
Norm[x_]:=Map[Norm,x];

Char[y___Integer][Term[x_Integer,ix_Integer]]:=Power[List[y][[x]],ix];
Char[y___Integer][x_Aword]:=Times @@ Map[Char[y],x];
Char[y___Integer][x_]:=Map[Char[y],x];

Bword /: NonCommutativeMultiply[x_Bword, y_Bword] := Bword @@ ((Aword @@ x) ** (Aword @@ y));
Bword /: Power[x_Bword, y_Integer]:=Bword @@ Power[Aword @@ x,y];
Bword[x___Term][y_Aword]:=Last[ComposeList[Map[Apply[SigmaBraid,#]&,{x}],y]];
SigmaBraid[j_Integer,1][Term[x_Integer,xi_Integer]]:=Aword[Term[x,xi]] /; ((j!=x) && ((j+1)!=x));
SigmaBraid[j_Integer,1][Term[x_Integer,xi_Integer]]:=Power[Aword[Term[x,1],Term[x+1,1],Term[x,-1]],xi] /; j==x;
SigmaBraid[j_Integer,1][Term[x_Integer,xi_Integer]]:=Aword[Term[j,xi]] /; j+1==x;
SigmaBraid[j_Integer,-1][Term[x_Integer,xi_Integer]]:=Aword[Term[x,xi]] /; (j!=x) && ((j+1)!=x);
SigmaBraid[j_Integer,-1][Term[x_Integer,xi_Integer]]:=Power[Aword[Term[x,-1],Term[j,1],Term[x,1]],xi] /; (j+1)==x;
SigmaBraid[j_Integer,-1][Term[x_Integer,xi_Integer]]:=Aword[Term[j+1,1]] /; j==x;
SigmaBraid[j_Integer,0][x_]:=Aword[];
SigmaBraid[j_Integer,p_Integer][x_Term]:=Nest[SigmaBraid[j,If[p>0,1,-1]],x,Abs[p]] /; p!=0;
SigmaBraid[j_Integer,p_Integer][x_Aword]:=Fold[NonCommutativeMultiply,Aword[],Map[SigmaBraid[j,p],x]];
Format[x_Bword] := StyleForm[SequenceForm @@ Map[Subscripted["\[Sigma]"[#[[1]],If[#[[2]]!=1,#[[2]],""]],{1},{2}]&,List @@ x],FontSlant->Italic];;

GenArtinBraid[y_Bword,gen_Integer]:=ArtinBraid @@ Map[y,Table[Aword[Term[i,1]],{i,gen}]];
GenGraphicsBraid[x_Bword,gen_Integer]:=List[Flatten[Map[Table[Sign[#[[2]]] #[[1]],{Abs[#[[2]]]}]&,List @@ x]],gen];

BChaos[f_ArtinBraid,ch_Char]:=With[{df=DFox[f]},
 If[ch===Char @@ (ch[f]),
   (Max[Abs[N[Eigenvalues[ch[df]]]]]>1 && Max[Abs[N[Eigenvalues[Norm[df]]]]]>1),
   Print["Not invariant character!"]]];
BChaos[x_Bword,ch_Char,gen_Integer]:=BChaos[GenArtinBraid[x,gen],ch];

ReadBraid[fname_String] := Module[{in,type},
in=ReadList[fname, String]; (* Pruning *)
type=ToExpression[StringJoin["{",StringReplace[First[in]," "->",\""],"\"}"]];
in=Take[Drop[Map[StringReplace[#," "->""]&,ReadList[fname, String]],1],If[type[[2]]=="s",type[[1]],1]]; (*<- Depends of the braid type *)
in=Map[StringReplace[#, {"}{"->"], Term[", "{"->"Term[", "}"->"]", "^"->", "}]&, in];
in=Map[StringJoin["Aword[", #, "]"]&, in];
If[type[[2]]=="s",ArtinBraid @@ Map[ToExpression[#]&, in],Bword @@ First[ToExpression[in]]]
];

End[]
EndPackage[]
(*
 $Log: FoxCalc.m,v $
 Revision 1.5  1998/03/08 00:30:23  tjchol01
  A First Distribution

 Revision 1.4  1998/03/07 22:49:56  tjchol01
 Almost all

 Revision 1.3  1998/03/07 22:26:15  tjchol01
 New version !

 Revision 1.2  1998/03/07 21:20:22  tjchol01
 Start !
*)