oftenpaper.net

matrix replacement 3D 1 ™


  1. 
    
    
    
    
    
    (**)
    Begin["mmx`"];
    
    matrixInput3D1[Dynamic[tensor_], Dynamic[color_], options___] :=
      Dynamic@Module[{grid},
        grid = Position[ArrayPad[tensor, {0, -1}], _?IntegerQ];
    
        EventHandler[#, {"MouseDown", 2} :> {}] &@
           Graphics3D[{#, Transparent, EdgeForm[LightGray], Cuboid /@ grid},
            options,(*Method->{"ShrinkWrap"->True},*)Boxed -> False] &@
    
         Array[With[{loc := tensor[[##]]},
            Mouseover[
             (**){Style[#, Darker[color, .65]] &@
               Text[Dynamic[loc /. 0 -> Style[0, Opacity[.5]]], {##}],
              Opacity[loc /. {0 -> .1, 1 -> .3}], Sphere[{##}, .2]},
             (**){Text[EventHandler[Checkbox[Dynamic[loc], {0, 1}],
                {"MouseDown", 2} :> (loc = 0)], {##}],
              Opacity[.01], Sphere[{##}, .2]}]] &,
          Dimensions[tensor]]];
    
    matrixInput3D2[Dynamic[tensor_], Dynamic[rules_], Dynamic[color_], options___] :=
      Dynamic@DynamicModule[{grid},
        grid = Flatten[Array[List, Dimensions[ArrayPad[tensor, {0, -1}]]], 2];
    
        EventHandler[#, {"MouseDown", 2} :> {}] &@
           Graphics3D[{#, Transparent, EdgeForm[LightGray], Cuboid /@ grid},
            options,(*Method->{"ShrinkWrap"->True},*)Boxed -> False] &@
    
         Array[With[{loc := tensor[[##]]},
            With[{display = Tooltip[Panel[#, FrameMargins -> None],
                 Column[{loc /. rules /. {Reverse -> "R", Transpose -> "T",
                     Composition -> List, Verbatim[Slot][_] :> "m"},
                   "", "Click to cycle", "Right-click to zero"}],
                 TooltipDelay -> .6] &},
    
             Mouseover[
              (**){Style[#, Darker[color, .65]] &@
                Text[Dynamic[loc /. 0 -> Style[0, Opacity[.5]]], {##}],
               Opacity[loc /. {0 -> .1, _ -> .3}], Sphere[{##}, .2]},
              (**){Text[EventHandler[
                 display[
                  Toggler(*PopupMenu*)[Dynamic[loc], First /@ rules,
                   ImageSize -> Automatic]
                  ],
                 {"MouseDown", 2} :> (loc = 0)], {##}],
               Opacity[.01], Sphere[{##}, .2]}]]] &,
          Dimensions[tensor]]];
    
    bg = White;
    dims = # -> If[# > 2, Style[#, Red], #] & /@ Range[5];
    
    rotations = Flatten@Outer[Function[{o, dir},
         Composition[Transpose[#, o] &, dir /@ # &, Transpose[#, o] &]],
        {{1, 2, 3}, {3, 2, 1}, {2, 1, 3}},
        {Composition[Transpose, Reverse],
         Composition[Reverse, Transpose],
         Reverse, Transpose}, 1];
    
    rotations = MapIndexed["S" @@ #2 -> #1 &, rotations];
    defaultRules = Join[{0 -> (0 # &), 1 -> (# &)}, rotations];
    
    iterate[matrix0_, matrixT_, rules_, power_] :=
      Nest[Function[prev,
        ArrayFlatten[Map[#[prev] &,
          Replace[matrixT, rules, {3}], {3}], 3]],
       matrix0, power];
    
    randomMatrix[dimensions_, source_] := With[
       {rv := RandomVariate[ZipfDistribution[Length[source], 1]]},
       Array[source[[rv]] &, dimensions]];
    
    With[{HiPrint := Function[viewpoint,
        With[{pow = power},
         CellPrint[ExpressionCell[
           Defer[
            powzerz = pow;
            With[{objects = Translate[primitive,
                Replace[Position[iterate[
                   matrix0 /. 0 matrix0 -> {{{1}}},
                   matrixT /. 0 matrixT -> {{{1}}},
                   rules, powzerz], If[negativeSpace, 0, 1]],
                 {} -> {1, 1, 1}]]},
             ImageResize[Rasterize[#], Scaled[1/4]] &@
              Defer[Graphics3D][{color, Opacity[opacity],
                Glow[glow], Specularity[specularity],
                EdgeForm[{Opacity[opacity], Darker[color, 4 .15]}], objects},
               Lighting -> "Neutral", Method -> {"ShrinkWrap" -> True},
               ImageSize -> {Automatic, 4 732}, Boxed -> False,
               ViewPoint -> viewpoint, ViewVertical -> vv,
               Background -> background]]],
           "Input"]]]],
    
      printMatrices := Function[
        CellPrint[ExpressionCell[DynamicModule[{
            mtx0 = matrix0, mtxT = matrixT, mtx0o = matrix0, mtxTo = matrixT,
            clr = color, opc = opacity, ns = negativeSpace, pow = power, rls = rules,
            prm = primitive, iter = iterate, bg = background, vp1 = vp, vv1 = vv},
    
           With[{
             btn = Button[DynamicWrapper["print data",
    
                If[mtx0 =!= mtx0o || mtxT =!= mtxTo, mtx0 = mtx0o; mtxT = mtxTo]],
               Print[Grid[{
                  {"kernel matrix", MatrixForm[mtx0o]},
                  {"transformation matrix", MatrixForm[mtxTo]},
                  {"rules", rls}, {"power", pow}}]]],
             mtx0c = matrixInput3D1[Dynamic[mtx0], Dynamic[clr],
               SphericalRegion -> True, ImageSize -> Small,
               Background -> Lighter[bg, .8],
               ViewPoint -> Dynamic[vp1], ViewVertical -> Dynamic[vv1]],
             mtxTc = matrixInput3D2[Dynamic[mtxT], Dynamic[rls], Dynamic[clr],
               SphericalRegion -> True, ImageSize -> Small,
               Background -> Lighter[bg, .8],
               ViewPoint -> Dynamic[vp1], ViewVertical -> Dynamic[vv1]],
             g3d = With[{objects = Translate[prm,
                  Replace[Position[iter[
                     mtx0 /. 0 mtx0 -> {{{1}}},
                     mtxT /. 0 mtxT -> {{{1}}},
                     rls, pow], If[ns, 0, 1]],
                   {} -> {1, 1, 1}]]},
               Graphics3D[{
                 EdgeForm[{Opacity[opc], Darker[clr, 4 .15]}],
                 clr, Opacity[opc], objects},
                ImageSize -> Small, Boxed -> False, SphericalRegion -> True,
                ViewPoint -> Dynamic[vp1], ViewVertical -> Dynamic[vv1],
                Lighting -> "Neutral", Background -> bg]]},
    
            Panel[Grid[{
               {Panel[Placeholder["name"]], SpanFromLeft, btn},
               {mtx0c, mtxTc, g3d}}]]]]]]],
    
      (* controls *)
      dim0C = Control[{{dim0, 1, ""}, dims, ControlType -> PopupMenu}],
      dimTC = Control[{{dimT, 2, ""}, dims, ControlType -> PopupMenu}],
      matrix0C = matrixInput3D1[Dynamic[matrix0], Dynamic[color],
        SphericalRegion -> True, ImageSize -> Dynamic[imgSize1],
        Background -> Dynamic[Lighter[background, .8]],
        ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv]],
      matrixTC = matrixInput3D2[Dynamic[matrixT], Dynamic[rules], Dynamic[color],
        SphericalRegion -> True, ImageSize -> Dynamic[imgSize2],
        Background -> Dynamic[Lighter[background, .8]],
        ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv]],
      rulesC = Pane[Style[#, 10], {400, 200}, Scrollbars -> Automatic] &@
        Control[{{rules, defaultRules, ""},
          InputField, Background -> Dynamic[Lighter[background, .65]],
          FieldSize -> {50, {0., Infinity}}}],
      colorC =
       Control[{{color, RGBColor[.15, .6, 1], "color"}, ColorSlider}],
      backgroundC = Row[{"background   ", Framed[
          ColorSlider[Dynamic[background, (bg = background = #) &],
           AppearanceElements -> "Swatch"],
          FrameStyle -> Gray], " ",
         ColorSlider[Dynamic[background, (bg = background = #) &],
          AppearanceElements -> "Spectrum", ImageSize -> Small]}],
      opacityC = Control@{{opacity, 1, "opacity"}, 0, 1, ImageSize -> Small},
      glowC = Control[{{glow, Black, "glow"}, ColorSlider}],
      specC = Control[{{specularity, Black, "specularity"}, ColorSlider, ImageSize -> Small}],
      primC = Control[{{primitive, Scale[Cuboid[],.99999], "primitive"},
         # -> Graphics3D[{color, #}, Boxed -> False, ImageSize -> 20] & /@
          {{PointSize[0], Point[{0., 0., 0.}]}, Sphere[{0., 0., 0.}, .5],
           {EdgeForm[None], Scale[Cuboid[],.99999]}, Scale[Cuboid[],.99999]}, SetterBar}],
      powerC = Control[{{power, 1, "power"}, 0, 5, 1, Appearance -> "Labeled"}],
      nsC = Control[{{negativeSpace, False,
          Tooltip["negative", "negative space",
           TooltipDelay -> .4]}, {False, True}}]
      },
    
     (*control layout*)
     With[{controls :=
        Row[{
          Column[{
            Row[{dim0C, "   |", dimTC}],
            Row[{"    ", matrix0C, "  ", matrixTC}]}], Spacer[40],
          Column[{
            OpenerView[{"Rules", rulesC}],
            OpenerView[{"Style",
              Column[{
                Row[{
                  Column[{colorC, backgroundC}], Spacer[40],
                  Column[{glowC, specC}]}],
                Row[{opacityC, Spacer[20], nsC, Spacer[20], primC}]}]}],
            powerC}]}],
    
       bookmarks := {
         Overscript["Random kernel matrix", ""] :>
           (matrix0 = randomMatrix[Dimensions[matrix0], {0, 1}]),
         "Random transformation matrix" :>
           (matrixT = randomMatrix[Dimensions[matrixT], First /@ defaultRules]),
         "Random both" :> (
           matrix0 = randomMatrix[Dimensions[matrix0], {0, 1}];
           matrixT = randomMatrix[Dimensions[matrixT], First /@ defaultRules]),
    
         Overscript["Clear kernel matrix", ""] :> (matrix0 = 0 matrix0),
         "Clear transformation matrix" :> (matrixT = 0 matrixT),
         "Clear both" :> ({matrix0, matrixT} = 0 {matrix0, matrixT}),
    
         Overscript["Invert kernel matrix", ""] :> (matrix0 = BitXor[matrix0, 1]),
         "Invert transformation matrix" :> (matrixT = Replace[matrixT, {0 -> 1, _ -> 0}, {3}]),
    
         Overscript["Print matrices", ""] :> printMatrices[],
    
         Overscript["HiPrint", ""] :> HiPrint[vp],
         "HiPrint Far" :> HiPrint[1000 vp]}},
    
      Panel[#, Background -> Dynamic[bg]] &@
       Manipulate[Module[{g3d, side},
    
         If[dim0 {1, 1, 1} =!= Dimensions[matrix0], matrix0 = PadRight[matrix0, dim0 {1, 1, 1}]];
         If[dimT {1, 1, 1} =!= Dimensions[matrixT], matrixT = PadRight[matrixT, dimT {1, 1, 1}]];
         If[bg =!= background, bg = background];
    
         Module[{matrixP},(*remove rules from matrix that no longer exist*)
          matrixP = Map[Function[a, If[a === Replace[a, rules], rules[[1, 1]], a]], matrixT, {3}];
          If[matrixT =!= matrixP, matrixT = matrixP]];
    
         g3d = With[{objects = Translate[primitive,
              Replace[Position[iterate[
                 matrix0 /. 0 matrix0 -> {{{1}}},
                 matrixT /. 0 matrixT -> {{{1}}},
                 rules, power], If[negativeSpace, 0, 1]],
               {} -> {1, 1, 1}]]},
           Graphics3D[{
             Dynamic[EdgeForm[{Opacity[opacity], Darker[color, 4 .15]}]],
             Dynamic[color], Dynamic[Opacity[opacity]], Dynamic[Glow[glow]],
             Dynamic[Specularity[specularity]], objects},
            ImageSize -> {{300, Large}, {300, Large}},
            Lighting -> "Neutral", Background -> Dynamic[background]]];
    
         side = Map[Function[vp1,
            Tooltip[#, ViewPoint -> vp1, TooltipDelay -> .3] &@
    
               EventHandler[#,
                "MouseDown" :> (vp = vp1 /. Infinity -> 4; vv = {0, 0, 1})] &@
             Framed[Deploy[
               Show[g3d, ViewPoint -> vp1, ImageSize -> Small, Boxed -> False]],
              FrameStyle -> Gray, Background -> Dynamic[background]]],
           Permutations[{Infinity, 0, 0}]];
    
         Row[{Column[side,(*Dividers->All,*)FrameStyle -> Gray],
           Show[g3d, Boxed -> False, SphericalRegion -> True,
            (*PlotRangePadding->.001,*)
            ViewPoint -> Dynamic[vp], ViewVertical -> Dynamic[vv]]}]
         ],
    
        {{vv, {0, 0, 1}}, ControlType -> None},
        {{vp, {1.3, -2.4, 2}}, ControlType -> None},
        {{imgSize1, Small},
         ControlType ->
          None},(*prevent matrix controls from autoresizing*)
        {{imgSize2, Small}, ControlType -> None},
        {{background, White}, ControlType -> None},
        {{matrix0,
          If[dim0 < 2, {{{1}}}, randomMatrix[dim0 {1, 1, 1}, {0, 1}]]},
         ControlType -> None},
        {{matrixT,
          If[dimT < 2, {{{1}}},
           randomMatrix[dimT {1, 1, 1}, First /@ defaultRules]]},
         ControlType -> None},
        controls, Bookmarks :> bookmarks,
        LabelStyle -> Darker[Gray], SynchronousUpdating -> Automatic,
        Paneled -> False, SaveDefinitions -> True, Alignment -> Center]]]
    
    (**)
    End[];
    
    
    
    
    
    
    

This page is an excerpt from the sierpinski triangle page to end most sierpinski triangle pages ™.