Problem Set 3 Group

Exercise G3-1

Authored by: Professor Allen

Background

First, examine the code provided:

PrimObj[origin_  , LatticeVecA_  ,  LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[origin, 
                circrad]}], 
Graphics[{RGBColor[ .5, 0, 1], 
              Disk[origin  +  LatticeVecA, 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[origin  +  LatticeVecB, 
                circrad]}], 
Graphics[{RGBColor[ .5, 1, 0], 
              Disk[origin +  LatticeVecA +  LatticeVecB, 
                circrad]}]
}]

Show[PrimObj[{1, 0}, {0, 1}, {1,  .5}], Axes -> True, 
      AspectRatio -> Automatic]

It creates a graphics object that consists of four colored circles that can serve as a nice object lacking special symmetry (so long as color is considered), and from which we can apply symmetry operations and produce periodic patterns.
In order to do this assignment, it is necessary to know a little crystallography in order to have a good scheme for applying the symmetry operations mentioned in the assignment: rotational, reflectional, and translational symmetry.
It is also helpful to decide on a calculational scheme for doing the assignment.  My scheme will be:
	1) use a script analogous to PrimObj to apply the required rotational and/or reflectional symmetry to the starting pattern produced by PrimObj;
	2) use appropriate translational symmetry vectors to make a spatially periodic repetition of the resulting object from step 1).

Applying point symmetry operations to PrimObj

Let's try an example of step 1). Here's a pattern with mirror symmetry about the y axis, obtained by repeating the PrimObj command but replacing x -> –x.

Show[PrimObj[{1, 1}, {0, 1}, {1,  .5}],  
      PrimObj[{-1, 1}, {0, 1}, {-1,  .5}], Axes -> True, 
      AspectRatio -> Automatic, PlotRange -> {0, 3}]

Here's a second example of step 1), a pattern with 2mm symmetry, obtained by repeating the PrimObj command appropriately.

Show[PrimObj[{1, 1}, {0, 1}, {1,  .5}],  
      PrimObj[{-1, 1}, {0, 1}, {-1,  .5}], 
      PrimObj[{1, -1}, {0, -1}, {1, - .5}],  
      PrimObj[{-1, -1}, {0, -1}, {-1, - .5}], 
      Axes -> True, AspectRatio -> Automatic, 
      PlotRange -> {-3, 3}]

OK, you get the idea.  In order to carry out the assignment, we will need to be able to generate patterns that have: 1-fold (trivial, because the pattern produced by PrimObj has this already), 2-fold, 3-fold, 4-fold, and 6-fold rotational symmetry, plus a pattern with reflectional symmetry and one that combined both 2-fold and mirror symmetry. By combining these patterns with appropriate translational symmetry vectors, we can get examples of patterns with plane group symmetries p1, p2, p3, p4, p6, pm, and p2mm, respectively. First we have to be able to generate a translationally periodic repetition of a graphics object and display it...

Applying translational symmetry operations to PrimObj

Here's a pattern with some translational symmetry in 1-D. Let {tx, ty} be a translational symmetry vector, and plot three repetitions of PrimObj:

tx = 3;
ty = 1;
Do[p[i] = 
            PrimObj[{1 + (i - 1) tx, 1 + (i - 1) ty}, {0, 
                1}, {1,  .5}];, {i, 3}];
Show[p[1], p[2], p[3], Axes -> True, 
      AspectRatio -> Automatic]

Let's say we wish to make a pattern of 3 x 3 identical objects, separated by basis vectors v1 and v2. The following routine builds a 9x 2 matrix "LatticePts" that contains a set of coordinates from which we can conveniently plot a lattice:

v1 := {v1x, v1y};
v2 := {v2x, v2y};
LatticeOrigin = {0, 0};
LatticePts  := 
        Join[Table[
            LatticeOrigin + (n - 1) v1, {n, 3}], 
Table[
            LatticeOrigin  + v2  +  (n - 1) v1, {n, 
              3}], 
Table[
            LatticeOrigin  + 2 v2  +  (n - 1) v1, {n, 
              3}]];

The following basis vectors will give four cells of a square lattice (note that v1 and v2 are perpendicular and of equal magnitude):

v1x = 1; v1y = 0; v2x = 0; v2y = 1;

ListPlot[LatticePts, AspectRatio -> Automatic]

Here's the same thing for a rectangular lattice

v1x = 1; v1y = 0; v2x = 0; v2y = 0.4;

