(* wzor Rodriguesa 
http://mathworld.wolfram.com/RodriguesRotationFormula.html
*)

omegam[w1_,w2_,w3_]:={{0,-w3,w2},{w3,0,-w1},{-w2,w1,0}}

MatrixForm[omegam[w1,w2,w3]]

MatrixForm[omegam[w1,w2,w3].omegam[w1,w2,w3]]

Wzór Rodriguesa na macierz obrotu

(* Obrót o kąt phi przeciwnie do ruchu wskazówek zegara wokół osi zdeiniowanej przez wektor o długości 1 i składowych kartezjańskich (w1,w2,w3). 
BARDZO WAŻNE: OŚ OBROTU MUSI PRZECHODZIĆ PRZEZ POCZĄTEK UKŁADU WSPÓŁRZĘDNYCH !!! *)

R[w1_,w2_,w3_,phi_]:=IdentityMatrix[3]+Sin[phi]*omegam[w1,w2,w3]+(1-Cos[phi])*omegam[w1,w2,w3].omegam[w1,w2,w3]

FullSimplify[MatrixForm[R[w1,w2,w3,phi]],Element[w1,Reals]&&Element[w2,Reals]&&Element[w3,Reals]&&Element[phi,Reals]&&(w1*w1+w2*w2+w3*w3==1)]

(* Macierz R powinna być macierzą ortogonalną ! *)

FullSimplify[Inverse[R[w1,w2,w3,phi]]==Transpose[R[w1,w2,w3,phi]],Element[w1,Reals]&&Element[w2,Reals]&&Element[w3,Reals]&&Element[phi,Reals]&&(w1*w1+w2*w2+w3*w3==1)]

(* Wierzchołki czworościanu wpisanego w sześcian o boku 2 *)

pktA={-1,-1,-1};

pktB={1,1,-1};

pktC={-1,1,1};

pktD={1,-1,1};

pktX=(1/2)*(pktA+pktC);

pktXp=(1/2)*(pktB+pktD);

pktAp={1,1,1};

(* e to jedynka w grupie T *)

e=IdentityMatrix[3];

