# MinimumIndexSet

Each week I'll be posting a recreational prograMing problem that has to do with Mathematica expression structures. This is the 3rd topic. Besides recreation, the goal is to expose and implement all Mathematica structure manipulation functions in Mathematica itself. The implemenation will be inclined towards a style that exposes a function's specification. In other words, we learn in no ambiguous terms what a function does. When possible, we'll also implement it using the most primitive methods, as to show how it can be easily translated into other languages.

Last week I posted a function FullArrayIndexSet. The solution I gave is incorrect. A correct solution is appended at the end.

This week's problem is MinimumIndexSet.

Mathematica expression can be thought of as a tree. An expression is essentially composed of atoms and brackets. Atom are the leaves of the tree, while brackets specify the structure. If we regard all atoms as the same (i.e. replacing all atoms by one symbol), then expressions differ only in structure. Each atom has an index. The set of all atom's indexes defines the shape of the expression. For example, the index set of the expression

{{f[1,1],f[1,2]},{f[2,1],f[2,2]}}

is

{{0},{1,0},{1,1,0},{1,1,1},{1,1,2},{1,2,0}, {1,2,1},{1,2,2},{2,0},{2,1,0},{2,1,1},{2,1,2}, {2,2,0},{2,2,1},{2,2,2}}

(calculated by (Position[#,_,{-1},Heads->True]&)@Array[f,{2,2}])

Notice that if a tree has an index {3}, it certainly implies the existence of a node with index {1}. Otherwise it doesn't make sense. In general, an index may imply many other indexes. For example, {2,2,2} implies {{0},{1},{2},{2,0},{2,1},{2,2},{2,2,0},{2,2,1},{2,2,2}}.

If we are given a set of indexes, we want a function MinimumIndexSet that reduces the indexes to a minimum, such that all other indexes are implied by the minimum set.

Solutions:

(*MinimumIndexSet------------------------*) Clear[MinimumIndexSet,MinimumIndexSet2,MinimumIndexSet3]; MinimumIndexSet::"usage"= "MinimumIndexSet[{index1,index2,...}] returns a modified version of \ argument in which indexes that can be inferred from other given indexes in it \ are deleted. Related: CompleteIndexSet, FullArrayIndexSet. Example: \ MinimumIndexSet[{{1},{2},{3},{2,3},{2,2},{2,3,7},{3,1}}]"; (*First approach: delete itself---------*) (* MinimumIndexSet specification: We are given a list of indexes. We go through each index and determine if it is redunant. If it is, then delete it. Suppose {a,b,c,d} is one index. It is redundant if MemberQ[givenIndexes,{a,b,c,x$_/;x$ > d}|{a,b,c,x$_/;x$ >= d,__}]. *) MinimumIndexSet[indexes_List]:= DeleteCases[indexes, PatternTest[_,( MemberQ[indexes, Replace[#,{frest___, last_}->({frest,x_/;(x>last)}|{frest, x_/;(x>=last),__})]]&)],{1}]; (* alternative approach: delete others: Another approach is to delete other indexes that is implied by a current index. Suppose {a,b,c,d} is an index, then it implies any indexes that matches one of {{x$_/;x$<=a},{a,x$_/;x$<=b},{a,b,x$_/;x$<=c},{a,b,c,x$_/;x$<d}}. *) (*here are two implementations of the "delete others" approach. *) (*MinimumIndexSet2 generates all patterns that needs to be deleted, for example: pattern1|pattern2|... then feed it to DeleteCases. MinimumIndexSet3 uses Fold to feed them one at a time to DeleteCases. *) MinimumIndexSet2[indexes_List]:= DeleteCases[indexes, Alternatives@@ Union@(Flatten[#,1]&)@ Map[Function[( ReplacePart[#,Last@#/.LessEqual->Less,-1]&)@( Table[Replace[ Take[#,i],{frest___,last_}->{frest,x_/;(x<=last)}],{ i,Length@#}]&)@#],indexes],{1}]; MinimumIndexSet3[indexes_List]:= Fold[Function[{expr, index},(DeleteCases[expr,#,{1}]&)@( Alternatives@@( ReplacePart[#,Last@#/.LessEqual->Less,-1]&)@( Table[Replace[ Take[#,i],{frest___,last_}->{frest,x_/;(x<=last)}],{i, Length@#}]&)@index)],indexes,Reverse@Sort@indexes]; (*testing*) (*the following testing code will need RandomIndexSet, which you can supply yourself if interested.*) Clear[li]; Do[li=RandomIndexSet[{0,4},{1,5},{1,20}]; If[MinimumIndexSet@li===MinimumIndexSet2@li===MinimumIndexSet3@li//Not, Print["fucked: ",li]],{100}]

There are surely other approaches, algorithms, implementations, and coding styles to MinimumIndexSet. Would you care to contribute one?

I've done some speed test on the three versions and some variants. Guess which one is faster? In summary, I'm quite amazed by how Mathematica build-in functions take care of things. Time after time my experience suggest that one should focus on efficiency (of algorithms), but never speed (i.e. how fast things are in a language). (otherwise you probably wouldn't be programing in Mathematica anyway.)

Here are corrections to last week's FullArrayIndexSet. We'll come back to it sometimes in the future.

Clear[FullArrayIndexSet,FullArrayIndexSet2]; FullArrayIndexSet::"usage"= "FullArrayIndexSet[{i1,i2,...},(Heads->True)] returns a complete index set for an array of given dimensions {i1,i2,...}. The option Heads->True will consider Heads as parts of the array (and includes their indexes). Related: FullArrayLeavesIndexSet, CompleteIndexSet. Example: FullArrayIndexSet[{2,3}]"; Options[FullArrayIndexSet]={Heads->True}; FullArrayIndexSet[dimensions_List]:= FullArrayIndexSet[dimensions,Heads->True]; FullArrayIndexSet[dimensions_List,Heads->True]:=(Flatten[#,1]&)@ Table[FullArrayLeavesIndexSet[Take[dimensions,i],Heads->True],{i, Length@dimensions}]; FullArrayIndexSet[dimensions_List, Heads->False]:=(DeleteCases[#,{___,0,__},{1}]&)@ FullArrayIndexSet[dimensions,Heads->True]; (*a snippet of one version of FullArrayLeavesIndexSet. Included here because it is used by the above version of FullArrayIndexSet*) FullArrayLeavesIndexSet[dimensions_List, Heads->True]:=(Flatten[#,Length@dimensions-1]&)@ Array[List,dimensions+1,0]; (*alternative definition using ExpressionGenerator. ExpressionGenerator was named TreeGenerator in my previous messages....*) Options[FullArrayIndexSet2]={Heads->True}; FullArrayIndexSet2[indexes_List]:=FullArrayIndexSet2[indexes,Heads->True]; FullArrayIndexSet2[indexes_List,Heads->predicate_]:= Sort@Position[ExpressionGenerator[indexes,Heads->predicate],_,{1,-1}];

Patreon me $5. Ask me question on patreon