Match each primitive with relevant directives in GraphicsComplexBox

Question

I am struggling to write the correct pattern to match all ArrowBox objects with the relevant graphic directives in following snippet

{
    Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
    {
        Arrowheads[0.],
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299], 
    ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299],
    {
        Arrowheads[0.],
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    }, 
    ArrowBox[BezierCurveBox[{2, {0.890575, 0.349397}, 1}], 0.0127299], 
    ArrowBox[BezierCurveBox[{3, {0.391162, 0.515612}, 1}], 0.0127299]
}

To generate the same code, use this snippet which extracts it from a GraphicsComplexBox:

g = Block[{Identity}, 
  Graph[{1 <-> 2, 2 <-> 3, 1 -> 3, 2 -> 1, 2 -> 3, 3 -> 1}, 
    EdgeWeight -> Identity /@ {{0, 0}, {0, 0}, {1, 0}, {0, 1}, {1, 0}, {0, 1}}]];
Cases[ToBoxes[g], _GraphicsComplexBox, Infinity][[1, 2, 1]]

I try to improve the answer https://mathematica.stackexchange.com/a/169265/13042 so it works with other graphs as well. The following part of the solution in the referenced answer does not work as intended for the above given graph:

Cases[ToBoxes[g], {dir___, ar : Longest[__ArrowBox], ___} :> 
(## & @@ Thread[{dir, {ar}}]), Infinity]

It returns

{
    {
        Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    {
        Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299], 
        ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299]
    }
}

There are several issues

• the last two ArrowBox objects are missing
• contains a duplicate ArrowBox, and
• graphic directives are not properly handled.

The output should look like

{
    {
        Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299]},
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299]
    },
    {
        Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.], 
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{2, {0.890575, 0.349397}, 1}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], 
        ArrowBox[BezierCurveBox[{3, {0.391162, 0.515612}, 1}], 0.0127299]
    }
}

General scheme is

{
    directivesLevel1,
    RepeatedPattern[ primitive | {directivesLevel2, primitive}]
}

which should return with the replacement rule

{
    {directivesLevel1, primitive} OR
    {directiveslevel1, directivesLevel2, primitive},
    ...
}

Other graphs for more extensive testing

g2 = Block[{Identity}, 
  Graph[{1 <-> 2, 1 <-> 3, 2 <-> 3, 2 <-> 4, 2 <-> 5, 4 <-> 5, 5 <-> 6, 3 <-> 6, 3 <-> 7,
    6 <-> 7, 4 -> 3, 4 -> 1, 7 -> 2, 6 -> 4, 5 -> 1, 6 -> 1, 7 -> 1, 5 -> 7}, 
    EdgeWeight ->  Identity /@ Join[Table[{0, 0}, 10], {{1, 0}, {1, 0}, {0, 1}, {0, 1},
        {1, 1}, {1, 1}, {0, 1}, {1, 0}}]]]

g3 = Block[{Identity}, 
  Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 6, 2 <-> 3, 3 <-> 4, 4 <-> 5, 4 <-> 6, 5 <-> 6,
    1 -> 5, 2 -> 5, 2 -> 4, 5 -> 3, 6 -> 3, 6 -> 2}, 
    EdgeWeight -> Identity /@ Join[Table[{0, 0}, 9], Table[{0, 1}, 3], Table[{1, 0}, 3]]]]

To see all errors, run