ListPlot[LatticePts, AspectRatio -> Automatic]

And for an arbitrary lattice

v1x = 0.7; v1y = 0.2; v2x = 0; v2y = 0.4;

ListPlot[LatticePts, AspectRatio -> Automatic]

Now a lattice with six-fold rotational symmetry

v1x = 1; v1y = 0; v2x = 0.5; v2y = (Sqrt[3])/2. ;

ListPlot[LatticePts, AspectRatio -> Automatic]

Now, rather than drawing lattice points, we'd like to be able to draw an arbitrary pattern with 2-D translational symmetry... like the one produced by PrimObj. Start with the arbitrary lattice defined with the following short routine.

v1x = 4.4; v1y = 0; v2x = 1.2; v2y = 5.8;

LatticeOrigin = {1, 1};

MyPlot  =  
        Show[PrimObj[LatticePts[[1]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[2]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[3]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[4]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[5]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[6]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[7]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[8]], {0, 1}, {1,  .5}], 
          PrimObj[LatticePts[[9]], {0, 1}, {1,  .5}],  
          Axes -> True, AspectRatio -> Automatic, 
          PlotRange -> {-1, 15}];

The pattern above has the plane group symmetry p1.

A more compact way of getting the final graphics object with translational symmetry...

Now we will demonstrate a more compact way to do the plotting, using a recursion method to progressively build up a graphics object without displaying it, then when the object is completed, it is displayed using Show with the appropriate option.

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[PrimObj[LatticePts[[1 ]], {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], PrimObj[LatticePts[[i ]], {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {0, 15}]

Because of the routine I use to generate lattice points in 2-D, I can produce up to 9 repetitions...

ShowMyPlot[9]

Now let's say we want to add a symmetry element such as a two-fold axis. We should modify the thing that gets placed at the lattice points accordingly.  Here is a "brute-force" way to do it:

TwoFoldRotObj1[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ - origin, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ - origin  -  LatticeVecA, 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ - origin  -  LatticeVecB, 
                circrad]}], 
Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ - origin -  LatticeVecA -  LatticeVecB, 
                circrad]}]
}]

Note that I have added an additional variable "displ" here, which was not in the original PrimObj script. This allows specification of the location where each translation of the basic pattern will be drawn:

Show[TwoFoldRotObj1[{0, 0}, {1, 0}, {0, 1}, {1,  .5}], 
      Axes -> True, AspectRatio -> Automatic]

OK, that was one way to do it.  Here is a way that uses the rotation matrix:

RotMat1:=(({{Cos[π], -Sin[π]}, {Sin[π], Cos[π]}}))

TwoFoldRotObj[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat1 . origin, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecA), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecB), 
                circrad]}], 
Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat1 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}]
}]

Show[TwoFoldRotObj[{0, 0}, {1, 0}, {0, 1}, {1,  .5}], 
      Axes -> True, AspectRatio -> Automatic]

Now let's hang this on a lattice with arbitrary v1 and v2:

v1x = 7.4; v1y = 0; v2x = 1.2; v2y = 5.8;

LatticeOrigin = {0, 0};

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[TwoFoldRotObj[LatticePts[[1 ]], {1, 0}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], 
        TwoFoldRotObj[LatticePts[[i ]], {1, 0}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {-5, 15}]

ShowMyPlot[9]

This plot (above) displays plane group symmetry p2. Note the appearance of additional locations of two-fold rotational symmetry midway between any two lattice points!

Now let's tackle the three-fold rotational symmetry and make a periodic pattern with p3 symmetry

Use the basic motif and add a three-fold axis.  We have two rotation matrices acting on the original object:

RotMat1:=(({{Cos[2 π/3], -Sin[2 π/3]}, {Sin[2 π/3], Cos[2 π/3]}}))
RotMat2:=(({{Cos[4 π/3], -Sin[4 π/3]}, {Sin[4 π/3], Cos[4 π/3]}}))

ThreeFoldRotObj[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat1 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat2 . origin, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat2 . (origin  +  LatticeVecA), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecB), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat2 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat1 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat2 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}]
}]

Show[ThreeFoldRotObj[{0, 0}, {1, 0.5}, {0, 1}, {1,  .5}], 
      Axes -> True, AspectRatio -> Automatic]

And now adding translational symmetry of a special type: in order to preserve three-fold axes in the pattern with translational symmetry, the lattice must be specialized such that v1 and v2 are of equal magnitude and have an angle of π/3 between them:

