Question about designing a particular data structure

Question

Background: I store polygons with a color assigned at the face level. In some occasions I want to use vertex colors but I want to store data efficiently, i.e. don't want to duplicate data to the vertex level when it is not necessary.

Consider the following simplified data structure ( I had in mind, but does not work ):

 tf := TableForm
 def = {{10, 20}, {30, 40}};
 def2 = Array[def &, 12];
 col = {def2, def2};
 pcl := {{col[[1]], col[[1]], col[[1]], col[[1]]}, {col[[2]], col[[2]]}};

 col[[1]] // tf
 col[[2]] // tf
 pcl[[1]] // tf
 pcl[[2]] // tf

def represents the data of one instance of a shape;

def2 represents the data of a shape with p6mm symmetry ( 12 copies );

col={def, def} represents the main data structure which currently stores two shapes;

pcl={{col[[1]], col[[1]], col[[1]], col[[1]]}, {col[[2]], col[[2]]}} represents the desired data structure which currently stores two shapes with the first having four vertices and the second two vertices;

Now if I set col[[1,1,1]] to {11,21} this shows up in pcl. So far, so good.

I can't however overwrite it at the vertexlevel pcl[[1,1,1,1]]={12,22} Mathematica generates a Set::noval: Symbol pcl in part assignment does not have an immediate value. >> message.

Question: How do I set up the required data structure such that a change at the face level propagates through all vertices unless a vertex has been modified for that particular shape?

Answer 1

Preamble

I think this is a very good question. Trying to address it in a reasonably general way, I ended up with a tiny framework which implements a limited form of pointer-like semantics, which I'd like to describe and illustarate.

Code

This allows one to mark some portion of the code (some expression) as a reference.

ClearAll[Ptr, new, llp];
SetAttributes[{Ptr, new}, HoldAll];
Protect[Ptr, llp];

new[data_] :=
  Module[{st },
    Hold[data] /. p_new :> With[{eval = p}, eval /; True] /.
      Hold[d_] :> (st = Unevaluated[d]) ;
    Ptr[st]
  ];

This returns the lowest-level "pointer" inside a given expression containing a given part, if any, with a number of residual indices needed to extract that part.

Clear[llptr];
llptr[p_Ptr] := {p, 0};
llptr[expr_] := llp;
llptr[p : Ptr[s_], ind_, inds___] :=
  Block[{llp = {p, Length[{inds}] + 1}}, llptr[s, ind, inds]];
llptr[expr_, ind_, inds___] := llptr[expr[[ind]], inds];

This implements a special assignment operator which can work with the "pointers", including part assignments:

ClearAll[set];
SetAttributes[set, HoldFirst];
set[Part[expr_, inds__], rhs_] := 
   With[{lp = llptr[expr, inds]},
      (lp /. {p : Ptr[s_], num_} :> 
        (s[[Sequence @@ Take[{inds}, -num]]] = rhs)) /; 
            First[lp] =!= llp];

set[lhs_, rhs_] :=
   With[{l = lhs},
     Replace[l, Ptr[s_] :> Remove[s]];
     Set[lhs, rhs]];

This implements a custom Part operator, which has special semantics on "pointers":

ClearAll[part];
part[expr_, inds : PatternSequence[_, __]] :=
    Fold[part, expr, {inds}];
part[Ptr[s_], ind_] := part[s, ind];
part[expr_, ind_] := expr[[ind]];

In particular, any number of reference layers is invisible for the part, so the results of part should be the same as those of Part on expression not containing references but otherwise the same.

This performs a complete "dereferencing" of an expression, converting it to a "normal" one:

ClearAll[derefAll];
derefAll[expr_] := expr //. Ptr[s_] :> s

Illustration

I take your example with slightly smaller sizes of elements to keep this managable here. This is how it would look:

tf := TableForm
def ~ set ~ new@{{10, 20}, {30, 40}};
def2 ~ set ~ new@Array[def &, 4];
col ~ set ~ new@{def2, def2};
pcl ~ set ~ new@{{part[col, 1], part[col, 1]}, {part[col, 2]}};

Now, some examples:

pcl

(* Ptr[st$1074] *)

part[pcl,1]

(*  {Ptr[st$1072],Ptr[st$1072]}  *)

part[pcl,1,1]

(*  Ptr[st$1072]  *)

part[pcl,1,1]//derefAll

(*  {{{10,20},{30,40}},{{10,20},{30,40}},{{10,20},{30,40}},{{10,20},{30,40}}} *)

part[pcl,1,1,1]

(*  Ptr[st$1071]  *)

derefAll@part[pcl,1,1,1]

(*   {{10,20},{30,40}}  *)

For parts below the lowest-level pointer, you don't need dereferencing:

part[pcl,1,1,1,1]

{10,20}

part[pcl,1,1,1,1,1]

(* 10  *)

part[pcl,1,1,1,1,2]

(* 20 *)

Now we reset some part to something else:

pcl[[1,1,1]]~set~new@{new@{50,60},new@{70,80}}

(* Ptr[st$1175] *)

And check:

derefAll@pcl

(*  
    {{{{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}}},
    {{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}}}},
    {{{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}}}}}
*)

We see that it propagated to all parts. Now we change it in a different way, through a variable:

def2=new@Array[def&,3];
derefAll@pcl

(*
     {{{{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}}},
     {{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}}}},
     {{{{50,60},{70,80}},{{50,60},{70,80}},{{50,60},{70,80}}}}}
*)

We see that again, the change propagated properly. Now we change some other variable:

def~set~new@{{1,2},{3,4}}

(* Ptr[st$1219] *)

and

derefAll@pcl

(* 
    {{{{{1,2},{3,4}},{{1,2},{3,4}},{{1,2},{3,4}}},
    {{{1,2},{3,4}},{{1,2},{3,4}},{{1,2},{3,4}}}},
    {{{{1,2},{3,4}},{{1,2},{3,4}},{{1,2},{3,4}}}}}
*)

we see that again the changes propagated. Here is some part of a new expression:

part[pcl,1,1,1]//derefAll

(* {{1,2},{3,4}} *)

We now change the part by a part assignment:

pcl[[1,1,1]]~set~new@{{5,6},{7,8}}

(* Ptr[st$1250] *)

What is interesting, and it shows some consistency of our approach, that this change propagated to the variables:

def//derefAll

(* {{5,6},{7,8}} *)

And again:

pcl[[1,1,1,1]]~set~{9,10}

(* {9,10} *)

def//derefAll

(*  {{9,10},{7,8}} *)

Remarks and conclusions

I have presented a tiny framework implementing a limited version of the pointer semantics. It allows one to introduce mutable state within expressions and propagate changes in a relatively straightforward manner.

The weakest point currently is garbage collection. I have a very primitive form of it implemented in set assignment, but I can easily imagine cases where some dangling symbols may be created. I hope to improve on that in the future, if there is enough interest for this.

Answer 2

You could do something like this (draft)

c = Red;
pcl := {c, Blue};

Module[{preserve, pcl1},
 reset[] := (pcl1 = pcl; preserve = {});
 reset[];
 SetAttributes[set, HoldAll];
 set[element_, value_] :=
  (AppendTo[preserve, {element, value}]; 
   pcl1 = pcl; (pcl1[[#[[1]]]] = #[[2]]) & /@ preserve);
 print[] := preserve;
 get[] := (pcl1 = pcl; (pcl1[[#[[1]]]] = #[[2]]) & /@ preserve; pcl1);
 ]
reset[];