prograMing: trees and indexes, 3
- To: mathgroup@smc.vnet.net
- Subject: [mg11003] prograMing: trees and indexes, 3
- From: "Xah" <xah@best.com>
- Date: Mon, 16 Feb 1998 03:40:07 -0500
- Organization: Venus & Xah Love Factory
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
existance 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,
e.g. 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}];
Xah, xah@best.com
http://www.best.com/~xah/PageTwo_dir/more.html
"Morality abets evil"