Cell[CellGroupData[{Cell[BoxData[
 RowBox[{"Manipulate", "[", "
", 
  RowBox[{
   RowBox[{"Module", "[", 
    RowBox[{
     RowBox[{"{", " ", 
      RowBox[{"coloring", ",", "redorblue"}], "}"}], ",", 
     "
", " ", 
     RowBox[{
      RowBox[{"coloring", "=", 
       RowBox[{"PadLeft", "[", 
        RowBox[{
         RowBox[{"IntegerDigits", "[", 
          RowBox[{"nn", ",", "2"}], "]"}], ",", "15"}], "]"}]}], ";", 
      "
", 
      RowBox[{"redorblue", "=", 
       RowBox[{"Select", "[", 
        RowBox[{"triangles", ",", 
         RowBox[{
          RowBox[{"monochromaticQ", "[", 
           RowBox[{"coloring", ",", "#"}], "]"}], "&"}]}], "]"}]}], 
      ";", "
", 
      RowBox[{"Graphics3D", "[", 
       RowBox[{
        RowBox[{"{", "
", 
         RowBox[{
          RowBox[{"{", "
", 
           RowBox[{
            RowBox[{"Opacity", "[", ".5", "]"}], ",", 
            "
", 
            RowBox[{"Transpose", "@", 
             RowBox[{"{", "
", 
              RowBox[{
               RowBox[{
                RowBox[{
                 RowBox[{
                  RowBox[{"{", 
                   RowBox[{
                    RowBox[{"Lighter", "@", "Red"}], ",", 
                    RowBox[{"Lighter", "@", "Blue"}]}], "}"}], "[", 
                  RowBox[{"[", " ", 
                   RowBox[{"1", "+", 
                    RowBox[{"coloring", "[", 
                    RowBox[{"[", 
                    RowBox[{
                    RowBox[{"Position", "[", 
                    RowBox[{"edges", ",", 
                    RowBox[{"Rest", "@", "#"}]}], "]"}], "[", 
                    RowBox[{"[", 
                    RowBox[{"1", ",", "1"}], "]"}], "]"}], " ", "]"}],
                     "]"}]}], " ", "]"}], "]"}], "&"}], "/@", 
                "redorblue"}], ",", "
", 
               RowBox[{
                RowBox[{
                 RowBox[{"Polygon", "@", 
                  RowBox[{"pts", "[", 
                   RowBox[{"[", "#", "]"}], "]"}]}], "&"}], "/@", 
                "redorblue"}]}], "
", "}"}]}]}], 
           "
", "}"}], ",", "
", 
          RowBox[{"Thickness", "[", ".01", "]"}], ",", 
          RowBox[{"Transpose", "[", 
           RowBox[{"{", " ", 
            RowBox[{
             RowBox[{"coloring", "/.", 
              RowBox[{"{", 
               RowBox[{
                RowBox[{"0", "->", "Red"}], ",", 
                RowBox[{"1", "->", "Blue"}]}], "}"}]}], ",", 
             RowBox[{
              RowBox[{
               RowBox[{"Cylinder", "[", 
                RowBox[{"#", ",", ".02"}], "]"}], "&"}], "/@", 
              "segments"}]}], "}"}], "]"}], ",", 
          "
", 
          RowBox[{"PointSize", "[", "0.03", "]"}], ",", 
          RowBox[{"Sphere", "[", 
           RowBox[{"pts", ",", ".05"}], "]"}]}], 
         "
", "}"}], ",", 
        RowBox[{"ImageSize", "->", "520"}], " ", ",", 
        RowBox[{"Boxed", "->", "False"}], ",", 
        RowBox[{"ViewPoint", "->", 
         RowBox[{"{", 
          RowBox[{"0", ",", "0", ",", "1"}], "}"}]}]}], "]"}]}]}], 
    "
", "]"}], ",", "
", 
   RowBox[{"{", 
    RowBox[{
     RowBox[{"{", 
      RowBox[{"nn", ",", "1945", ",", "\"\<n\>\""}], "}"}], ",", "1", 
     ",", 
     RowBox[{
      RowBox[{"2", "^", "15"}], "-", "1"}], ",", "1", ",", 
     RowBox[{"Appearance", "->", "\"\<Labeled\>\""}]}], "}"}], 
   ",", "
", 
   RowBox[{"TrackedSymbols", ":>", 
    RowBox[{"{", "nn", "}"}]}], ",", "
", 
   RowBox[{"Initialization", ":>", 
    RowBox[{"(", "
", 
     RowBox[{
      RowBox[{"pts", "=", 
       RowBox[{"Table", "[", 
        RowBox[{
         RowBox[{"{", 
          RowBox[{
           RowBox[{"Cos", "[", 
            RowBox[{"2", "Pi", " ", 
             RowBox[{"k", "/", "6"}]}], "]"}], ",", 
           RowBox[{"Sin", "[", 
            RowBox[{"2", "Pi", " ", 
             RowBox[{"k", "/", "6"}]}], "]"}], ",", "0"}], "}"}], ",", 
         RowBox[{"{", 
          RowBox[{"k", ",", "6"}], "}"}]}], "]"}]}], ";", 
      "
", 
      RowBox[{"edges", "=", 
       RowBox[{"Flatten", "[", 
        RowBox[{
         RowBox[{"Table", "[", 
          RowBox[{
           RowBox[{"{", 
            RowBox[{"i", ",", "j"}], "}"}], ",", 
           RowBox[{"{", 
            RowBox[{"j", ",", "6"}], "}"}], ",", 
           RowBox[{"{", 
            RowBox[{"i", ",", 
             RowBox[{"j", "-", "1"}]}], "}"}]}], "]"}], ",", "1"}], 
        "]"}]}], ";", "
", 
      RowBox[{"segments", "=", 
       RowBox[{"Flatten", "[", 
        RowBox[{
         RowBox[{"Table", "[", 
          RowBox[{
           RowBox[{"{", 
            RowBox[{
             RowBox[{"pts", "[", 
              RowBox[{"[", "i", "]"}], "]"}], ",", 
             RowBox[{"pts", "[", 
              RowBox[{"[", "j", "]"}], "]"}]}], "}"}], ",", 
           RowBox[{"{", 
            RowBox[{"j", ",", "6"}], "}"}], ",", 
           RowBox[{"{", 
            RowBox[{"i", ",", 
             RowBox[{"j", "-", "1"}]}], "}"}]}], "]"}], ",", "1"}], 
        "]"}]}], ";", "
", 
      RowBox[{"triangles", "=", 
       RowBox[{"Subsets", "[", 
        RowBox[{
         RowBox[{"Range", "[", "6", "]"}], ",", 
         RowBox[{"{", "3", "}"}]}], "]"}]}], ";", 
      "
", 
      RowBox[{
       RowBox[{"monochromaticQ", "[", 
        RowBox[{"coloring_", ",", "triangle_"}], "]"}], ":=", 
       RowBox[{"1", "==", 
        RowBox[{"Length", "@", 
         RowBox[{"Union", "[", 
          RowBox[{
           RowBox[{
            RowBox[{
             RowBox[{
              RowBox[{"coloring", "[", 
               RowBox[{"[", "#", "]"}], "]"}], "&"}], "/@", " ", 
             RowBox[{"Position", "[", 
              RowBox[{"edges", ",", "#"}], "]"}]}], "&"}], "/@", 
           RowBox[{"(*", " ", 
            RowBox[{"sides", ":"}], " ", "*)"}], 
           RowBox[{"Subsets", "[", 
            RowBox[{"triangle", ",", 
             RowBox[{"{", "2", "}"}]}], "]"}]}], "]"}]}]}]}]}], 
     "
", ")"}]}]}], "
", 
  "]"}]], "Input",
 CellGroupingRules->{"GroupTogetherGrouping", 10000.},
 CellChangeTimes->{
  3.55810071857382*^9, {3.558101197572937*^9, 
   3.5581012103232317`*^9}, {3.5581012634222*^9, 
   3.558101264021821*^9}, {3.558101302892232*^9, 
   3.558101324632242*^9}, 3.5581013601153793`*^9, {
   3.558101408445898*^9, 3.558101409208138*^9}, {3.558102189170739*^9,
    3.558102190005802*^9}, {3.558102388486553*^9, 
   3.558102395532139*^9}, {3.558104085570716*^9, 
   3.558104102730558*^9}, {3.558104163673909*^9, 
   3.558104164272559*^9}, {3.558104234318025*^9, 
   3.558104253009859*^9}, {3.560614319598033*^9, 
   3.5606143596821213`*^9}, {3.5606143928799887`*^9, 
   3.560614470526333*^9}, {3.560614511445507*^9, 
   3.560614511603245*^9}, 3.7607251600207577`*^9}],

Cell[BoxData[
 TagBox[
  StyleBox[
   DynamicModuleBox[{$CellContext`nn$$ = 1945, Typeset`show$$ = True, 
    Typeset`bookmarkList$$ = {}, Typeset`bookmarkMode$$ = "Menu", 
    Typeset`animator$$, Typeset`animvar$$ = 1, Typeset`name$$ = 
    "\"untitled\"", Typeset`specs$$ = {{{
       Hold[$CellContext`nn$$], 1945, "n"}, 1, 32767, 1}}, 
    Typeset`size$$ = {520., {225., 229.}}, Typeset`update$$ = 0, 
    Typeset`initDone$$, Typeset`skipInitDone$$ = 
    False, $CellContext`nn$127264$$ = 0}, 
    DynamicBox[Manipulate`ManipulateBoxes[
     1, StandardForm, "Variables" :> {$CellContext`nn$$ = 1945}, 
      "ControllerVariables" :> {
        Hold[$CellContext`nn$$, $CellContext`nn$127264$$, 0]}, 
      "OtherVariables" :> {
       Typeset`show$$, Typeset`bookmarkList$$, Typeset`bookmarkMode$$,
         Typeset`animator$$, Typeset`animvar$$, Typeset`name$$, 
        Typeset`specs$$, Typeset`size$$, Typeset`update$$, 
        Typeset`initDone$$, Typeset`skipInitDone$$}, "Body" :> 
      Module[{$CellContext`coloring$, $CellContext`redorblue$}, \
$CellContext`coloring$ = PadLeft[
           IntegerDigits[$CellContext`nn$$, 2], 
           15]; $CellContext`redorblue$ = 
         Select[$CellContext`triangles, \
$CellContext`monochromaticQ[$CellContext`coloring$, #]& ]; 
        Graphics3D[{{
            Opacity[0.5], 
            Transpose[{
              Map[Part[{
                 Lighter[Red], 
                 Lighter[Blue]}, 1 + Part[$CellContext`coloring$, 
                  Part[
                   Position[$CellContext`edges, 
                    Rest[#]], 1, 1]]]& , $CellContext`redorblue$], 
              Map[Polygon[
                
                Part[$CellContext`pts, #]]& , \
$CellContext`redorblue$]}]}, 
           Thickness[0.01], 
           Transpose[{
             
             ReplaceAll[$CellContext`coloring$, {
              0 -> Red, 1 -> Blue}], 
             Map[Cylinder[#, 0.02]& , $CellContext`segments]}], 
           PointSize[0.03], 
           Sphere[$CellContext`pts, 0.05]}, ImageSize -> 520, Boxed -> 
          False, ViewPoint -> {0, 0, 1}]], 
      "Specifications" :> {{{$CellContext`nn$$, 1945, "n"}, 1, 32767, 
         1, Appearance -> "Labeled"}}, 
      "Options" :> {TrackedSymbols :> {$CellContext`nn$$}}, 
      "DefaultOptions" :> {ControllerLinking -> True}],
     ImageSizeCache->{565., {270., 276.}},
     SingleEvaluation->True],
    Deinitialization:>None,
    DynamicModuleValues:>{},
    Initialization:>(($CellContext`pts = Table[{
          Cos[(2 Pi) ($CellContext`k/6)], 
          Sin[(2 Pi) ($CellContext`k/6)], 0}, {$CellContext`k, 
          6}]; $CellContext`edges = Flatten[
         Table[{$CellContext`i, $CellContext`j}, {$CellContext`j, 
           6}, {$CellContext`i, $CellContext`j - 1}], 
         1]; $CellContext`segments = Flatten[
         Table[{
           Part[$CellContext`pts, $CellContext`i], 
           Part[$CellContext`pts, $CellContext`j]}, {$CellContext`j, 
           6}, {$CellContext`i, $CellContext`j - 1}], 
         1]; $CellContext`triangles = Subsets[
         Range[6], {3}]; $CellContext`monochromaticQ[
         Pattern[$CellContext`coloring, 
          Blank[]], 
         Pattern[$CellContext`triangle, 
          Blank[]]] := 1 == Length[
          Union[
           Map[Map[Part[$CellContext`coloring, #]& , 
             Position[$CellContext`edges, #]]& , 
            Subsets[$CellContext`triangle, {2}]]]]); 
     Typeset`initDone$$ = True),
    SynchronousInitialization->True,
    UnsavedVariables:>{Typeset`initDone$$},
    UntrackedVariables:>{Typeset`size$$}], "Manipulate",
   Deployed->True,
   StripOnInput->False],
  Manipulate`InterpretManipulate[1]]], "Output",
 CellGroupingRules->{"GroupTogetherGrouping", 10000.},
 CellChangeTimes->{3.760725160021023*^9},
 CellID->1214944692]
}, {2}]]