Cell[CellGroupData[{Cell[BoxData[ RowBox[{ RowBox[{ RowBox[{"projectionOperator", "[", RowBox[{"{", RowBox[{"n_", ",", "k_", ",", "q_"}], "}"}], "]"}], ":=", RowBox[{"Thread", "[", RowBox[{"Rule", "[", RowBox[{ RowBox[{"Range", "[", RowBox[{ RowBox[{ RowBox[{"-", "1"}], "+", RowBox[{"k", "^", "q"}]}], ",", "0", ",", RowBox[{"-", "1"}]}], "]"}], ",", RowBox[{"IntegerDigits", "[", RowBox[{"n", ",", "k", ",", RowBox[{"k", "^", "q"}]}], "]"}]}], "]"}], "]"}]}], ";"}]], "Input", CellGroupingRules->{"GroupTogetherGrouping", 10000.}, CellChangeTimes->{{3.3858064694020863`*^9, 3.385806562976138*^9}, { 3.385806598675548*^9, 3.3858066639442387`*^9}, { 3.385821551661881*^9, 3.3858215690083714`*^9}, 3.3859136796726494`*^9, 3.760839380095047*^9}, CellID->223062173], Cell[BoxData[ RowBox[{ RowBox[{ RowBox[{"projectedBlocks", "[", "blockSize_Integer", "]"}], ":=", RowBox[{"Append", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{"1", ",", "1"}], "}"}], ",", RowBox[{"{", RowBox[{"1", ",", "2"}], "}"}], ",", RowBox[{"{", RowBox[{"1", ",", "3"}], "}"}]}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"1", "+", "blockSize"}], ",", "2"}], "}"}]}], "]"}]}], ";"}]], "Input", CellGroupingRules->{"GroupTogetherGrouping", 10000.}, CellChangeTimes->{ 3.35696210375764*^9, {3.385852038333152*^9, 3.385852108827753*^9}, 3.3859136808288994`*^9, 3.760839380095182*^9}, CellID->1835729789], Cell[BoxData[ RowBox[{"Manipulate", "[", RowBox[{ RowBox[{"With", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"ca", "=", RowBox[{"CellularAutomaton", "[", RowBox[{"elementaryRule", ",", RowBox[{"IntegerDigits", "[", RowBox[{ RowBox[{"Round", "[", RowBox[{"initialConditions", "*", RowBox[{"(", RowBox[{ RowBox[{"-", "1"}], "+", SuperscriptBox["2", RowBox[{"3", RowBox[{"(", "blockSize", ")"}]}]]}], ")"}]}], "]"}], ",", "2", ",", RowBox[{"3", "*", "blockSize"}]}], "]"}], ",", "blockSize"}], "]"}]}], ",", " ", RowBox[{"projectionNumber", "=", RowBox[{"Round", "[", RowBox[{"projNo", "*", RowBox[{"(", RowBox[{ RowBox[{"-", "1"}], "+", SuperscriptBox["2", SuperscriptBox["2", "blockSize"]]}], ")"}]}], "]"}]}]}], "}"}], ",", RowBox[{"Grid", "[", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{"Labeled", "[", RowBox[{ RowBox[{"Graphics", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"MapIndexed", "[", RowBox[{ RowBox[{ RowBox[{"Text", "[", RowBox[{ RowBox[{"Style", "[", RowBox[{"#1", ",", "18"}], "]"}], ",", RowBox[{ RowBox[{"Reverse", "@", RowBox[{"(", RowBox[{"#2", "-", RowBox[{"{", RowBox[{"0", ",", "1"}], "}"}]}], ")"}]}], "*", RowBox[{"{", RowBox[{"1", ",", RowBox[{"-", "1"}]}], "}"}]}], ",", RowBox[{"{", RowBox[{ RowBox[{"-", "4"}], ",", RowBox[{"-", "1"}]}], "}"}]}], "]"}], "&"}], ",", RowBox[{"MapIndexed", "[", RowBox[{ RowBox[{ RowBox[{"ReplacePart", "[", RowBox[{"#", ",", RowBox[{"Join", "[", RowBox[{ RowBox[{"Table", "[", RowBox[{ RowBox[{"i", "->", RowBox[{"Style", "[", RowBox[{ RowBox[{"#", "[", RowBox[{"[", "i", "]"}], "]"}], ",", RowBox[{"GrayLevel", "[", "0.9", "]"}]}], "]"}]}], ",", RowBox[{"{", RowBox[{"i", ",", "1", ",", RowBox[{ RowBox[{"#2", "[", RowBox[{"[", "1", "]"}], "]"}], "-", "1"}]}], "}"}]}], "]"}], ",", RowBox[{"Table", "[", RowBox[{ RowBox[{ RowBox[{"-", "i"}], "->", RowBox[{"Style", "[", RowBox[{ RowBox[{"#", "[", RowBox[{"[", "i", "]"}], "]"}], ",", RowBox[{"GrayLevel", "[", "0.9", "]"}]}], "]"}]}], ",", RowBox[{"{", RowBox[{"i", ",", "1", ",", RowBox[{ RowBox[{"#2", "[", RowBox[{"[", "1", "]"}], "]"}], "-", "1"}]}], "}"}]}], "]"}]}], "]"}]}], "]"}], "&"}], ",", "ca"}], "]"}], ",", RowBox[{"{", "2", "}"}]}], "]"}], ",", RowBox[{"MapIndexed", "[", RowBox[{ RowBox[{ RowBox[{"With", "[", RowBox[{ RowBox[{"{", RowBox[{"c", "=", " ", RowBox[{ RowBox[{"Reverse", "@", RowBox[{"(", RowBox[{"#2", "-", "1"}], ")"}]}], "*", RowBox[{"{", RowBox[{"blockSize", ",", RowBox[{"-", "1"}]}], "}"}]}]}], "}"}], ",", RowBox[{"{", RowBox[{"If", "[", RowBox[{ RowBox[{"MemberQ", "[", RowBox[{ RowBox[{ "projectedBlocks", "[", "blockSize", "]"}], ",", "#2"}], "]"}], ",", RowBox[{"{", RowBox[{ RowBox[{"Text", "[", RowBox[{ RowBox[{"Style", "[", RowBox[{ RowBox[{ RowBox[{"FromDigits", "[", RowBox[{ RowBox[{"#", "[", RowBox[{"[", "1", "]"}], "]"}], ",", "2"}], "]"}], "/.", RowBox[{"If", "[", RowBox[{"showProjection", ",", RowBox[{"projectionOperator", "[", RowBox[{"{", RowBox[{ "projectionNumber", ",", "2", ",", "blockSize"}], "}"}], "]"}], ",", RowBox[{"{", "}"}]}], "]"}]}], ",", "24", ",", RowBox[{ RowBox[{ "ColorData", "[", "\"\\"", "]"}], "[", "0.8", "]"}], ",", RowBox[{ "FontWeight", "->", "\"\\""}]}], "]"}], ",", RowBox[{"Mean", "[", RowBox[{"{", RowBox[{"c", ",", RowBox[{"c", "+", RowBox[{"{", RowBox[{"blockSize", ",", RowBox[{"-", "1"}]}], "}"}]}]}], "}"}], "]"}]}], "]"}], ",", RowBox[{"Opacity", "[", "0.3", "]"}], ",", RowBox[{ RowBox[{ "ColorData", "[", "\"\\"", "]"}], "[", "0.2", "]"}], ",", RowBox[{"Rectangle", "[", RowBox[{"c", ",", RowBox[{"c", "+", RowBox[{"{", RowBox[{"blockSize", ",", RowBox[{"-", "1"}]}], "}"}]}]}], "]"}]}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"Opacity", "[", "0.2", "]"}], ",", RowBox[{"EdgeForm", "[", RowBox[{"AbsoluteThickness", "[", "1", "]"}], "]"}], ",", RowBox[{"Rectangle", "[", RowBox[{"c", ",", RowBox[{"c", "+", RowBox[{"{", RowBox[{"blockSize", ",", RowBox[{"-", "1"}]}], "}"}]}]}], "]"}]}], "}"}]}], "]"}], "}"}]}], "]"}], " ", "&"}], ",", RowBox[{"Partition", "[", RowBox[{"ca", ",", RowBox[{"{", RowBox[{"1", ",", "blockSize"}], "}"}], ",", RowBox[{"{", RowBox[{"1", ",", "blockSize"}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{"1", ",", "1"}], "}"}], ",", RowBox[{"{", RowBox[{"1", ",", "1"}], "}"}]}], "}"}]}], "]"}], ",", RowBox[{"{", "2", "}"}]}], "]"}]}], "}"}], ",", RowBox[{"Frame", "->", "False"}], ",", RowBox[{"ImageSize", "->", "500"}], ",", RowBox[{"AspectRatio", "->", RowBox[{"4", "/", "9"}]}]}], "]"}], ",", RowBox[{"Text", "@", "\"\\""}]}], "]"}], "}"}], ",", RowBox[{"{", RowBox[{"Labeled", "[", RowBox[{ RowBox[{"Text", "@", RowBox[{"Grid", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"Prepend", "[", RowBox[{ RowBox[{"Range", "[", RowBox[{ RowBox[{ RowBox[{"-", "1"}], "+", RowBox[{"2", "^", "blockSize"}]}], ",", "0", ",", RowBox[{"-", "1"}]}], "]"}], ",", RowBox[{ "Text", "@", "\"\\""}]}], "]"}], ",", RowBox[{"Prepend", "[", RowBox[{ RowBox[{"IntegerDigits", "[", RowBox[{"projectionNumber", ",", "2", ",", RowBox[{"2", "^", "blockSize"}]}], "]"}], ",", RowBox[{"Text", "@", "\"\\""}]}], "]"}]}], "}"}], ",", RowBox[{"Dividers", "->", "All"}], ",", RowBox[{"Background", "->", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"ColorData", "[", "1", "]"}], "[", "3", "]"}], "}"}], ",", "None"}], "}"}]}]}], "]"}]}], ",", RowBox[{"Text", "@", "\"\\""}]}], "]"}], "}"}]}], "}"}], "]"}]}], "]"}], ",", " ", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{ "initialConditions", ",", "0.52", ",", "\"\\""}], "}"}], ",", "0", ",", "1"}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{ "elementaryRule", ",", "110", ",", "\"\\""}], "}"}], ",", "0", ",", "255", ",", "1", ",", RowBox[{"Appearance", "->", "\"\\""}]}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{"blockSize", ",", "3", ",", "\"\\""}], "}"}], ",", "2", ",", "4", ",", "1", ",", RowBox[{"Appearance", "->", "\"\\""}]}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{ "projNo", ",", "0.46", ",", "\"\\""}], "}"}], ",", "0", ",", "1"}], "}"}], ",", RowBox[{"{", RowBox[{ RowBox[{"{", RowBox[{ "showProjection", ",", "False", ",", "\"\\""}], "}"}], ",", RowBox[{"{", RowBox[{"True", ",", "False"}], "}"}]}], "}"}], ",", RowBox[{"TrackedSymbols", "->", RowBox[{"{", RowBox[{ "initialConditions", ",", "elementaryRule", ",", "blockSize", ",", "projNo", ",", "showProjection"}], "}"}]}], ",", RowBox[{"SaveDefinitions", "->", "True"}], ",", RowBox[{"AutorunSequencing", "->", RowBox[{"{", RowBox[{"4", ",", "3", ",", "5", ",", "2", ",", "1"}], "}"}]}]}], "]"}]], "Input", CellGroupingRules->{"GroupTogetherGrouping", 10000.}, CellChangeTimes->{{3.385849839274988*^9, 3.3858502037853537`*^9}, { 3.385850260085403*^9, 3.385850262946494*^9}, {3.385850302214796*^9, 3.385850365492724*^9}, {3.385850431616877*^9, 3.385850472951325*^9}, {3.385850593203594*^9, 3.385850630053516*^9}, {3.385851240075033*^9, 3.385851258968149*^9}, {3.3858513035452223`*^9, 3.385851367930883*^9}, {3.385851402267864*^9, 3.385851738390945*^9}, {3.385851815641412*^9, 3.3858520210833406`*^9}, {3.3858521249207773`*^9, 3.385852231049471*^9}, {3.385852268959443*^9, 3.385852294083613*^9}, {3.385852327683199*^9, 3.3858523408323097`*^9}, {3.385852534435462*^9, 3.3858525441298523`*^9}, {3.3858526238514633`*^9, 3.3858527074089127`*^9}, {3.3858527476394167`*^9, 3.385852751726568*^9}, {3.3858527850263233`*^9, 3.38585278664962*^9}, {3.3858528460003843`*^9, 3.385852877224222*^9}, {3.385852907231389*^9, 3.385853156414476*^9}, {3.3858532107658567`*^9, 3.385853370425856*^9}, {3.385853527954269*^9, 3.3858535520664663`*^9}, {3.385853597563086*^9, 3.385853618686713*^9}, {3.385853654917989*^9, 3.385853658339774*^9}, {3.385853701688754*^9, 3.385853705949545*^9}, {3.385853982854838*^9, 3.385854009132559*^9}, {3.3858540608932056`*^9, 3.385854174007056*^9}, {3.3858542443351107`*^9, 3.385854295201065*^9}, {3.38585547911534*^9, 3.385855572640077*^9}, {3.385855631092464*^9, 3.385855645744012*^9}, {3.38585616800492*^9, 3.3858561832512093`*^9}, {3.3859137045788994`*^9, 3.3859137265163994`*^9}, 3.7608393800815697`*^9}, CellID->62877671], Cell[BoxData[ TagBox[ StyleBox[ DynamicModuleBox[{$CellContext`blockSize$$ = 3, $CellContext`elementaryRule$$ = 110, $CellContext`initialConditions$$ = 0.52, $CellContext`projNo$$ = 0.46, $CellContext`showProjection$$ = False, Typeset`show$$ = True, Typeset`bookmarkList$$ = {}, Typeset`bookmarkMode$$ = "Menu", Typeset`animator$$, Typeset`animvar$$ = 1, Typeset`name$$ = "\"untitled\"", Typeset`specs$$ = {{{ Hold[$CellContext`initialConditions$$], 0.52, "initial conditions"}, 0, 1}, {{ Hold[$CellContext`elementaryRule$$], 110, "elementary rule number"}, 0, 255, 1}, {{ Hold[$CellContext`blockSize$$], 3, "block size"}, 2, 4, 1}, {{ Hold[$CellContext`projNo$$], 0.46, "projection number"}, 0, 1}, {{ Hold[$CellContext`showProjection$$], False, "show projected values?"}, {True, False}}}, Typeset`size$$ = { 500., {154., 159.}}, Typeset`update$$ = 0, Typeset`initDone$$, Typeset`skipInitDone$$ = False, $CellContext`initialConditions$518114$$ = 0, $CellContext`elementaryRule$518115$$ = 0, $CellContext`blockSize$518116$$ = 0, $CellContext`projNo$518117$$ = 0, $CellContext`showProjection$518118$$ = False}, DynamicBox[Manipulate`ManipulateBoxes[ 1, StandardForm, "Variables" :> {$CellContext`blockSize$$ = 3, $CellContext`elementaryRule$$ = 110, $CellContext`initialConditions$$ = 0.52, $CellContext`projNo$$ = 0.46, $CellContext`showProjection$$ = False}, "ControllerVariables" :> { Hold[$CellContext`initialConditions$$, \ $CellContext`initialConditions$518114$$, 0], Hold[$CellContext`elementaryRule$$, \ $CellContext`elementaryRule$518115$$, 0], Hold[$CellContext`blockSize$$, \ $CellContext`blockSize$518116$$, 0], Hold[$CellContext`projNo$$, $CellContext`projNo$518117$$, 0], Hold[$CellContext`showProjection$$, \ $CellContext`showProjection$518118$$, False]}, "OtherVariables" :> { Typeset`show$$, Typeset`bookmarkList$$, Typeset`bookmarkMode$$, Typeset`animator$$, Typeset`animvar$$, Typeset`name$$, Typeset`specs$$, Typeset`size$$, Typeset`update$$, Typeset`initDone$$, Typeset`skipInitDone$$}, "Body" :> With[{$CellContext`ca$ = CellularAutomaton[$CellContext`elementaryRule$$, IntegerDigits[ Round[$CellContext`initialConditions$$ (-1 + 2^(3 $CellContext`blockSize$$))], 2, 3 $CellContext`blockSize$$], $CellContext`blockSize$$], \ $CellContext`projectionNumber$ = Round[$CellContext`projNo$$ (-1 + 2^(2^$CellContext`blockSize$$))]}, Grid[{{ Labeled[ Graphics[{ MapIndexed[Text[ Style[#, 18], Reverse[#2 - {0, 1}] {1, -1}, {-4, -1}]& , MapIndexed[ReplacePart[#, Join[ Table[$CellContext`i -> Style[ Part[#, $CellContext`i], GrayLevel[0.9]], {$CellContext`i, 1, Part[#2, 1] - 1}], Table[-$CellContext`i -> Style[ Part[#, $CellContext`i], GrayLevel[0.9]], {$CellContext`i, 1, Part[#2, 1] - 1}]]]& , $CellContext`ca$], {2}], MapIndexed[ With[{$CellContext`c$ = Reverse[#2 - 1] {$CellContext`blockSize$$, -1}}, { If[ MemberQ[ $CellContext`projectedBlocks[$CellContext`\ blockSize$$], #2], { Text[ Style[ ReplaceAll[ FromDigits[ Part[#, 1], 2], If[$CellContext`showProjection$$, $CellContext`projectionOperator[{$CellContext`\ projectionNumber$, 2, $CellContext`blockSize$$}], {}]], 24, ColorData["NeonColors"][0.8], FontWeight -> "Bold"], Mean[{$CellContext`c$, $CellContext`c$ + \ {$CellContext`blockSize$$, -1}}]], Opacity[0.3], ColorData["NeonColors"][0.2], Rectangle[$CellContext`c$, $CellContext`c$ + \ {$CellContext`blockSize$$, -1}]}, { Opacity[0.2], EdgeForm[ AbsoluteThickness[1]], Rectangle[$CellContext`c$, $CellContext`c$ + \ {$CellContext`blockSize$$, -1}]}]}]& , Partition[$CellContext`ca$, { 1, $CellContext`blockSize$$}, { 1, $CellContext`blockSize$$}, {{1, 1}, {1, 1}}], { 2}]}, Frame -> False, ImageSize -> 500, AspectRatio -> 4/9], Text["coarse graining"]]}, { Labeled[ Text[ Grid[{ Prepend[ Range[-1 + 2^$CellContext`blockSize$$, 0, -1], Text["unprojected value"]], Prepend[ IntegerDigits[$CellContext`projectionNumber$, 2, 2^$CellContext`blockSize$$], Text["projected value"]]}, Dividers -> All, Background -> {{ ColorData[1][3]}, None}]], Text["projections"]]}}]], "Specifications" :> {{{$CellContext`initialConditions$$, 0.52, "initial conditions"}, 0, 1}, {{$CellContext`elementaryRule$$, 110, "elementary rule number"}, 0, 255, 1, Appearance -> "Labeled"}, {{$CellContext`blockSize$$, 3, "block size"}, 2, 4, 1, Appearance -> "Labeled"}, {{$CellContext`projNo$$, 0.46, "projection number"}, 0, 1}, {{$CellContext`showProjection$$, False, "show projected values?"}, {True, False}}}, "Options" :> { TrackedSymbols -> {$CellContext`initialConditions$$, \ $CellContext`elementaryRule$$, $CellContext`blockSize$$, \ $CellContext`projNo$$, $CellContext`showProjection$$}, AutorunSequencing -> {4, 3, 5, 2, 1}}, "DefaultOptions" :> {ControllerLinking -> True}], ImageSizeCache->{545., {253., 259.}}, SingleEvaluation->True], Deinitialization:>None, DynamicModuleValues:>{}, Initialization:>({$CellContext`projectedBlocks[ Pattern[$CellContext`blockSize, Blank[Integer]]] := Append[{{1, 1}, {1, 2}, {1, 3}}, { 1 + $CellContext`blockSize, 2}], $CellContext`projectionOperator[{ Pattern[$CellContext`n, Blank[]], Pattern[$CellContext`k, Blank[]], Pattern[$CellContext`q, Blank[]]}] := Thread[Range[-1 + $CellContext`k^$CellContext`q, 0, -1] -> IntegerDigits[$CellContext`n, $CellContext`k, \ $CellContext`k^$CellContext`q]]}; 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.760839380081881*^9}, CellID->314286849] }, {4}]]