v1x = 7; v1y = 0; v2x = Sqrt[v1x^2  +  v1y^2] Cos[π/3]; 
    v2y = Sqrt[v1x^2  +  v1y^2] Sin[π/3];

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[ThreeFoldRotObj[
          LatticePts[[1 ]], {1, 0.5}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], 
        ThreeFoldRotObj[LatticePts[[i ]], {1, 0.5}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {-4, 16}]

ShowMyPlot[9]

Now let's tackle the four-fold rotational symmetry and make a periodic pattern with p4 symmetry

RotMat1:=(({{Cos[ π/2], -Sin[ π/2]}, {Sin[ π/2], Cos[ π/2]}}))
RotMat2:=(({{Cos[π], -Sin[π]}, {Sin[π], Cos[π]}}))
RotMat3:=(({{Cos[3  π/2], -Sin[3  π/2]}, {Sin[3  π/2], Cos[3  π/2]}}))

FourFoldRotObj[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat1 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat2 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat3 . origin, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat2 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat3 . (origin  +  LatticeVecA), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecB), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat2 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat3 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat1 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat2 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat3 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}]
}]

Show[FourFoldRotObj[{0, 0}, {1, 0.5}, {0, 1}, {1,  .5}], 
      Axes -> True, AspectRatio -> Automatic]

Not surprisingly, to retain four-fold rotational symmetry in the translationally periodic pattern, v1 and v2 must be specialized and have the same magnitude and an interaxial angle of π/2.

v1x = 6. ; v1y = 0; v2x = 0; v2y = 6. ;

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[FourFoldRotObj[LatticePts[[1 ]], {1, 0}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], 
        FourFoldRotObj[LatticePts[[i ]], {1, 0}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {-5, 15}]

Because of the routine I use to generate lattice points in 2-D, I can produce up to 9 repetitions...

ShowMyPlot[9]

This plot (above) displays plane group symmetry p4. Note here that we obtained points that have two-fold rotational symmetry!

Now do something similar for a six-fold axis:

RotMat1:=(({{Cos[ π/3], -Sin[ π/3]}, {Sin[π/3], Cos[ π/3]}}))
RotMat2:=(({{Cos[2 π/3], -Sin[2 π/3]}, {Sin[2 π/3], Cos[2 π/3]}}))
RotMat3:=(({{Cos[3 π/3], -Sin[3 π/3]}, {Sin[3  π/3], Cos[3  π/3]}}))
RotMat4:=(({{Cos[4 π/3], -Sin[4 π/3]}, {Sin[4 π/3], Cos[4 π/3]}}))
RotMat5:=(({{Cos[5 π/3], -Sin[5 π/3]}, {Sin[5 π/3], Cos[5 π/3]}}))

SixFoldRotObj[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat1 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat2 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat3 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat4 . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + RotMat5 . origin, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat2 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat3 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat4 . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + RotMat5 . (origin  +  LatticeVecA), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat1 . (origin  +  LatticeVecB), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat2 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat3 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat4 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + RotMat5 . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat1 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat2 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat3 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat4 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  RotMat5 . (origin +  LatticeVecA +  LatticeVecB), 
                circrad]}]
}]

As for plane group p3, the lattice must be specialized so that v1 and v2 are of equal magnitude and have a π/3 interaxial angle:

v1x = 7; v1y = 0; v2x = Sqrt[v1x^2  +  v1y^2] Cos[π/3]; 
    v2y = Sqrt[v1x^2  +  v1y^2] Sin[π/3];

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[SixFoldRotObj[
          LatticePts[[1 ]], {1, 0.5}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], 
        SixFoldRotObj[LatticePts[[i ]], {1, 0.5}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {-4, 16}]

ShowMyPlot[9]

The pattern above is p6.  Note here that we have created points in the pattern that have three-fold rotational symmetry and other points where there is two-fold symmetry!

We can use a similar approach to generate a pattern with reflection symmetry by use of the reflection matrix, as follows:

ReflAboutYMat:=(({{-1, 0}, {0, 1}}))

ReflAboutYObj[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + ReflAboutYMat . origin, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + ReflAboutYMat . (origin  +  LatticeVecA), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + ReflAboutYMat . (origin  +  LatticeVecB), 
                circrad]}], 
Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  ReflAboutYMat . (origin +  LatticeVecA +  
                        LatticeVecB), 
                circrad]}]
}]

