(************************************************************************) (* *) (* BraidGroup.m *) (* Various calculations in the braid group *) (* *) (* version 2.0 *) (* Joe Christy 10/25/91 *) (* *) (************************************************************************) (* * version 1.0 4/11/90 * * version 1.1 4/30/90 * added RandomBraid, Delta, Unbraid, ProductBraid, InverseBraid * JPC * * version 1.2 7/1/91 * added W(n), after Berge, BraidPower * JPC * * version 1.3 7/16/91 * added TrivialCancellation * JPC * * version 2.0 10/25/91 * various Mathematica 2.0 updates * JPC * *) (* * TO DO * * Implement solutions of word and conjugacy problems * streamline TrivialCancellation * *) BeginPackage["BraidGroup`", "SymmetricGroup`"] Braid::usage = "Braids are represented in the form {cs, s}, where cs is a list of crossings and s is the number of strands. Individual crossings are represented by integers: -n when the nth strand crosses under the n+1st, n when the nth strand crosses over the n+1st." BraidQ::usage = "BraidQ[b] yields True iff b is a legitimate Braid." CrossingToPermutation::usage = "CrossingToPermutation[n] yields the permutation of the strands induced by a single crossing of the Abs[n]th and Abs[n]+1st strands." BraidToPermutation::usage = "BraidToPermutation[b] yields the permutation of the strands induced by the braid b." CrossingNumber::usage = "CrossingNumber[b] returns the number of crossings of the braid b." Braid::bogus = "`` is not a legitimate braid!" RandomBraid::usage = "RandomBraid[c,s] produces a random c-crossing braid on s strands." Delta::usage = "Delta[n] returns a braid representing a positive half twist on n strands." Unbraid::usage = "Unbraid[n] returns the trivial braid on n strands." ProductBraid::usage = "ProductBraid[b1, b2] returns the product of b1 and b2 in the smallest braid group which contains them both." InverseBraid::usage = "InverseBraid[b] returns the inverse of b in the braid group." BraidPower::usage = "BraidPower[b, n] returns the nth power of b in the braid group." W::usage = "W[n, e] returns the nth power of the word {n-1, n-2, ... ,2 , 1}" TrivialCancellation::usage = "TrivialCancellation is a rule that cancels adjacent crossings of the same pair of strands with opposite parity. At present it only supports 100 strands." Begin["`Private`"] (* begin the private context *) BraidQ[b_] := Min[Abs[ b[[1]] ]]>0 && Max[Abs[ b[[1]] ]] < b[[2]] && Map[IntegerQ, b[[1]] ] == Table[True,{Length[b[[1]] ]}] TrivialCancellation = { {foo___,1,-1,bar___} -> {foo,bar}, {foo___,-1,1,bar___} -> {foo,bar}, {foo___,2,-2,bar___} -> {foo,bar}, {foo___,-2,2,bar___} -> {foo,bar}, {foo___,3,-3,bar___} -> {foo,bar}, {foo___,-3,3,bar___} -> {foo,bar}, {foo___,4,-4,bar___} -> {foo,bar}, {foo___,-4,4,bar___} -> {foo,bar}, {foo___,5,-5,bar___} -> {foo,bar}, {foo___,-5,5,bar___} -> {foo,bar}, {foo___,6,-6,bar___} -> {foo,bar}, {foo___,-6,6,bar___} -> {foo,bar}, {foo___,7,-7,bar___} -> {foo,bar}, {foo___,-7,7,bar___} -> {foo,bar}, {foo___,8,-8,bar___} -> {foo,bar}, {foo___,-8,8,bar___} -> {foo,bar}, {foo___,9,-9,bar___} -> {foo,bar}, {foo___,-9,9,bar___} -> {foo,bar}, {foo___,10,-10,bar___} -> {foo,bar}, {foo___,-10,10,bar___} -> {foo,bar}, {foo___,11,-11,bar___} -> {foo,bar}, {foo___,-11,11,bar___} -> {foo,bar}, {foo___,12,-12,bar___} -> {foo,bar}, {foo___,-12,12,bar___} -> {foo,bar}, {foo___,13,-13,bar___} -> {foo,bar}, {foo___,-13,13,bar___} -> {foo,bar}, {foo___,14,-14,bar___} -> {foo,bar}, {foo___,-14,14,bar___} -> {foo,bar}, {foo___,15,-15,bar___} -> {foo,bar}, {foo___,-15,15,bar___} -> {foo,bar}, {foo___,16,-16,bar___} -> {foo,bar}, {foo___,-16,16,bar___} -> {foo,bar}, {foo___,17,-17,bar___} -> {foo,bar}, {foo___,-17,17,bar___} -> {foo,bar}, {foo___,18,-18,bar___} -> {foo,bar}, {foo___,-18,18,bar___} -> {foo,bar}, {foo___,19,-19,bar___} -> {foo,bar}, {foo___,-19,19,bar___} -> {foo,bar}, {foo___,20,-20,bar___} -> {foo,bar}, {foo___,-20,20,bar___} -> {foo,bar}, {foo___,21,-21,bar___} -> {foo,bar}, {foo___,-21,21,bar___} -> {foo,bar}, {foo___,22,-22,bar___} -> {foo,bar}, {foo___,-22,22,bar___} -> {foo,bar}, {foo___,23,-23,bar___} -> {foo,bar}, {foo___,-23,23,bar___} -> {foo,bar}, {foo___,24,-24,bar___} -> {foo,bar}, {foo___,-24,24,bar___} -> {foo,bar}, {foo___,25,-25,bar___} -> {foo,bar}, {foo___,-25,25,bar___} -> {foo,bar}, {foo___,26,-26,bar___} -> {foo,bar}, {foo___,-26,26,bar___} -> {foo,bar}, {foo___,27,-27,bar___} -> {foo,bar}, {foo___,-27,27,bar___} -> {foo,bar}, {foo___,28,-28,bar___} -> {foo,bar}, {foo___,-28,28,bar___} -> {foo,bar}, {foo___,29,-29,bar___} -> {foo,bar}, {foo___,-29,29,bar___} -> {foo,bar}, {foo___,30,-30,bar___} -> {foo,bar}, {foo___,-30,30,bar___} -> {foo,bar}, {foo___,31,-31,bar___} -> {foo,bar}, {foo___,-31,31,bar___} -> {foo,bar}, {foo___,32,-32,bar___} -> {foo,bar}, {foo___,-32,32,bar___} -> {foo,bar}, {foo___,33,-33,bar___} -> {foo,bar}, {foo___,-33,33,bar___} -> {foo,bar}, {foo___,34,-34,bar___} -> {foo,bar}, {foo___,-34,34,bar___} -> {foo,bar}, {foo___,35,-35,bar___} -> {foo,bar}, {foo___,-35,35,bar___} -> {foo,bar}, {foo___,36,-36,bar___} -> {foo,bar}, {foo___,-36,36,bar___} -> {foo,bar}, {foo___,37,-37,bar___} -> {foo,bar}, {foo___,-37,37,bar___} -> {foo,bar}, {foo___,38,-38,bar___} -> {foo,bar}, {foo___,-38,38,bar___} -> {foo,bar}, {foo___,39,-39,bar___} -> {foo,bar}, {foo___,-39,39,bar___} -> {foo,bar}, {foo___,40,-40,bar___} -> {foo,bar}, {foo___,-40,40,bar___} -> {foo,bar}, {foo___,41,-41,bar___} -> {foo,bar}, {foo___,-41,41,bar___} -> {foo,bar}, {foo___,42,-42,bar___} -> {foo,bar}, {foo___,-42,42,bar___} -> {foo,bar}, {foo___,43,-43,bar___} -> {foo,bar}, {foo___,-43,43,bar___} -> {foo,bar}, {foo___,44,-44,bar___} -> {foo,bar}, {foo___,-44,44,bar___} -> {foo,bar}, {foo___,45,-45,bar___} -> {foo,bar}, {foo___,-45,45,bar___} -> {foo,bar}, {foo___,46,-46,bar___} -> {foo,bar}, {foo___,-46,46,bar___} -> {foo,bar}, {foo___,47,-47,bar___} -> {foo,bar}, {foo___,-47,47,bar___} -> {foo,bar}, {foo___,48,-48,bar___} -> {foo,bar}, {foo___,-48,48,bar___} -> {foo,bar}, {foo___,49,-49,bar___} -> {foo,bar}, {foo___,-49,49,bar___} -> {foo,bar}, {foo___,50,-50,bar___} -> {foo,bar}, {foo___,-50,50,bar___} -> {foo,bar}, {foo___,51,-51,bar___} -> {foo,bar}, {foo___,-51,51,bar___} -> {foo,bar}, {foo___,52,-52,bar___} -> {foo,bar}, {foo___,-52,52,bar___} -> {foo,bar}, {foo___,53,-53,bar___} -> {foo,bar}, {foo___,-53,53,bar___} -> {foo,bar}, {foo___,54,-54,bar___} -> {foo,bar}, {foo___,-54,54,bar___} -> {foo,bar}, {foo___,55,-55,bar___} -> {foo,bar}, {foo___,-55,55,bar___} -> {foo,bar}, {foo___,56,-56,bar___} -> {foo,bar}, {foo___,-56,56,bar___} -> {foo,bar}, {foo___,57,-57,bar___} -> {foo,bar}, {foo___,-57,57,bar___} -> {foo,bar}, {foo___,58,-58,bar___} -> {foo,bar}, {foo___,-58,58,bar___} -> {foo,bar}, {foo___,59,-59,bar___} -> {foo,bar}, {foo___,-59,59,bar___} -> {foo,bar}, {foo___,60,-60,bar___} -> {foo,bar}, {foo___,-60,60,bar___} -> {foo,bar}, {foo___,61,-61,bar___} -> {foo,bar}, {foo___,-61,61,bar___} -> {foo,bar}, {foo___,62,-62,bar___} -> {foo,bar}, {foo___,-62,62,bar___} -> {foo,bar}, {foo___,63,-63,bar___} -> {foo,bar}, {foo___,-63,63,bar___} -> {foo,bar}, {foo___,64,-64,bar___} -> {foo,bar}, {foo___,-64,64,bar___} -> {foo,bar}, {foo___,65,-65,bar___} -> {foo,bar}, {foo___,-65,65,bar___} -> {foo,bar}, {foo___,66,-66,bar___} -> {foo,bar}, {foo___,-66,66,bar___} -> {foo,bar}, {foo___,67,-67,bar___} -> {foo,bar}, {foo___,-67,67,bar___} -> {foo,bar}, {foo___,68,-68,bar___} -> {foo,bar}, {foo___,-68,68,bar___} -> {foo,bar}, {foo___,69,-69,bar___} -> {foo,bar}, {foo___,-69,69,bar___} -> {foo,bar}, {foo___,70,-70,bar___} -> {foo,bar}, {foo___,-70,70,bar___} -> {foo,bar}, {foo___,71,-71,bar___} -> {foo,bar}, {foo___,-71,71,bar___} -> {foo,bar}, {foo___,72,-72,bar___} -> {foo,bar}, {foo___,-72,72,bar___} -> {foo,bar}, {foo___,73,-73,bar___} -> {foo,bar}, {foo___,-73,73,bar___} -> {foo,bar}, {foo___,74,-74,bar___} -> {foo,bar}, {foo___,-74,74,bar___} -> {foo,bar}, {foo___,75,-75,bar___} -> {foo,bar}, {foo___,-75,75,bar___} -> {foo,bar}, {foo___,76,-76,bar___} -> {foo,bar}, {foo___,-76,76,bar___} -> {foo,bar}, {foo___,77,-77,bar___} -> {foo,bar}, {foo___,-77,77,bar___} -> {foo,bar}, {foo___,78,-78,bar___} -> {foo,bar}, {foo___,-78,78,bar___} -> {foo,bar}, {foo___,79,-79,bar___} -> {foo,bar}, {foo___,-79,79,bar___} -> {foo,bar}, {foo___,80,-80,bar___} -> {foo,bar}, {foo___,-80,80,bar___} -> {foo,bar}, {foo___,81,-81,bar___} -> {foo,bar}, {foo___,-81,81,bar___} -> {foo,bar}, {foo___,82,-82,bar___} -> {foo,bar}, {foo___,-82,82,bar___} -> {foo,bar}, {foo___,83,-83,bar___} -> {foo,bar}, {foo___,-83,83,bar___} -> {foo,bar}, {foo___,84,-84,bar___} -> {foo,bar}, {foo___,-84,84,bar___} -> {foo,bar}, {foo___,85,-85,bar___} -> {foo,bar}, {foo___,-85,85,bar___} -> {foo,bar}, {foo___,86,-86,bar___} -> {foo,bar}, {foo___,-86,86,bar___} -> {foo,bar}, {foo___,87,-87,bar___} -> {foo,bar}, {foo___,-87,87,bar___} -> {foo,bar}, {foo___,88,-88,bar___} -> {foo,bar}, {foo___,-88,88,bar___} -> {foo,bar}, {foo___,89,-89,bar___} -> {foo,bar}, {foo___,-89,89,bar___} -> {foo,bar}, {foo___,90,-90,bar___} -> {foo,bar}, {foo___,-90,90,bar___} -> {foo,bar}, {foo___,91,-91,bar___} -> {foo,bar}, {foo___,-91,91,bar___} -> {foo,bar}, {foo___,92,-92,bar___} -> {foo,bar}, {foo___,-92,92,bar___} -> {foo,bar}, {foo___,93,-93,bar___} -> {foo,bar}, {foo___,-93,93,bar___} -> {foo,bar}, {foo___,94,-94,bar___} -> {foo,bar}, {foo___,-94,94,bar___} -> {foo,bar}, {foo___,95,-95,bar___} -> {foo,bar}, {foo___,-95,95,bar___} -> {foo,bar}, {foo___,96,-96,bar___} -> {foo,bar}, {foo___,-96,96,bar___} -> {foo,bar}, {foo___,97,-97,bar___} -> {foo,bar}, {foo___,-97,97,bar___} -> {foo,bar}, {foo___,98,-98,bar___} -> {foo,bar}, {foo___,-98,98,bar___} -> {foo,bar}, {foo___,99,-99,bar___} -> {foo,bar}, {foo___,-99,99,bar___} -> {foo,bar} }; (* This is the permutation of the strands induced by a single crossing. *) CrossingToPermutation[n_,s_] := Block[{nn=Abs[n]}, Join[Range[1, nn-1],{nn+1, nn},Range[nn+2,s]] ] CrossingNumber[b_] := Length[ b[[1]] ] /; BraidQ[b] || Message[Braid::bogus, b] BraidToPermutation[b_] := Module[{p = IdentityPermutation[ b[[2]] ], c = CrossingNumber[b]}, For[cn = 1, cn <= c, cn++, p = ProductPermutation[p, CrossingToPermutation[ b[[1]][[cn]], b[[2]] ] ]; ]; Return[p] ] /; BraidQ[b] || Message[Braid::bogus, b] Delta[n_Integer?Positive] := { Flatten[Table[ Table[i, {i, 1, n-j}], {j, 1, n-1} ]], n } Unbraid[n_Integer?Positive] := {{}, n} RandomBraid[c_Integer?Positive, s_Integer?Positive] := {Table[ (2 Random[Integer] - 1) Random[Integer, {1, s-1}], {n,1,c}]//.TrivialCancellation, s} ProductBraid[b1_, b2_] := { Join[ b1[[1]], b2[[1]] ]//.TrivialCancellation, Max[ b1[[2]], b2[[2]] ] } /; (BraidQ[b1] || Message[Braid::bogus, b1]) && (BraidQ[b2]|| Message[Braid::bogus, b2]) ProductBraid[b1_, b2_, theRest__] := Module[{pb=ProductBraid[b1,b2]}, ProductBraid[ pb, theRest] ]/; (BraidQ[b1] || Message[Braid::bogus, b1]) && (BraidQ[b2]|| Message[Braid::bogus, b2]) InverseBraid[b_] := { -1 * Reverse[ b[[1]] ], b[[2]]} /; BraidQ[b] || Message[Braid::bogus, b] BraidPower[ b_, 0] := Unbraid[b[[2]]] /; BraidQ[b] || Message[Braid::bogus, b] BraidPower[ b_, 1] := b /; BraidQ[b] || Message[Braid::bogus, b] BraidPower[ b_, n_Integer?Positive] := ProductBraid[b,BraidPower[b,n-1]] /; BraidQ[b] || Message[Braid::bogus, b] BraidPower[ b_, n_Integer?Negative] := InverseBraid[BraidPower[b, -n]] /; BraidQ[b] || Message[Braid::bogus, b] (* This is Berge's word, cf. Topology & its Apps. 38 p.13 *) W[1, e_Integer] := Unbraid[2] W[n_Integer?Positive, 0] := Unbraid[n] W[n_Integer?Positive, 1] := {Table[n-i,{i,n-1}],n} W[n_Integer?Positive, e_Integer] := BraidPower[W[n,1],e] End[] (* end the private context *) EndPackage[] (* end the package context *)