(* :Title: Equivalent Words *)

(* :Context: EquivalentWords` *)

(* :Author: Eric Rowland *)
(*          http://math.tulane.edu/~erowland *)

(* :Date: {2009, 9, 19} *)
(* First version written jointly with Bobbe Cooper in July--August 2002. *)

(* :Package Version: 1.11 *)

(* :Mathematica Version: 6.0 *)

(* :Acknowledgement:
	A small portion of this code was originally adapted from a Maple program by Michael Lau:
	"A Computer Implementation of Whitehead's Algorithm", Oregon State University REU, 1997.
*)

(* :Discussion:
	This package contains functions for studying equivalent words in the free group of rank 2.
*)


BeginPackage["EquivalentWords`"]

$AllAutomorphisms::usage =
"$AllAutomorphisms is a list of the eight one\[Hyphen]letter automorphisms on F_2."

$Automorphisms::usage =
"$Automorphisms is a list of the four sufficient one\[Hyphen]letter automorphisms on F_2."

AlternatingWordQ::usage =
"AlternatingWordQ[word] yields True if \*StyleBox[\"word\", \"TI\"] has no adjacent identical letters, and yields False otherwise."

ApplyAutomorphism::usage =
"ApplyAutomorphism[{A, x}, word] applies to \*StyleBox[\"word\", \"TI\"] the Whitehead type II automorphism {A, x}, where \*StyleBox[\"A\", \"TI\"] is a list of generators."

CancelInverses::usage =
"CancelInverses[word] cancels all adjacent inverses in the cyclic word \*StyleBox[\"word\", \"TI\"]."

CanonicalPermutation::usage =
"CanonicalPermutation[word] returns the permutation of \*StyleBox[\"word\", \"TI\"] appearing first in lexicographic order."

Children::usage =
"Children[word] gives the RCP words that immediately descend from (by prepending \"a\" to a cycled permutation of) the RCP word \*StyleBox[\"word\", \"TI\"].
Children[list] gives the RCP words that immediately descend from any word in list."

ClassifyWords::usage =
"ClassifyWords[list] breaks up a list of RCP words of the same length by the weights of the generators and partitions the list into equivalence classes."

CountAndClassifyWords::usage =
"CountAndClassifyWords[n] classifies words of length \*StyleBox[\"n\", \"TI\"] by equivalence class, counts the classes of each size, establishes the root word classes, and counts the root word classes of each size, as well as giving in the first entry statistics about the number of objects considered at each step."

CountWords::usage =
"CountWords[n] counts the classes of length \*StyleBox[\"n\", \"TI\"] words of each size and counts the root word classes of each size, as well as giving in the first entry statistics about the number of objects considered at each step."

EquivalenceClass::usage =
"EquivalenceClass[word] gives a list of all minimal RCP words equivalent to \*StyleBox[\"word\", \"TI\"]."

EquivalentWords::usage =
"EquivalentWords[word] gives a list of cyclically\[Hyphen]reduced words that are equivalent to \*StyleBox[\"word\", \"TI\"], among which are all the minimal RCP words that are equivalent to \*StyleBox[\"word\", \"TI\"]."

EquivalentWordsQ::usage =
"EquivalentWordsQ[word1, word2] yields True if \*StyleBox[\"word1\", \"TI\"] and \*StyleBox[\"word2\", \"TI\"] are equivalent, and yields False otherwise."

ExtendWord::usage =
"ExtendWord[word, n] gives a list of 1\[Hyphen]letter extensions of \*StyleBox[\"word\", \"TI\"] toward RCP\[Hyphen]candidate \*StyleBox[\"n\", \"TI\"]\[Hyphen]letter extensions."

GatherByInvariant::usage =
"GatherByInvariant is an option for ClassifyWords that specifies whether a list of words should first be classified by minimum generator weight before being classified by equivalence class."

InverseGenerator::usage =
"InverseGenerator[generator] gives the inverses of the generators \"a\", \"b\", \"A\", and \"B\"."

MinimalWordQ::usage =
"MinimalWordQ[word] yields True if \*StyleBox[\"word\", \"TI\"] is of minimal length in its equivalence class, and yields False otherwise."

OneLetterAutomorphismEquivalentWords::usage =
"OneLetterAutomorphismEquivalentWords[word] gives a list of all words equivalent to \*StyleBox[\"word\", \"TI\"] under a cycle or under a single Whitehead type II automorphism that does not increase its length."

ProvablyIsolatedWordQ::usage =
"ProvablyIsolatedWordQ[word] yields True if \*StyleBox[\"word\", \"TI\"] can be proved to be isolated by counting syllables, and yields False otherwise.
(A value of False therefore does not necessarily imply that the word is not isolated.)"

RCPCandidates::usage =
"RCPCandidates[n] gives a list of (not necessarily minimal) RCP\[Hyphen]candidate words of length \*StyleBox[\"n\", \"TI\"].
RCPCandidates[word, n] gives a list of (not necessarily minimal) RCP\[Hyphen]candidate \*StyleBox[\"n\", \"TI\"]\[Hyphen]letter extensions of \*StyleBox[\"word\", \"TI\"].
RCPCandidates[list, n] extends a list of words."

RCPRepresentative::usage =
"RCPRepresentative[word] returns the first in a lexicographic ordering of all cycled permutations of \*StyleBox[\"word\", \"TI\"]."

RCPWords::usage =
"RCPWords[n] gives a list of all minimal RCP words of length \*StyleBox[\"n\", \"TI\"]."

RootWordClasses::usage =
"RootWordClasses[n] gives the equivalence classes of all RCP root words of length \*StyleBox[\"n\", \"TI\"]."

RootWordQ::usage =
"RootWordQ[word] yields True if \*StyleBox[\"word\", \"TI\"] is a root word, and yields False otherwise."

RootWords::usage =
"RootWords[n] gives a list of all RCP root words of length \*StyleBox[\"n\", \"TI\"]."

RunLengths::usage =
"RunLengths[word] lists the lengths of runs of consecutive letters in \*StyleBox[\"word\", \"TI\"]."

SortWords::usage =
"SortWords[list] sorts a list of words according to the ordering \"a\", \"b\", \"A\", \"B\"."

SyllableCount::usage =
"SyllableCount[word, syllable] gives the number of occurences of a syllable and its inverse in \*StyleBox[\"word\", \"TI\"]."

WordEquivalenceClasses::usage =
"WordEquivalenceClasses[n] gives the equivalence classes of all RCP words of length \*StyleBox[\"n\", \"TI\"].
WordEquivalenceClasses[n, i] givies the equivalence classes of all RCP words of length \*StyleBox[\"n\", \"TI\"] whose minimal generator weight is \*StyleBox[\"i\", \"TI\"]."


Unprotect["EquivalentWords`*"]

Begin["`Private`"]

If[$VersionNumber < 6,
	Accumulate[list_List] := Rest[FoldList[Plus, 0, list]];
	Divisible[n_, m_] := Mod[n, m] == 0;
	Tally[list_] := {#[[1]], Length[#]} & /@ Split[Sort[list]]
]

StringRotateRight[string_String, n_Integer] :=
	StringTake[string, {Mod[-n + 1, StringLength[string], 1], -1}] <> StringTake[string, Mod[-n, StringLength[string]]]


$AllAutomorphisms =
{{{"a"}, "b"}, {{"a"}, "B"}, {{"b"}, "a"}, {{"b"}, "A"},
 {{"A"}, "b"}, {{"A"}, "B"}, {{"B"}, "a"}, {{"B"}, "A"}}

$Automorphisms =
{{{"a"}, "b"}, {{"a"}, "B"}, {{"b"}, "a"}, {{"b"}, "A"}}

InverseGenerator["a"] = "A"
InverseGenerator["b"] = "B"
InverseGenerator["A"] = "a"
InverseGenerator["B"] = "b"

RunLengths[word_String] := Length /@ Split[Characters[word]]

AlternatingWordQ[word_String] := Max[RunLengths[word]] <= 1

SortWords[words_List] :=
StringReplace[
	Sort[StringReplace[words, {"A" -> "y", "B" -> "z"}]],
	{"y" -> "A", "z" -> "B"}
]

SyllableCount["", syllable_String] := 0
SyllableCount[word_String, syllable_String] :=
StringCount[
	word <> StringTake[word, StringLength[syllable] - 1],
	syllable | StringJoin[InverseGenerator /@ Reverse[Characters[syllable]]],
	Overlaps -> True
]

CancelInverses[word_String] :=
FixedPoint[
	StringReplace[#, {
		StartOfString ~~ "a" ~~ x___ ~~ "A" ~~ EndOfString :> x,
		StartOfString ~~ "b" ~~ x___ ~~ "B" ~~ EndOfString :> x,
		StartOfString ~~ "A" ~~ x___ ~~ "a" ~~ EndOfString :> x,
		StartOfString ~~ "B" ~~ x___ ~~ "b" ~~ EndOfString :> x
	}] &,
	FixedPoint[
		StringReplace[#,
			{"aA" -> "", "bB" -> "", "Aa" -> "", "Bb" -> ""}
		] &,
		word
	]
]

CanonicalPermutation[""] = ""
CanonicalPermutation[word_String] :=
With[{position = First /@ StringPosition[word, Except[StringTake[word, {1}]], 1]},
	If[position != {},
		StringReplace[word, {
			StringTake[word, {1}] -> "a",
			InverseGenerator[StringTake[word, {1}]] -> "A",
			StringTake[word, {First[position]}] -> "b",
			InverseGenerator[StringTake[word, {First[position]}]] -> "B"
		}],
		StringJoin[ConstantArray["a", StringLength[word]]]
	]
]

RCPRepresentative[""] = ""
RCPRepresentative[word_String] :=
Module[{runlengths = RunLengths[word], w},
	If[StringTake[word, {1}] == StringTake[word, {-1}] && Length[runlengths] > 1,
		w = StringRotateRight[word, Last[runlengths]];
		runlengths = Prepend[Take[runlengths, {2, -2}], First[runlengths] + Last[runlengths]],
		w = word
	];
	First[SortWords[
		CanonicalPermutation[StringRotateRight[w, -#]] & /@ 
			Accumulate[runlengths][[
				(Flatten[Position[runlengths, Max[runlengths]]] - 1) /. 0 -> -1
			]]
	]]
]

ExtendWord[word_String, n_Integer?Positive] :=
Module[{letters},
	If[StringCount[word, "b"] == 0,
		letters = {"a", "b"},
		letters = DeleteCases[{"a", "b", "A", "B"}, InverseGenerator[StringTake[word, {-1}]]];
		If[(First[#] == Last[#] &) @ RunLengths[word],
			letters = DeleteCases[letters, StringTake[word, {-1}]]];
		If[n == 1, letters = DeleteCases[letters, "a" | "A"]]
	];
	(word <> # &) /@ letters
]

RCPCandidates[n_Integer?NonNegative] :=
Which[
	n == 0, {""},
	n == 1 || Divisible[n, 4], RCPCandidates[{"a"}, n - 1],
	True, RCPCandidates[{"aa"}, n - 2]
]
RCPCandidates[word_String, n_Integer?NonNegative] := RCPCandidates[{word}, n]
RCPCandidates[words_List, 0] := words
RCPCandidates[words_List, n_Integer?Positive] :=
	RCPCandidates[Flatten[ExtendWord[#, n] & /@ words], n - 1]

ApplyAutomorphism[{{y_String}, x_String}, word_String] :=
CancelInverses[StringReplace[word, {
	y -> y <> x,
	InverseGenerator[y] -> InverseGenerator[x] <> InverseGenerator[y]
}]]
ApplyAutomorphism[{A_List, x_String}, word_String] :=
CancelInverses[StringReplace[
	word,
	# -> If[MemberQ[A, InverseGenerator[#]], InverseGenerator[x], ""] <> # <> If[MemberQ[A, #], x, ""] & /@
		{"a", "b", "A", "B"}
]]

OneLetterAutomorphismEquivalentWords[word_String] :=
Union[
	StringRotateRight[word, #] & /@ Range[StringLength[word] - 1],
	Select[
		ApplyAutomorphism[#, word] & /@ $Automorphisms,
		StringLength[#] <= StringLength[word] &
	]
]

EquivalentWords[word_String] :=
Module[{words = {word}, oldwords, newwords = {word}},
	While[newwords != {},
		oldwords = words;
		words = Union[words, Sequence @@ OneLetterAutomorphismEquivalentWords /@ newwords];
		newwords = Complement[words, oldwords]
	];
	Union[CanonicalPermutation /@ words]
]

(* This is usually being used to classify words with the same minimum generator weight. *)
classifySameLengthWords[list_List] :=
Module[{classes = {}, words = list, class},
	While[words != {},
		class = Intersection[words, EquivalentWords[First[words]]];
		AppendTo[classes, class];
		words = Complement[words, class]
	];
	classes
]

ClassifyWords[list_List /; Equal @@ StringLength /@ list, opts___?OptionQ] :=
Module[{isolated},
	isolated = Select[list, ProvablyIsolatedWordQ];
	StringReplace[#, {"y" -> "A", "z" -> "B"}] & /@ Sort[Join[
		List /@ isolated,
		Sort[StringReplace[#, {"A" -> "y", "B" -> "z"}]] & /@
			If[TrueQ[GatherByInvariant /. {opts} /. Options[ClassifyWords]],
				Flatten[classifySameLengthWords /@ Map[
					Last,
					Split[
						Sort[
							{Min[SyllableCount[#, "a"], SyllableCount[#, "b"]], #} & /@
								Complement[list, isolated]
						],
						Equal @@ First /@ {##} &
					],
					{2}
				], 1],
				classifySameLengthWords[Complement[list, isolated]]
			]
	]]
]
Options[ClassifyWords] = {GatherByInvariant -> True}

ProvablyIsolatedWordQ[word_String] := CancelInverses[word] == word &&
Abs[SyllableCount[word, "ab"] - SyllableCount[word, "aB"]] <
	Min[SyllableCount[word, "aa"], SyllableCount[word, "bb"]]

MinimalWordQ[word_String] := CancelInverses[word] == word &&
Abs[SyllableCount[word, "ab"] - SyllableCount[word, "aB"]] <=
	Min[SyllableCount[word, "aa"], SyllableCount[word, "bb"]]

RootWordQ[word_String] := CancelInverses[word] == word &&
Abs[SyllableCount[word, "ab"] - SyllableCount[word, "aB"]] ==
	SyllableCount[word, "aa"] == SyllableCount[word, "bb"]

RCPWords[n_Integer?NonNegative] :=
Union[RCPRepresentative /@ Select[RCPCandidates[n], MinimalWordQ]]

WordEquivalenceClasses[n_Integer?NonNegative] := ClassifyWords[RCPWords[n]]
WordEquivalenceClasses[n_Integer?NonNegative, i_Integer?NonNegative] :=
ClassifyWords[
	Select[RCPWords[n], Min[SyllableCount[#, "a"], SyllableCount[#, "b"]] == i &],
	GatherByInvariant -> False
]

RootWords[n_Integer?NonNegative] :=
Union[RCPRepresentative /@ Select[RCPCandidates[n], RootWordQ]]

RootWordClasses[n_Integer?NonNegative] := ClassifyWords[RootWords[n]]

CountWords[n_Integer?NonNegative] :=
Module[{originalwords, rcpwords, equivalenceclasses, rootwordclasses},
	originalwords = RCPCandidates[n];
	rcpwords = Union[RCPRepresentative /@ Select[originalwords, MinimalWordQ]];
	equivalenceclasses = ClassifyWords[rcpwords];
	rootwordclasses = Select[equivalenceclasses, RootWordQ[First[#]] &];
	{
		{
			Length[originalwords],
			Length[rcpwords],
			Length[equivalenceclasses],
			Length[Flatten[rootwordclasses]],
			Length[rootwordclasses]
		},
		Tally[Length /@ equivalenceclasses],
		Tally[Length /@ rootwordclasses]
	}
]

CountAndClassifyWords[n_Integer?NonNegative] :=
Module[{originalwords, rcpwords, equivalenceclasses, rootwordclasses},
	originalwords = RCPCandidates[n];
	rcpwords = Union[RCPRepresentative /@ Select[originalwords, MinimalWordQ]];
	equivalenceclasses = ClassifyWords[rcpwords];
	rootwordclasses = Select[equivalenceclasses, RootWordQ[First[#]] &];
	{
		{
			Length[originalwords],
			Length[rcpwords],
			Length[equivalenceclasses],
			Length[Flatten[rootwordclasses]],
			Length[rootwordclasses]
		},
		Tally[Length /@ equivalenceclasses],
		Tally[Length /@ rootwordclasses],
		equivalenceclasses,
		rootwordclasses
	}
]

EquivalenceClass[word_] :=
SortWords[Select[Union[RCPRepresentative /@ EquivalentWords[word]], MinimalWordQ]]

EquivalentWordsQ[word1_String, word2_String] := EquivalenceClass[word1] == EquivalenceClass[word2]

Children[word_String] := Children[{word}]
Children[words_List] :=
Union @@ Function[
	word,
	RCPRepresentative["a" <>
		CanonicalPermutation[StringRotateRight[word, #]]
	] & /@ Accumulate[Reverse[RunLengths[word]]]
] /@ words


End[]

Protect["EquivalentWords`*"]

EndPackage[]