Show[ReflAboutYObj[{0, 0}, {1, 0}, {0, 1}, {1,  .5}], 
      Axes -> True, AspectRatio -> Automatic]

When a pattern with translational symmetry also contains just reflection symmetry, the lattice must be specialized so that v1 and v2 are orthogonal, i.e., the lattice must be rectangular:

v1x = 7; v1y = 0; v2x = 0; v2y = 4;

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[ReflAboutYObj[
          LatticePts[[1 ]], {1, 0.5}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], 
        ReflAboutYObj[LatticePts[[i ]], {1, 0.5}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {0, 12}]

ShowMyPlot[9]

The pattern above has plane group symmetry m.

Finally, let's make a pattern with p2mm symmetry. This will involve a motif that has both two-fold and reflection symmetry:

TwoFoldRotMat:=(({{Cos[π], -Sin[π]}, {Sin[π], Cos[π]}}))
ReflAboutYMat:=(({{-1, 0}, {0, 1}}))

TwoMMObj[displ_  , origin_  , LatticeVecA_  ,  
        LatticeVecB_  ]  := 
      Module[{circrad = 
            0.25*Min[Sqrt[LatticeVecA . LatticeVecA], 
                Sqrt[LatticeVecB . 
                    LatticeVecB]]}, 
{Graphics[{RGBColor[1, 
                0,  .5], 
              Disk[displ + origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + ReflAboutYMat . origin, circrad]}], 
          Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + TwoFoldRotMat . origin, 
                circrad]}], 
Graphics[{RGBColor[1, 0,  .5], 
              Disk[displ + TwoFoldRotMat . ReflAboutYMat . origin, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + origin  +  LatticeVecA, circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + ReflAboutYMat . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + TwoFoldRotMat . (origin  +  LatticeVecA), 
                circrad]}], 
          Graphics[{RGBColor[ .5, 0, 1], 
              Disk[displ + 
                  TwoFoldRotMat . 
                    ReflAboutYMat . (origin  +  LatticeVecA), 
                circrad]}], 
Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + origin  +  LatticeVecB, circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + ReflAboutYMat . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + TwoFoldRotMat . (origin  +  LatticeVecB), 
                circrad]}], 
          Graphics[{RGBColor[1,  .5, 0], 
              Disk[displ + 
                  TwoFoldRotMat . 
                    ReflAboutYMat . (origin  +  LatticeVecB), 
                circrad]}], 
Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + origin +  LatticeVecA +  LatticeVecB, 
                circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  ReflAboutYMat . (origin +  LatticeVecA +  
                        LatticeVecB), circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  TwoFoldRotMat . (origin +  LatticeVecA +  
                        LatticeVecB), circrad]}], 
          Graphics[{RGBColor[ .5, 1, 0], 
              Disk[displ + 
                  TwoFoldRotMat . 
                    ReflAboutYMat . (origin +  LatticeVecA +  
                        LatticeVecB), 
                circrad]}]
}]

Show[TwoMMObj[{0, 0}, {1, 1}, {0, 1}, {1,  .5}], Axes -> True, 
      AspectRatio -> Automatic]

Note that in the above pattern, by combination of a two-fold axis with a reflection about the y axis, an additional reflection symmetry element about the x axis automatically appeared !
In this case when we add translational symmetry to the 2mm point group symmetry operation, the lattice must be specialized to be rectangular (just as for plane group m):

v1x = 10; v1y = 0; v2x = 0; v2y = 7;

Clear[i]

Clear[MyPlot]