(* b to obrót wokół osi XX' o kąt Pi *)

vb=Normalize[pktXp-pktX];

phib=Pi;

b=R[vb[[1]],vb[[2]],vb[[3]],phib]

(* c jest obrotem wokół osi AA' o kąt 2*Pi/3 *)

vc=Normalize[pktAp-pktA];

phic=2*Pi/3;

c=R[vc[[1]],vc[[2]],vc[[3]],phic]

(* Zachodzi b^2=c^3=(b.c)^3=e  *)

b.b==e

c.c.c==e

b.c.b.c.b.c==e

(* Teraz próbuję wypisać wszystkie elementy grupy ... *)

G={e,b,c,c.c,b.c,b.c.c,c.b,c.c.b,c.c.b.c,c.c.b.c.c,b.c.c.b,b.c.c.b.c};

Length[G]

(* ... i przy pomocy tej podwójnej pętli sprawdzam, czy któryś się nie powtarza.  *)

Do[Do[If[G[[i]]==G[[k]],Print["i= ",i," k=",k]],{i,1,k-1}],{k,2,Length[G]}]

(* Wygląda na to, że wszystkie elementy są istotnie różne ! *)

(* W takim razie, który element pokrywa się z c.b.c ? *)

Do[If[G[[i]]==c.b.c,Print["i= ",i]],{i,1,Length[G]}]

(* Szukamy elementów odwrotnych *)

Do[Do[If[(G[[k]].G[[i]]==e)&&(G[[i]].G[[k]]==e),inv[k]=i;Print["k= ",k,"   i= ",i]],{i,1,Length[G]}],{k,1,12}]

inv[10]

(* Szukamy centrum grupy T *)

Do[{l=0;Do[If[G[[i]].G[[k]]==G[[k]].G[[i]] ,l=l+1],{i,1,Length[G]}];If[l==Length[G],Print["k= ",k]]},{k,1,Length[G]}]

(* Czyli w centrum jest tylko e ! *)

(* Zbudujmy klasy sprzężenia (a), szukając wszystkich g.a.(g)^(-1). Uwaga: Mathematica używa list, dla których ważna jest pozycja elementu. Dlatego, by móc porównywać różne klasy, sortuję wyniki, a po tej operacji mogę już usunąć elementy, które się powtarzają.   *)

Do[klasa[k]=Sort[DeleteDuplicates[Table[Simplify[G[[i]].G[[k]].Inverse[G[[i]]]],{i,1,Length[G]}]]],{k,1,Length[G]}]

KLASY=DeleteDuplicates[Table[klasa[i],{i,1,Length[G]}]]

(* KLASY jest listą list macierzy (listą klas) ! *)

Length[KLASY]

KLASY[[1]]

(* KLASY[[i]] jest listą macierzy (z klasy nr i) *)

Length[KLASY[[1]]]

Length[KLASY[[2]]]

Length[KLASY[[3]]]

Length[KLASY[[4]]]

KLASY[[2]][[2]]

(* KLASY[[k]][[j]] jest macierzą nr j w klasie nr k *)

Do[Do[Do[If[G[[i]]==KLASY[[k]][[j]],Print["Element i= ",i," jest w klasie nr=",k]],{i,1,Length[G]}],{j,1,Length[KLASY[[k]]]}],{k,1,Length[KLASY]}]

Simplify[b.c.c.b==c.b.c]

Simplify[b.c.c.b.c==c.b.c.c]

Do[chi[i]=Tr[G[[i]]],{i,1,12}]

(* Sprawdzamy, że w każdej klasie sprzężenia charaktery są takie same *)

(* Klasa 1 *)

chi[1]

(* Klasa 2 *)

chi[2]==chi[9]==chi[12]

(* Klasa 3 *)

chi[3]==chi[5]==chi[7]==chi[10]

(* Klasa 4 *)

chi[4]==chi[6]==chi[8]==chi[11]

(* Sprawdzenie, czy "robocza" trójwymiarowa reprezentacja jest nieredukowalna. Do sprawdzenia z wykładem IV  *)

(* Wybieram reprezentantów klas *)

r[1]=1;r[2]=2;r[3]=3;r[4]=4;

Length[G]==Sum[Length[KLASY[[k]]]*Abs[Tr[G[[r[k]]]]]^2,{k,1,4}]

(* Albo dużo prościej, sumując po wszystkich elementach *)

Length[G]==Sum[Abs[Tr[G[[i]]]]^2,{i,1,12}]

(* Mamy więc już dwie reprezentacje nieredukowalne grupy T: trywialną i trójwymiarową *)

Gtryw={1,1,1,1,1,1,1,1,1,1,1,1};

Length[Gtryw]

(* Dla kompletu, należy teraz jeszcze znaleźć brakującą reprezentację jednowymiarową, traktując b i c jak ZWYKŁE LICZBY ZESPOLONE *)

(* Mieliśmy: G={e,b,c,c.c,b.c,b.c.c,c.b,c.c.b,c.c.b.c,c.c.b.c.c,b.c.c.b,b.c.c.b.c};
Spróbujmy: e=c=1; b=-1 *)

G1wym={1,-1,1,1,-1,-1,-1,-1,-1,-1,-1,-1};

Length[G1wym]

(* Sprawdzamy, że w każdej klasie sprzężenia charaktery są takie same *)

(* Klasa 1: e *)

G1wym[[1]]

(* Klasa 2: b, c^2*b*c, b*c^2*b*c *)

G1wym[[2]]==G1wym[[9]]==G1wym[[12]]

(* Klasa 3: c, b*c, c*b, c^2*b*c^2 *)

G1wym[[3]]==G1wym[[5]]==G1wym[[7]]==G1wym[[10]]

(* Klasa 4: c^2, b*c^2, c^2*b, b*c^2*b *)

G1wym[[4]]==G1wym[[6]]==G1wym[[8]]==G1wym[[11]]

(* To nie jest więc reprezentacja! *)

(* Teraz spróbuję: e=b=1, c= E^(2*I*Pi/3)*)

(* Mieliśmy: G={e,b,c,c.c,b.c,b.c.c,c.b,c.c.b,c.c.b.c,c.c.b.c.c,b.c.c.b,b.c.c.b.c}; *)

cc=E^(2*I*Pi/3)

cc^3

ee=1;bb=1;

G1wym={ee,bb,cc,cc*cc,bb*cc,bb*cc*cc,cc*bb,cc*cc*bb,cc*cc*bb*cc,cc*cc*bb*cc*cc,bb*cc*cc*bb,bb*cc*cc*bb*cc};

Length[G1wym]

(* Sprawdzamy, że w każdej klasie sprzężenia charaktery są takie same *)

(* Klasa 1: e *)

G1wym[[1]]

(* Klasa 2: b, c^2*b*c, b*c^2*b*c *)

G1wym[[2]]==G1wym[[9]]==G1wym[[12]]

(* Klasa 3: c, b*c, c*b, c^2*b*c^2 *)

G1wym[[3]]==G1wym[[5]]==G1wym[[7]]==G1wym[[10]]

(* Klasa 4: c^2, b*c^2, c^2*b, b*c^2*b *)

G1wym[[4]]==G1wym[[6]]==G1wym[[8]]==G1wym[[11]]

(* To jest więc reprezentacja! *)

(* Teraz spróbuję: e=b=1, c= E^(2*I*Pi/3)*)

G1wym

(* Sprawdzamy warunek nieredukowalności, sumując po wszystkich elementach *)

Length[G1wym]==Sum[Abs[G1wym[[i]]]^2,{i,1,12}]

(* Strona 44 wykładu III *)

(* (Subscript[U, ν]) (3wym) ⟶  (Subscript[U, μ]) (1wym) *)

(* A - dowolna macierz, która działa na wektor z trzema składowymi i daje wektor z jedną składową *)

Am=Array[A,{3,1}]

(* Dla nietrywialnej reprezentacji jednowymiarowej *)

B=Sum[G1wym[[i]]*Flatten[Am].G[[inv[i]]],{i,1,12}]

(* Dla reprezentacji trywialnej *)

B=Sum[Gtryw[[i]]*Flatten[Am].G[[inv[i]]],{i,1,12}]

(* Zgodnie z rachunkiem z wykładu III, macierz B spełnia założenia II lematu Schura, więc musi być macierzą zerową!  *)