Mathematica: unable to format isomorphic expression

[jackmell]

I can't figure out how to format a variable isomorphic expression in Mathematica so that it will look nice. The best I can do will put parentheses around everything and expand powers. For example, given the array $\{2,4,4,3,3\}$, I'd like Mathematica to write:

$\mathbb{Z}_2\times\mathbb{Z}_{2^2}\times \mathbb{Z}_{2^2}\times \mathbb{Z}_3\times \mathbb{Z}_3$

but the subscripts and number of them would be variable. This code:

mySubscripts = {2, 2^4, 2^4, 3, 3};
expression =
  SubscriptBox["\[DoubleStruckCapitalZ]", mySubscripts[[1]]] //
  DisplayForm;
For[i = 2, i <= Length[mySubscripts], i++,
  expression =
  expression \[Cross]SubscriptBox["\[DoubleStruckCapitalZ]",
  mySubscripts[[i]]] // DisplayForm;
  ];
Style[expression, 40]

will output

$(((\mathbb{Z}_2\times\mathbb{Z}_{16})\times\mathbb{Z}_{16})\times\mathbb{Z}_3\times\mathbb{Z}_3$. and that's not ok; I need to keep the exponents in their un-expanded format like $2^2$, and also separate the prime powers and eliminate the parenthesis or preferably, put parenthesis only around like prime powers . Is there anyway to modify my code so that the output will look like the first format? If I try to convert everything to strings, the subscripts are much too low and don't look nice. Basically, my objective is to construct an isomorphic expression like above for variable $n=p_1^{e_1}p_2^{e_2}\cdots p_n^{e_n}$

Ok thanks for reading,
Jack

 

[kontejnjer]

I'll admit, this one caused me a headache since Mathematica, while being pretty versatile, isn't exactly the ultimate typesetting software. That being said, the shortest version I could come up with is:

mySubscripts = HoldForm/@Unevaluated@{2, 2^4, 2^4, 3, 3};
StringJoin[
ToString[DisplayForm[
  Style[(Riffle[
  SubscriptBox["\[DoubleStruckCapitalZ]",
  mySubscripts[[#]]] & /@ Range@Length@mySubscripts,
  "\[Cross]"])[[#]], FontSize -> 40]],
  FormatType -> StandardForm] & /@
  Range@Length@(Riffle[
  SubscriptBox["\[DoubleStruckCapitalZ]", mySubscripts[[#]]] & /@
  Range@Length@mySubscripts, "\[Cross]"])]

I'm convinced this could be somehow shortened using Apply or Thread (MapThread maybe?), but I've gotten used to (ab)using Map at every chance I get. As you can see, there's no need to initialize the first element at all, and it's easy to generalize to superscripts as well, or anything really.

I also modified your code to get a deceptively shorter solution with a Do loop, but it's ridiculous when viewed with FullForm, so I decided to go with the above since it's simpler and doesn't compound expressions. Here's the iterative code for completeness:

Do[expression =
  ToString[DisplayForm@expression, FormatType -> StandardForm] <>
  "\[Cross]" <>
  ToString[
  DisplayForm@
  SubscriptBox["\[DoubleStruckCapitalZ]", mySubscripts[[i]]],
  FormatType -> StandardForm], {i, 2, Length[mySubscripts]}];
Style[expression, FontSize->40]

However, if you try to evaluate this with even as little as 15 subscripts (say, set mySubscripts=Range@15), it will take very long to evaluate (70 secs on my computer), while the first solution takes about 0.006 seconds. Hope this helps.

EDIT:
Using Apply makes it an order of magnitude faster, not to mention way more concise:

Style[StringJoin[
  ToString[Subscript[#1, #2], FormatType -> StandardForm] & @@@
  Riffle[Subscript["\[DoubleStruckCapitalZ]", mySubscripts[[#]]] & /@
  Range@Length@mySubscripts, "\[Cross]"]], FontSize -> 40]

 

[jackmell]

Ok, that's really outstanding Konte. And I've worked on it quite a bunch also but could not get it the way I want. Here's an example of what I would like Mathematica to print out:
$\begin{array}{ccc} \mathbb{Z}_{455}^* & \cong & \mathbb{Z}_{5}^*\times\mathbb{Z}_{7}^*\times\mathbb{Z}_{13}^* \\ \text{} & \cong & \mathbb{Z}_4\times \mathbb{Z}_6\times \mathbb{Z}_{12} \\ \text{} & \cong & \left(\mathbb{Z}_{2^1}\times \mathbb{Z}_{2^2}\times \mathbb{Z}_{2^2}\right)\times \left(\mathbb{Z}_{3^1}\times \mathbb{Z}_{3^1}\right)=G_2\times G_3 \\ \end{array}$
and I've already coded the factoring of the unit group into these three sets of groups but can't get the output formatted correctly.

Some notes:

(1) The first line are unit groups and need ths asterisks. However the subscript number could be quite large and Mathematica places the asterisk above and at the end of the number and not close to the $\mathbb{Z}$ like latex. Would be nice if we could format the first line like latex does, for example $\mathbb{Z}_{50427}^*$.

(2) The third line needs to keep the subscript powers unevaluated to make this visually instructive (in terms of Sylow p-subgroups and the paper referenced in the link below), and also the algorithm used to compute the automorphisms relies on this format. See thread:
https://www.physicsforums.com/threads/finding-number-of-automorphisms-for-z-nz.814038/

Now, these powers are obtained by factoring integers and as you know Mathematica formats this as an array of the base and exponents. For example, factoring $\mathbb{Z}_{12}$ produces:

In[34]:= n = 12
primeSets = FactorInteger[n]

Out[34]= 12

Out[35]= {{2, 2}, {3, 1}}

and when I attempt to substitute this array into your code, it gets evaluated:

In[41]:= primePowers = {};
For[i = 1, i <= Length[primeSets], i++,
  primePowers = Append[primePowers, Unevaluated[
  primeSets[[i, 1]]^primeSets[[i, 2]]]]; ];
primePowersOut[43]= {4, 3}

Might you be able to help me with this part? Tell you what, if you help me with this and we can get it perfect enough for a Wolfram demonstration, then I will commit to the arduous and life-draining task of constructing one and submitting it so that we can benefit humanity by contributing to math education as I think this would be helpful to students of Abstract Algebra and the demonstration product does not have one like this. Or we can work on the demonstration here and I'll cite everyone. Also, I've already coded the algorithm to compute the automorphisms as a function of $\mathbb{Z}_n^*$ so all I would have left is to get the isomorphic expression (the three line expression above) formatted correctly (then of course encapsulate it in a Manipulate, and a few other GUI things but nothing major I think).

Ok thanks,
Jack

 

[kontejnjer]

I'm not very familiar with abstract algebra, so I don't know how the subscripts in the second row are related to those in the first, but here's what I came up with:

Module[
{n = (*the number to factor*)},
Style[
  ToString[Subsuperscript["\[DoubleStruckCapitalZ]", n, "*"],FormatType -> StandardForm]
  <> "\[TildeFullEqual]" <>
  StringJoin[
  ToString[Subsuperscript[#1, #2, #3], FormatType -> StandardForm] & @@@
  Riffle[
  Subsuperscript["\[DoubleStruckCapitalZ]",
  If[FactorInteger[n][[#, 2]] > 1 (*this is optional, it's used so it doesn't display the exponent if it's 1*),
  Superscript[FactorInteger[n][[#, 1]],FactorInteger[n][[#, 2]]],
FactorInteger[n][[#, 2]]],
  "*"] & /@
  Range@Length@FactorInteger@n,
  "\[Cross]"]
  ],
  FontSize -> 40
  ]
]

This is for the first line, for the second line you can just use Subscript instead of Subsuperscript. Also, you could use HoldForm instead of Unevaluated, but it's not needed since FactorIntger outputs a list and I just convert its output to strings. For the third line I'm guessing you can make a list of the numbers in the second line, then do something like:

list = {4, 6, 12} (*just an example*);
Style[
StringJoin[
  ToString[Subsuperscript[#1, #2, #3], FormatType -> StandardForm] & @@@
  Riffle[Subsuperscript["\[DoubleStruckCapitalZ]",
  Superscript[
  SortBy[Flatten[FactorInteger@list, 1], First][[#, 1]],
  SortBy[Flatten[FactorInteger@list, 1], First][[#, 2]]
],
  "*"] & /@
  Range@Length@SortBy[Flatten[FactorInteger@list, 1], First],
  "\[Cross]"]], FontSize -> 40]

To combine all of this, you could just use StringJoin[{expression1,expression2,...}], but put Style AFTER this (since Style removes the head String).

EDIT: some slight modifications to the last piece of code make it possible to insert the parentheses automatically:

Style[
 Riffle[
  StringJoin["(",
  ToString[
  Subscript[#1, #2], FormatType -> StandardForm] & @@@
  Riffle[Subsuperscript["\[DoubleStruckCapitalZ]",
  Superscript[#1, #2], "*"] & @@@ {##}, "\[Cross]"], ")"] & @@@
  GatherBy[SortBy[Flatten[FactorInteger@list, 1], First], First],
  "\[Cross]"] // StringJoin, FontSize -> 40]

I'm guessing an If could be added somewhere to avoid bracketing single expressions.

 

[jackmell]

Wow! Outstanding Konte. You're so good. I did a quick test of your code and it's looking good. Will have to do other things today though. Will work on it later and over the weekend and I'll post my results when I get it working fully.

Thanks,
Jack

 

[jackmell]

That code was not easy to follow; you're a much better programmer than me Konte. I gradually de-constructed it to understand it but now it's all in pieces. Never used Riffle before. Here's what my code prints out for $\mathbb{Z}_{10!}^*$:

$\begin{array}{ccc} \mathbb{Z}_{10!}^* & \cong & \mathbb{Z}_{2^8}^*\times\mathbb{Z}_{3^4}^*\times\mathbb{Z}_{5^2}^* \times\mathbb{Z}_7^* \\ \text{} & \cong & \mathbb{Z}_2\times \mathbb{Z}_{64}\times \mathbb{Z}_{54}\times \mathbb{Z}_{20}\times \mathbb{Z}_6 \\ \text{} & \cong & \left(\mathbb{Z}_2\times \mathbb{Z}_2\times \mathbb{Z}_2\times \mathbb{Z}_{2^2}\times \mathbb{Z}_{2^6}\text{)\times (}\mathbb{Z}_3\times \mathbb{Z}_{3^3}\text{)\times }\mathbb{Z}_5=G_2\times G_3 \times G_5\right. \\ \end{array}$

Now that's what I call perfect.

Ok, so I think I have this part of the code working. My next step would be to encapsulate it and then create a simple Manipulate that presents say 5 groups the user can choose and it simply reports the isomorphisms like above. I'll add the automorphism calculation later.

Thanks Konte!

 

[jackmell]

Here are my routines:

getIntegerGroupSylowProducts accepts the group index $n$ and returns {sylowPowerSets, isomorphismGrid}. We can then Print[isomorphismGrid] to report the isomorphisms. The sylowPowerSets are the exponent sets of the Sylow isomorphisms (3rd line in the isomorphism report). This power set is then sent to the second routine getTotalAutomorphism[sylowExponents] which then uses the formula in the above reference to compute the total number of automorphisms. Finally, I encapsulate it all in a Manipulate.

getIntegerGroupSylowProducts[n_]:=Module[{i,theFactors,unitGroup,firstRiffle,stringFirstRiffle,firstIsomorphism,net,factor,secondArray,myRiffle, string1,secondIsomorphism,secondFactors,theTally,theSylowsubgroupNames,theSylowsubgroups,sylowRiffle,string4, sylowGroups,sequence,num,stringSylow,thirdArray,myRiffle3,string3,thirdIsomorphism},

theFactors=FactorInteger[n];
unitGroup=Style[ToString[Subsuperscript["\[DoubleStruckCapitalZ]",n,"*"],FormatType->StandardForm]];

(* create first isomorphic relation *)
firstRiffle=Riffle[Subsuperscript["\[DoubleStruckCapitalZ]",If[theFactors[[#,2]]>1 (*this is optional,it's used so it doesn't display the exponent if it's 1*),Superscript[theFactors[[#,1]],theFactors[[#,2]]],theFactors[[#,1]]],"*"]&/@Range@Length@theFactors,"\[Cross]"];
stringFirstRiffle=StringJoin[ToString[Subsuperscript[#1,#2,#3],FormatType->StandardForm]&@@@ firstRiffle];
firstIsomorphism={unitGroup,"\[TildeFullEqual]",stringFirstRiffle};

(* Create second isomorphic relation * *)
net={};
For[i=1,i<=Length[theFactors],i++,
(* first check for powers of 2 *)
If[theFactors[[i,1]]==2,
{
If[theFactors[[i,2]]==2,
factor={2};
net=Append[net,factor];
];
If[theFactors[[i,2]]>2,
net=Append[net,{2}];
net=Append[net,{2^(theFactors[[i,2]]-2)}];
];
}
];
If[theFactors[[i,1]]!=2,
{
factor={theFactors[[i,1]]^theFactors[[i,2]]-(theFactors[[i,1]]^(theFactors[[i,2]]-1))};
net=Append[net,factor];
}
];
];
secondArray={#1[[1]],1}& /@ net;
myRiffle=Riffle[Subscript["\[DoubleStruckCapitalZ]",If[secondArray[[#,2]]>1 (*this is optional,it's used so it doesn't display the exponent if it's 1*),Superscript[secondArray[[#,1]],secondArray[[#,2]]],secondArray[[#,1]]]]&/@Range@Length@secondArray,"\[Cross]"];
string1=StringJoin[ToString[Subscript[#1,#2],FormatType->StandardForm]&@@@ myRiffle];
secondIsomorphism={"","\[TildeFullEqual]",string1};

(* Create third isomorphic relation (Sylow products) *)
secondFactors={};
For[i=1,i<=Length[net],i++,
If[Length[net[[i]]]==2,
secondFactors=Append[secondFactors,FactorInteger[net[[i,1]]]];
secondFactors=Append[secondFactors,FactorInteger[net[[i,2]]]];
];
If[Length[net[[i]]]==1,
secondFactors=Append[secondFactors,FactorInteger[net[[i]]]];
];
];
secondFactors=Sort[Flatten[secondFactors,2]];
theTally=Tally[secondFactors,#1[[1]]==#2[[1]]&];
theSylowsubgroupNames=#[[1,1]]& /@ theTally;
theSylowsubgroups=Subscript["S",#1]&/@ theSylowsubgroupNames;
sylowRiffle=Riffle[theSylowsubgroups,"\[Cross]"];

string4=StringJoin[ToString[Subscript[#1,#2],FormatType->StandardForm]&@@@ sylowRiffle];

(************************)

thirdArray=secondFactors;
sylowGroups={};
sequence=Tally[thirdArray,#1[[1]]==#2[[1]]&];
For[i=1,i<=Length[sequence],i++,
num=sequence[[i,1,1]];
sylowGroups=Append[sylowGroups,Select[thirdArray,#[[1]]==num&]];
];
stringSylow={};
For[i=1,i<=Length[sylowGroups],i++,
thirdArray=sylowGroups[[i]];
myRiffle3=Riffle[Subscript["\[DoubleStruckCapitalZ]",If[thirdArray[[#,2]]>1 (*this is optional,it's used so it doesn't display the exponent if it's 1*),Superscript[thirdArray[[#,1]],thirdArray[[#,2]]],thirdArray[[#,1]]]]&/@Range@Length@thirdArray,"\[Cross]"];
If[Length[sylowGroups[[i]]]>1,
string3="("<>StringJoin[ToString[Subscript[#1,#2],FormatType->StandardForm]&@@@ myRiffle3]<>")";
,
string3=StringJoin[ToString[Subscript[#1,#2],FormatType->StandardForm]&@@@ myRiffle3];
];
stringSylow=Append[stringSylow,string3];
];
myRiffle3=Riffle[stringSylow,"\[Cross]"];
string3=StringJoin[ToString[Subscript[#1,#2],FormatType->StandardForm]&@@@ myRiffle3];
thirdIsomorphism={"","\[TildeFullEqual]",string3,"=",string4};

(* now return the Sylow exponent sets and a grid of the isomorphism *)

{sylowGroups,Style[Grid[{firstIsomorphism,secondIsomorphism,thirdIsomorphism}],40]}
];

getTotalAutomorphism[thePGroups_] :=
  Module[{sum, line, theTally, base, nMax, i, pos, e, c, d, total1,
  total2, total3},
  sum = 1;
  For[line = 1, line <= Length[thePGroups], line++,
  thePGroups[[line]];
  theTally = Tally[thePGroups[[line]], #1[[2]] == #2[[2]] &];
  base = thePGroups[[line, 1, 1]];
  nMax = Length[thePGroups[[line]]];
  For[i = 1, i <= nMax, i++,
  pos =
  Flatten[Position[thePGroups[[line]], thePGroups[[line, i]]]];
  e[i] = thePGroups[[line, i, 2]];
  c[i] = pos[[1]];
  d[i] = Last[pos];
  ];
  total1 = \!\(
\*UnderoverscriptBox[\(\[Product]\), \(k =
  1\), \(nMax\)]\((base^d[k] - base^\((k - 1)\))\)\) ;
  total2 = \!\(
\*UnderoverscriptBox[\(\[Product]\), \(j =
  1\), \(nMax\)]\(\((base^e[j])\)^\((nMax - d[j])\)\)\) ;
  total3 = \!\(
\*UnderoverscriptBox[\(\[Product]\), \(i =
  1\), \(nMax\)]\(\((base^\((e[i] - 1)\))\)^\((nMax - c[i] +
  1)\)\)\);
  sum *= total1 total2 total3;
 
  ];
  sum
  ];

Manipulate[{thePGroups, theIsomorphisms} =
  getIntegerGroupSylowProducts[nval];
 Column[{theIsomorphisms,
  Row[{Style["Total automorphisms: ", 16],
  getTotalAutomorphism[thePGroups]}]}], {{nval, 12, "Group"}, 12,
  500, 1}, SaveDefinitions -> True]

 

[kontejnjer]

Looks good to me, just a couple of general tips:

1) For loops are the slowest in Mathematica, if you need to use loops, use Do instead, or even better, Apply or Map.
2) Don't use multiple Ifs if the condition is on the same element, use Which.
3) Append works on 1 element, but you can easily add multiple list elements using Join.

In any case, great job :)

 

[jackmell]

Looks good to me, just a couple of general tips:

1) For loops are the slowest in Mathematica, if you need to use loops, use Do instead, or even better, Apply or Map.
2) Don't use multiple Ifs if the condition is on the same element, use Which.
3) Append works on 1 element, but you can easily add multiple list elements using Join.

In any case, great job :)

Ok, thanks for looking at it. I'll try and incorporate those suggestions. What I think I'll do next is check the results against manual calculations as I'm just a beginner in Abstract Algebra and not 100% sure I got all the algebra (isomorphisms on the right of the expression) right. If the manual checks are ok though, then I think I'll write a demo and submit it to Wolfram and just hope for the best.

Thanks Konte,
I like programming in Mathematica and really appreciate others helping me get better at it. :)