MyPlot[1]  =  
      Show[TwoMMObj[LatticePts[[1 ]], {1, 1}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

MyPlot[i_]  :=  
      Show[MyPlot[i - 1], 
        TwoMMObj[LatticePts[[i ]], {1, 1}, {0, 1}, {1,  .5}],  
        DisplayFunction -> Identity]

ShowMyPlot[i_ ]  :=  
      Show[MyPlot[i], DisplayFunction -> $DisplayFunction, 
        Axes -> True, AspectRatio -> Automatic, 
        PlotRange -> {-4, 18}]

ShowMyPlot[9]

Problem G3-2

Both groups put a valiant effort into this problem.  What follows is credited to the following group's work: Doug Fraser, David Gray, Yao-Chung King, Juliana Olmstead, Hannah Yun, Stephanie Silberstein.

Enaught=1 (for simplicity)

Clear[nmax]

Energy = (1 - 1/nmax^2)

For Only n=1, n=2,  Only eight total states. There are three electrons so that means there are 1000 possible combinations for three electrons.

nmax = 2;
RealTotalNumberOfStates = 
      Table[f = g; 
NumberOfAtoms = 
          3; 
TotalNumberOfStatesTemp = 
          0; 
For[i = 1, i <= f, i++, 
          TotalNumberOfStatesTemp = (-2 + 4 i) + 
              TotalNumberOfStatesTemp]; 
TotalNumberOfStatesTemp, {g, 1, nmax}]

PossibleEnergyValuesSorta = Table[Energy, {nmax, 1, nmax}]

Here we have to account for the fact that the probability of the energy for a state goes up with the state number.

Do[Do[
        PossibleEnergyValuesSorta = 
          Insert[PossibleEnergyValuesSorta, 
            PossibleEnergyValuesSorta[[-(nmax - q + 
                      1)]], -nmax + q - 1], {2  q - 2}], {q, 
        nmax}]
PossibleEnergyValuesSorta

Put in the number of atoms and permutate

NumberOfAtoms = 3

Table[0, {i, 1, NumberOfAtoms}]

After creating a table for the number of atoms, we must make a list of all of these tables for each state configuration.

ListOfSystemStates = 
      Delete[Flatten[
          Table[Delete[
              Table[ReplacePart[Table[0, {i, 1, NumberOfAtoms}], 
                  PossibleEnergyValuesSorta[[j]], 
                  Table[{NumberOfAtoms}, {NumberOfAtoms, 1, l}]], {l, 0, 
                  NumberOfAtoms}], 1], {j, 1, Sum[2 w - 1, {w, 1, nmax}]}], 
          1], {{1}, {2}}]

The sets that were deleted were the sets of {0,0,0} because there should only be one of them.

Next we take all of the permutations of this to find all of the possible states while accounting for the increased probability of having 3/4 produced three times more likely than 0.

PossibleSystemEnergiesList = 
      Flatten[Table[
          Permutations[ListOfSystemStates[[o]]], {o, 1, 
            Length[ListOfSystemStates]}], 1]

Next we find the possible system energies in a one list form.

PossibleSystemEnergies = 
      PossibleSystemEnergiesList . Table[1, {z, 1, NumberOfAtoms}]

XCoordinates = Union[PossibleSystemEnergies]

OmegaE = 
      Table[Count[
          PossibleSystemEnergies, Union[
              PossibleSystemEnergies][[s]]], {s, 1, 
          Length[Union[PossibleSystemEnergies]]}]

EntropyTable = 
      Table[Boltzmann Log[OmegaE[[r]]], {r, 1, 
          Length[OmegaE]}]

YCoordinates = EntropyOverBoltzmann = 
        EntropyTable/Boltzmann

Now that we have the coordinates for our graph of the Log[Eomega]/Boltzmann vs. possible system energies, we can start to graph it.

Table[
      Table[XCoordinates[[i]]  + YCoordinates[[i]], {i, i, i}], {i, 
        1, Length[YCoordinates]}]

Join[XCoordinates, YCoordinates]

For[b = 1, b <= Length[YCoordinates], b++, 
      ListForPlotting[b] = {XCoordinates[[b]], 
          YCoordinates[[b]]}]

PointsToPlot = 
      Table[ListForPlotting[c], {c, 1, Length[XCoordinates]}]

ListPlot[PointsToPlot, PlotJoined -> True]

The  Entropy of a system where the maximum state of an electron is n=1 is Zero.
The Entropy of a system where the maximum state of an electron is n=2 is {0,Log[9],Log[9],Log[3]} depending on the configurations.
The Entropy of a system where the maximum state of an electron is n=2 is {0,Log[9],Log[15],Log[9],Log[15],Log[3],Log[5]} depending on the configurations.
The Entropy of a system where there are 5 atoms and the maximum state of an electron is n=2 is{Log[3],Log[15],Log[30],Log[30],Log[15],Log[3]} depending on the configurations.

XTRA Credit: As can be seen in the graph above, it appears that the entropy decreases after a certain point while the energy is still going up.  This makes zero sense.  According to the equation dU=TdS-PdV, while Volume is held constant, the change in internal energy (a jump in state could be this change) divided by the temperature that one is at should give the change in Entropy.  Since Temperature is positive and the change in internal energy is positive when the energy is increasing, the change in entropy should never by negative.  On the graph above, dS is definitely negative.  This is where our results are unphysical.