ClearAll[displayWeightedMultiGraph]
displayWeightedMultiGraph = Module[{i = 1, j, g = #, bcurves,
  labels = PropertyValue[#, EdgeWeight], 
  gccoords = Cases[ToBoxes[#], GraphicsComplexBox[x_, y_, z___] :> x, Infinity][[1]]}, 
  bcurves = Cases[ToBoxes[g], {dir___, ar : Longest[__ArrowBox], ___} :> 
    (## & @@ Thread[{dir, {ar}}]), Infinity] /. 
  {ArrowBox[BezierCurveBox[x_, y___], z___] :> 
     Arrow[BezierCurve[x /. k_Integer :> gccoords[[k]], y], z], 
   ArrowBox[x : {__}, y_] :> Arrow[gccoords[[x]], y]}; 
   SetProperty[g, EdgeShapeFunction -> ({j = i++; Text[labels[[j]], 
     BezierFunction[#, SplineDegree -> 7][0.5]], bcurves[[j]]} &)]] &;

displayWeightedMultiGraph/@{g, g2, g3}

Answer 1

As I said in my comment, I think it's much more straightforward to use Show to create the equivalent Graphics object. Then, you can use Normal to convert the GraphicsComplex into normal primitives. However, there is an issue with Normal and BezierCurve objects that are nested inside of other primitives, partly discussed in (104818). For example:

Normal @ GraphicsComplex[
    {{1,1}, {1.25,1.75}, {2,2}},
    Arrow[BezierCurve[{1, 2, 3}], .1]
]

{Arrow[BezierCurve[{1, 2, 3}], 0.1]}

The integer indices of the BezierCurve have not been replaced with the coordinates from the first argument of the GraphicsComplex. On the other hand, when the primitives are not nested, Normal works:

Normal @ GraphicsComplex[{{1,1}, {1.25,1.75}, {2,2}}, BezierCurve[{1, 2, 3}]]
Normal @ GraphicsComplex[{{1,1}, {1.25,1.75}, {2,2}}, Arrow[{1, 2, 3}, .1]]

{BezierCurve[{{1, 1}, {1.25, 1.75}, {2, 2}}]}

{Arrow[{{1, 1}, {1.25, 1.75}, {2, 2}}, 0.1]}

Here is a patch the fixes the nested BezierCurve issue:

Unprotect[Normal];
Normal[g_] /; !TrueQ@$BZFix := Block[{$BZFix=True},
    Normal[g /. gc_GraphicsComplex :> fixGC[gc]]
]

fixGC[GraphicsComplex[pts_, prim_, rest___]] := GraphicsComplex[
    pts,
    prim /. BezierCurve[p_, r___] :> BezierCurve[p /. i_Integer :> pts[[i]], r],
    rest
]

Check:

Normal @ GraphicsComplex[{{1,1}, {1.25,1.75}, {2,2}}, Arrow[BezierCurve[{1, 2, 3}], .1]]

{Arrow[BezierCurve[{{1, 1}, {1.25, 1.75}, {2, 2}}], 0.1]}

For your first example graph:

g = Block[{Identity}, 
    Graph[
        {1 <-> 2, 2 <-> 3, 1 -> 3, 2 -> 1, 2 -> 3, 3 -> 1}, 
        EdgeWeight -> Identity /@ {{0, 0}, {0, 0}, {1, 0}, {0, 1}, {1, 0}, {0, 1}}
    ]
];

We get:

Normal @ Show @ g //InputForm

Graphics[{{Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], {Arrowheads[0.], Arrow[BezierCurve[{{0.49692221124371655, 0.}, {0.6063408473035717, 0.5148479095999602}, {0.9999936484762257, 0.8642449331499502}}], 0.012729919145102353]}, Arrow[BezierCurve[{{0.49692221124371655, 0.}, {0.1057602447225488, 0.3521832484933547}, {0., 0.8677950164043108}}], 0.012729919145102353], Arrow[BezierCurve[{{0.9999936484762257, 0.8642449331499502}, {0.49941304589520347, 0.7015802720433176}, {0., 0.8677950164043108}}], 0.012729919145102353], {Arrowheads[0.], Arrow[BezierCurve[{{0.9999936484762257, 0.8642449331499502}, {0.5005806025810231, 1.0304596775108001}, {0., 0.8677950164043108}}], 0.012729919145102353]}, Arrow[BezierCurve[{{0.9999936484762257, 0.8642449331499502}, {0.8905750124163706, 0.3493970235499975}, {0.49692221124371655, 0.}}], 0.012729919145102353], Arrow[BezierCurve[{{0., 0.8677950164043108}, {0.3911619665211691, 0.5156117679108979}, {0.49692221124371655, 0.}}], 0.012729919145102353]}, {Directive[Hue[0.6, 0.2, 0.8], EdgeForm[Directive[GrayLevel[0], Opacity[0.7]]]], Disk[{0.49692221124371655, 0.}, 0.012729919145102353], Disk[{0.9999936484762257, 0.8642449331499502}, 0.012729919145102353], Disk[{0., 0.8677950164043108}, 0.012729919145102353]}}, {FormatType -> TraditionalForm, FrameTicks -> None}]

You'll notice that all of the BezierCurve objects have actual coordinates, available to be extracted by your displayWeightedMultiGraph function.

Answer 2

I have figured out a possible solution

primitiveQ[p_] := Head[p] === ArrowBox;
directiveQ[d_] := Head[d] === Arrowheads || Head[d] === Directive;
list = Cases[ToBoxes[g], _GraphicsComplexBox, Infinity][[1, 2, 1]];
dirlevel1 = Cases[list, _?directiveQ];
Cases[list, ar_?primitiveQ|{dir___,ar_?primitiveQ} :> Flatten[{dirlevel1, dir, ar}]]

This returns

{
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.],
        ArrowBox[BezierCurveBox[{1, {0.606341, 0.514848}, 2}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{1, {0.10576, 0.352183}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{2, {0.499413, 0.70158}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]], Arrowheads[0.],
        ArrowBox[BezierCurveBox[{2, {0.500581, 1.03046}, 3}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{2, {0.890575, 0.349397}, 1}], 0.0127299]
    },
    {
        Arrowheads[Medium], Directive[Opacity[0.7], Hue[0.6, 0.7, 0.5]],
        ArrowBox[BezierCurveBox[{3, {0.391162, 0.515612}, 1}], 0.0127299]
    }
}

Remaining improvements

• remove duplicate directives keeping the last (here Arrowheads)
• better predicates primitiveQ and directiveQ

I am not too experienced: maybe this code contains unnecessary copies of lists.