CableComponent.m - Revision history

Drorbn at 19:09, 20 October 2013

2013-10-20T19:09:11Z

← Older revision		Revision as of 15:09, 20 October 2013
Line 1:		Line 1:
	(*		(*

	The program <code>CableComponent</code>, documented in the page on [[Cabling]]. It is not part of the package <code>KnotTheory`</code> but is designed to work with it. Use <code><nowiki>Import["http://katlas.org/~~wiki~~/CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the <code>)</code> on the first line and the <code>(</code> on the last.		The program <code>CableComponent</code>, documented in the page on [[Cabling]]. It is not part of the package <code>KnotTheory`</code> but is designed to work with it. Use <code><nowiki>Import["http://katlas.org/w/index.php?title=CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the <code>)</code> on the first line and the <code>(</code> on the last.
	<pre>		<pre>
	*)		*)

IvaH at 00:28, 19 November 2007

2007-11-19T00:28:41Z

← Older revision		Revision as of 20:28, 18 November 2007
Line 1:		Line 1:
	(*		(*

	The program <code>CableComponent</code>, documented in the page on [[Cabling]]. Use <code><nowiki>Import["http://katlas.org/wiki/CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the <code>)</code> on the first line and the <code>(</code> on the last.		The program <code>CableComponent</code>, documented in the page on [[Cabling]]. It is not part of the package <code>KnotTheory`</code> but is designed to work with it. Use <code><nowiki>Import["http://katlas.org/wiki/CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the <code>)</code> on the first line and the <code>(</code> on the last.
	<pre>		<pre>
	*)		*)

Drorbn at 19:54, 8 November 2007

2007-11-08T19:54:21Z

← Older revision		Revision as of 15:54, 8 November 2007
Line 1:		Line 1:
	(*		(*

	The program <code>CableComponent</code>, documented in the page on [[Cabling]]. Use <code><nowiki>Import["http://katlas.org/wiki/CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the (* on the first line and the *) on the last.		The program <code>CableComponent</code>, documented in the page on [[Cabling]]. Use <code><nowiki>Import["http://katlas.org/wiki/CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the <code>)</code> on the first line and the <code>(</code> on the last.
	<pre>		<pre>
	*)		*)

Drorbn at 19:40, 8 November 2007

2007-11-08T19:40:27Z

← Older revision		Revision as of 15:40, 8 November 2007
Line 1:		Line 1:
			(*
⚫	(* <pre> *)

			The program <code>CableComponent</code>, documented in the page on [[Cabling]]. Use <code><nowiki>Import["http://katlas.org/wiki/CableComponent.m&action=raw"]</nowiki></code> to download into a mathematica session, or copy-paste the text below ignoring the (* on the first line and the *) on the last.
		⚫	<pre>
			*)
	CableComponent[BR[n_Integer, js_List], K_] :=		CableComponent[BR[n_Integer, js_List], K_] :=
	Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,		Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,

Drorbn at 19:30, 8 November 2007

2007-11-08T19:30:56Z

← Older revision		Revision as of 15:30, 8 November 2007
Line 1:		Line 1:
			(* <pre> *)
	CableComponent[BR[n_Integer, js_List], K_] :=		CableComponent[BR[n_Integer, js_List], K_] :=
	Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,		Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,
	j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss,		j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss,
Line 75:		Line 76:
	out1 =		out1 =
	PD @@ ( out1 /. ((# -> ++k) & /@ (List @@ Union @@ out1)))]];		PD @@ ( out1 /. ((# -> ++k) & /@ (List @@ Union @@ out1)))]];
			(* </pre> *)

Drorbn at 19:23, 8 November 2007

2007-11-08T19:23:58Z

@@ Line 1: / Line 1: @@
-CableComponent[BR[n_Integer, js_List], K_] :=
+ CableComponent[BR[n_Integer, js_List], K_] :=
   Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,
     j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss,
@@ Line 48: / Line 48: @@
            ] /. {h[i_, 0, _] :> a[i], h[i_, n, _] :> c[i]} /. If[
           d - b == 1 || b - d > 1,
           {v[0, j_, _] :> d[j],
            v[n, j_, _] :> b[j]}, {v[0, j_, _] :> d[n + 1 - j],

Drorbn: New page: CableComponent[BR[n_Integer, js_List], K_] := Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j, j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss, ...

2007-11-08T19:23:09Z

New page: CableComponent[BR[n_Integer, js_List], K_] := Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j, j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss, ...

New page

CableComponent[BR[n_Integer, js_List], K_] :=
Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,
j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss,
t, t0, t1, t2, tj, v, w, writhe},
L = PD[K];
kjs = BR[L][[2]];
For[i1 = 1; writhe = 0, i1 <= Length[kjs], i1++,
writhe = writhe + Sign[kjs[[i1]]]];
For[i2 = 1; jss[0] = js, i2 <= n Abs[writhe], i2++,
jss[i2] =
Flatten[{jss[i2 - 1], Table[-Sign[writhe] e, {e, n - 1}]}]];
k1 = Length[jss[n Abs[writhe]]];
For[i = 1, i <= n, i++, s[i] = a[i] = i];
For[
j = 1, j <= k1, j++,
p = Select[Range[n], Abs[jss[n Abs[writhe]][[j]]] == a[#] &][[
1]];
q = Select[Range[n], a[#] == a[p] + 1 &][[1]];
If[jss[n Abs[writhe]][[j]] > 0,
K[j] = X[s[q], n + 2 j, n + 2 j - 1, s[p]],
K[j] = X[s[p], s[q], n + 2 j, n + 2 j - 1]];
s[p] = n + 2 j;
s[q] = n + 2 j - 1;
a[p]++;
a[q]--
];
BC = Table[K[d], {d, k1}];
If[Jones[L][q] === 1,
For[j1 = 1, j1 <= Length[BC], j1++,
For[i = 1, i <= n, i++, BC[[j1]] = BC[[j1]] /. s[i] :> a[i]
]];
If[BC == {}, BC = {Loop[1]}];
out1 = PD @@ BC,
For[j2 = 1, j2 <= Length[BC], j2++,
For[tj = 1, tj <= n, tj++, BC[[j2]] = BC[[j2]] /. tj :> 1[tj]]
];
p1 = Select[Range[n], # != s[#] &];
S = Select[L, MemberQ[#, 1] && MemberQ[#, 2] & ];
pos = Position[S, 1][[1, 2]];
r = Select[Table[i, {i, Length[L]}], L[[#]] == Flatten @@ S &][[
1]];
k = 0;
out0 = L /. X[a_, b_, c_, d_] :> (
++k;
Table[
X[h[i, j - 1, k], v[i, j, k], h[i, j, k], v[i - 1, j, k]],
{i, n}, {j, n}
] /. {h[i_, 0, _] :> a[i], h[i_, n, _] :> c[i]} /. If[
d - b == 1 || b - d > 1,
{v[0, j_, _] :> d[j],
v[n, j_, _] :> b[j]}, {v[0, j_, _] :> d[n + 1 - j],
v[n, j_, _] :> b[n + 1 - j]}
]
);
w = Flatten@out0[[r]];
out = PD @@ Flatten[Join @@ out0];
ss = Table[a[i], {i, n}][[p1]];
CC1 = List @@ out;
For[t0 = 1, t0 <= Length[ss], t0++,
C0[t0] = Select[w, MemberQ[#, 1[ss[[t0]]]] &];
C1[t0] =
Select[C0[t0],
Mod[Position[#, 1[ss[[t0]]]][[1, 1]], 2] == Mod[pos, 2] &];
C2[t0] =
C1[t0] /. 1[ss[[t0]]] :>
s[Select[Range[n], a[#] == ss[[t0]] &][[1]]]];

CS1 = Flatten[Table[C1[t1], {t1, Length[ss]}]];
CS2 = Flatten[Table[C2[t2], {t2, Length[ss]}]];
For[i = 1, i <= Length[CS1], i++,
CC1 = DeleteCases[CC1, CS1[[i]]]];
out1 = Union[BC, CC1, CS2];
PD @@ out1;
k = 0;
out1 =
PD @@ ( out1 /. ((# -> ++k) & /@ (List @@ Union @@ out1)))]];
$$-->

{{In|
n = 2 |
in = <nowiki>CableComponent[n_integer, K_] := CableComponent[BR[n, {}], K];
CableComponent[BR[n_Integer, js_List], K_] :=
Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j,
j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss,
t, t0, t1, t2, tj, v, w, writhe},
L = PD[K];
kjs = BR[L][[2]];
For[i1 = 1; writhe = 0, i1 <= Length[kjs], i1++,
writhe = writhe + Sign[kjs[[i1]]]];
For[i2 = 1; jss[0] = js, i2 <= n Abs[writhe], i2++,
jss[i2] =
Flatten[{jss[i2 - 1], Table[-Sign[writhe] e, {e, n - 1}]}]];
k1 = Length[jss[n Abs[writhe]]];
For[i = 1, i <= n, i++, s[i] = a[i] = i];
For[
j = 1, j <= k1, j++,
p = Select[Range[n], Abs[jss[n Abs[writhe]][[j]]] == a[#] &][[
1]];
q = Select[Range[n], a[#] == a[p] + 1 &][[1]];
If[jss[n Abs[writhe]][[j]] > 0,
K[j] = X[s[q], n + 2 j, n + 2 j - 1, s[p]],
K[j] = X[s[p], s[q], n + 2 j, n + 2 j - 1]];
s[p] = n + 2 j;
s[q] = n + 2 j - 1;
a[p]++;
a[q]--
];
BC = Table[K[d], {d, k1}];
If[Jones[L][q] === 1,
For[j1 = 1, j1 <= Length[BC], j1++,
For[i = 1, i <= n, i++, BC[[j1]] = BC[[j1]] /. s[i] :> a[i]
]];
If[BC == {}, BC = {Loop[1]}];
out1 = PD @@ BC,
For[j2 = 1, j2 <= Length[BC], j2++,
For[tj = 1, tj <= n, tj++, BC[[j2]] = BC[[j2]] /. tj :> 1[tj]]
];
p1 = Select[Range[n], # != s[#] &];
S = Select[L, MemberQ[#, 1] && MemberQ[#, 2] & ];
pos = Position[S, 1][[1, 2]];
r = Select[Table[i, {i, Length[L]}], L[[#]] == Flatten @@ S &][[
1]];
k = 0;
out0 = L /. X[a_, b_, c_, d_] :> (
++k;
Table[
X[h[i, j - 1, k], v[i, j, k], h[i, j, k], v[i - 1, j, k]],
{i, n}, {j, n}
] /. {h[i_, 0, _] :> a[i], h[i_, n, _] :> c[i]} /. If[
d - b == 1 || b - d > 1,
{v[0, j_, _] :> d[j],
v[n, j_, _] :> b[j]}, {v[0, j_, _] :> d[n + 1 - j],
v[n, j_, _] :> b[n + 1 - j]}
]
);
w = Flatten@out0[[r]];
out = PD @@ Flatten[Join @@ out0];
ss = Table[a[i], {i, n}][[p1]];
CC1 = List @@ out;
For[t0 = 1, t0 <= Length[ss], t0++,
C0[t0] = Select[w, MemberQ[#, 1[ss[[t0]]]] &];
C1[t0] =
Select[C0[t0],
Mod[Position[#, 1[ss[[t0]]]][[1, 1]], 2] == Mod[pos, 2] &];
C2[t0] =
C1[t0] /. 1[ss[[t0]]] :>
s[Select[Range[n], a[#] == ss[[t0]] &][[1]]]];

CS1 = Flatten[Table[C1[t1], {t1, Length[ss]}]];
CS2 = Flatten[Table[C2[t2], {t2, Length[ss]}]];
For[i = 1, i <= Length[CS1], i++,
CC1 = DeleteCases[CC1, CS1[[i]]]];
out1 = Union[BC, CC1, CS2];
PD @@ out1;
k = 0;
out1 =
PD @@ ( out1 /. ((# -> ++k) & /@ (List @@ Union @@ out1)))]];