Mma World Programming Competitions
- To: mathgroup at yoda.physics.unc.edu
- Subject: Mma World Programming Competitions
- From: adams at maths.mu.oz.au (Tim Adam)
- Date: Mon, 30 May 1994 20:26:50 +1000
_Mathematica World_ is an electronic magazine aimed at helping people
use Mathematica effectively, and to this end we run two programming
competitions.
The winning solutions of the latest Friendly and International
competitions follow. Please see a previous article for the current
competition problems.
Tim Adam
Executive Editor,
Mathematica World
****************************************
Mathematica World Friendly Programming Competition: March
The Problem
Write a function QMMatchQ, similar to StringMatchQ, which checks
whether a string matches a pattern in which a question mark ? stands
for any one character. For example:
In[12] := QMMatchQ["ABC123", "A?C??3"]
Out[12] = True
The Winner - Todd Gayley
My initial thought was the following (what could be simpler?):
QMMatchQ[s_String, p_String] := MatchQ[Characters[s],
Characters[p] /. "?" -> _ ]
Unfortunately, it's not really correct since it doesn't allow the use of \
to mean a literal "?" character. This can be handled with:
QMMatchQ2[s_String, p_String] :=
MatchQ[Characters[s],
Characters[p] //.
{a___, "\\", "?", b___} -> {a, "QM", b}
/. "?" -> _
/. "QM" -> "?"
]
You could even write a nearly complete replacement for StringMatchQ in
this way. It doesn't handle the SpellingCorrection and IgnoreCase
options, and it doesn't properly handle multiple \'s, as in \\* which
should mean a literal backslash followed by the * metacharacter (but
then, StringMatchQ has this bug as well!)
QMMatchQ3[s_String, p_String] :=
MatchQ[Characters[s],
Characters[p] //.
{a___, "\\", x:("?" | "*" | "@"), b___} :>
{a, StringJoin["\\", x], b}
/.
{"?" -> _,"*" -> ___,
"@" -> _?(LowerCaseQ[#] || !LetterQ[#]&)}
/.
{"\\?" -> "?", "\\*" -> "*", "\\@" -> "@"}
]
****************************************
Mathematica World International Programming Competition
Results for First Quarter 1994
Congratulations to the three winners, who each receive a prize of $100
and commemerative plaque. Yvonne Lai is in 9th grade at high school,
and we were pleased to see her participating. Justin Gallivan is a
senior in Chemistry, and his winning solution improved on a previous
joint entry with his roommate. The Open problem was naturally more
difficult, and I was particularly impressed by Al Kaufman's thorough
solution.
High School
The Problem
For students at school up to the high school level, who are not
enrolled at a university.
(R.W. Hamming)
Find the ordered list of positive numbers up to and including a given
number which have no prime factors greater than 5.
For n = 20 the list is:
{1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15, 16, 18, 20}
Winning Solution by Yvonne Lai
The following Mathematica program finds the ordered list of positive
numbers up to and including a given number which have no prime
factors greater than 5.
GetList[GivenNumber_ /; GivenNumber > 0] := (
list := Table[ array[index], {index,0,GivenNumber} ];
Do[ array[index] = 0, {index,0,GivenNumber} ];
Do[ ( number = (2^i) (3^j) (5^k);
index = If[ number <= GivenNumber, number, 0];
array[index] = index; ),
{ i, 0, Floor[ N[ Log[2, GivenNumber] ] ] },
{ j, 0, Floor[ N[ Log[3, GivenNumber] ] ] },
{ k, 0, Floor[ N[ Log[5, GivenNumber] ] ] }
];
Print[ Select[list, # > 0 &] ];
)
Undergraduate
The Problem
For current students who have not completed a university degree.
(also includes High School students)
(T.D. Robb)
For any list find the list of objects which occur more than once in the
given list.
For example an input of {1, 2, 3, 1, 2, 4, 1, 7, 8, 9, 6, 6, 6, 6, 8}
should return {1, 2, 6, 8} as those elements appear twice or more.
If possible, the solution should be efficient for both short and very
long lists, and both sparse and densely packed duplicates.
Here are two simple inputs to work with:
SeedRandom[314159];
input1 = Table[Random[Integer, {0, 10^1}], {10^3}]; (* dense *)
input2 = Table[Random[Integer, {0, 10^3}], {10^3}]; (* sparse*)
Winning Solution by Justin Gallivan
I have made one assumption in the code and that is that the list
consists of positive integers. I will explain the necessity in a
moment, but first here is the solution:
duplicates[x_List]:=If[OddQ[Length[x]],
Intersection[Sequence @@ Transpose[Partition[Sort[Join[x,{-1}]],2]]],
Intersection[Sequence @@ Transpose[Partition[Sort[x],2]]]]
Basically, the idea is to sort the list and take it in ordered pairs
{i,j}. If the list is sorted, any number that appears more than once
must appear at least once as an i and as a j. Then, take all of the
i's and j's (Transpose) and find out which numbers are in both lists
(Intersection). To be Mathematically correct, the number of elements
in the original list must be even (so you don't get an extra i at the
assuming that negative numbers are not allowed. If this isn't the
case, a Null could be joined, or another symbol, but for the sake of
brevity, I used a -1. This assures an even list and that Transpose is
allowed.
duplicates[{1,2,3,1,2,4,1,7,8,9,6,6,6,6,8}]
Open
The Problem
Open to everyone.
Find the area of the region which is the intersection of a list of
two-dimensional convex polygons given in Mathematica Polygon form.
eg. Polygon[{x1, y1}, {x2, y2}, {x3, y3}, {x4, y4}] is a quadrilateral
with vertices in the given order.
The more adventurous may want to allow concave or even
self-intersecting polygons, however this will not be taken into
account for judging purposes, except to the extent that inherent
generality in a solution is a virtue.
Winning Solution by Al Kaufman
------- start of package -------
Off[General::spell,General::spell1];
(* Points === Ordered pairs *)
PairQ[p_,q__] := PairQ[p]&&PairQ[q];
PairQ[{x_,y_}] := True;
PairQ[_] := False;
Rot90[{x_,y_}] := {-y,x};
(* Area rules *)
Area[{p__Polygon?ConvexQ}] := Area[SetMeet[p]];
Area[p:Polygon[{_,_,__}]] :=Plus@@Map[(Rot90[#[[1]]].#[[2]])&,(Transpose[{#,RotateLeft[#]}]&@PolygonPoints[p])]/2;
Area[Polygon[___]] := 0;
(* Needed polygon properties *)
(* Convex polygon definitions *)
ConvexQ[p_Polygon,q__Polygon] := ConvexQ[p]&&ConvexQ[q];
ConvexQ[p:Polygon[{a_,b_,c_}]] := Area[p]>0;
ConvexQ[p:Polygon[{a_,b_,c_,d__}]] :=
(Area[Polygon[{a,b,c}]]>0)&&ConvexQ[Polygon[{a,c,d}]];
ConvexQ[_] := False;
InsideQ[y_Polygon,p_?PairQ] := And@@Map[InLeftSetQ[#,p]&,ToSegments[y]];
PolygonPoints[p_Polygon] := p[[1]];
(* Line segments *)
ToSegments[p_Polygon] :=
Map[Apply[Segment,#]&,((Transpose[{#,RotateLeft[#]}])&@PolygonPoints[p])];
(* Left set membership predicate:
Point, pt, is in left set of line Segment[a,b] if it
is in left half plane of directed line passing through the segment a ->
b *)
InLeftSetQ[Segment[a_,b_],pt_?PairQ] := ((pt-a).Rot90[b-a])>=0;
(* SetMeet === Set Intersection *)
SetAttributes[SetMeet,OneIdentity];
(* Set meets for line segments gives a point: {a,b} or {} if no intersection *)
SetMeet[s_Segment,t_Segment] :=
Module[{a=s[[1]],b=s[[2]],c=t[[1]],d=t[[2]],
rba,ba,rdc,dc,p,q,rdcba,rdabc,ca,da,pc,pd},
ba = b-a;
dc = d-c;
rba = Rot90[ba];
rdc = Rot90[dc];
rdcba = rdc.ba;
rbadc = rba.dc;
If[rdcba == 0 || rbadc ==0,
(* Parallel case *)
Return[{}],
(* Non parallel case *)
(
p = -rdc.(s[[1]]-t[[1]])/(rdcba);
q = rba.(s[[1]]-t[[1]])/(rbadc);
Return[
If[(0<=p<=1)&&(0<=q<=1),
s[[1]]+ba*p,
{}]
])]
];
SetMeet[p_Polygon,Polygon[]] := Polygon[];
SetMeet[p_Polygon?ConvexQ,q_Polygon?ConvexQ] :=
Block[{pp=ToSegments[p],qq=ToSegments[q],
s,t},
TheMeet= {};
(* Check for p in q and accumulate vertices belong to the meet *)
pinq = True;
Scan[
(inmeet = InsideQ[q,#];
pinq = pinq&&inmeet;
If[inmeet,AppendTo[TheMeet,#]])&,
PolygonPoints[p]];
If[pinq,Return[Polygon[TheMeet]]];
(* Check for q in p and accumulate vertices belong to the meet *)
qinp = True;
Scan[
(inmeet = InsideQ[p,#];
qinp = qinp&&inmeet;
If[inmeet,AppendTo[TheMeet,#]])&,
PolygonPoints[q]];
If[qinp,Return[Polygon[TheMeet]]];
(* Accumulate edge intersections for the meet *)
Scan[
(s=#;
Scan[
(t=#;
pt = SetMeet[s,t];
If[pt=!={},AppendTo[TheMeet,pt]])&,
qq])&,
pp];
(* Rearrange the meet to form a convex polygon *)
Return[MakeConvexHull[TheMeet]]
];
SetMeet[p_Polygon?ConvexQ,q__Polygon] := SetMeet[p,SetMeet[q]];
Clear[MakeConvexHull];
(* Form the convex hull which encloses an arbitrary set of points. *)
MakeConvexHull[m:{p_?PairQ,q_?PairQ,r__?PairQ}] :=
Block[{n,i,j},
(* Generate any boundary segment. *)
n = Length[m];
TheBoundary =
Catch[
For[i=1,i<= n,i++,
For[j=1,j<=n,j++,
If[i!=j,
If[
And@@Map[InLeftSetQ[Segment[m[[i]],m[[j]]],#]&,m],
Throw[{m[[i]],m[[j]]}]]
]]
]];
(* Form the pool from remaining possible boundary points. *)
ThePool = Union[Delete[m,{{i},{j}}]];
Finished = False;
(* Add boundary points to TheBoundary *)
(* ThePool may not be depleted by this processes. *)
While[!Finished,
(OldPool = ThePool;
CycleComplete = (OldPool==={});
PointFound = False;
While[!CycleComplete&&!PointFound,
PointFound = (ThePoint = First[ThePool];
And@@(Map[(InLeftSetQ[Segment[Last[TheBoundary],ThePoint],#])&,m]));
If[!PointFound,ThePool=RotateLeft[ThePool]];
CycleComplete = (ThePool === OldPool)];
If[PointFound,
(AppendTo[TheBoundary,ThePoint];
ThePool = Drop[ThePool,1])];
Finished = CycleComplete&&!PointFound)];
Return[Polygon[TheBoundary]]
];
MakeConvexHull[m:{p__?PairQ}] := Polygon[m];
MakeConvexHull[m:{}] := Polygon[{}]
------- end of package -------
Here's a short function to test the method:
TestPolygonIntersection[n1_Integer/;n1>=3,n2_Integer/;n2>=3] :=
(ptset = Table[{Random[],Random[]},{n1}];
poly1 = MakeConvexHull[ptset];
Print["Polygon1 vertices: ",Length[PolygonPoints[poly1]]];
Print["Polygon1 area: ",Area[poly1]];
ptset = Table[{Random[],Random[]},{n2}];
poly2 = MakeConvexHull[ptset];
Print["Polygon2 vertices: ",Length[PolygonPoints[poly2]]];
Print["Polygon2 area: ",Area[poly2]];
meet = SetMeet[poly1,poly2];
Print["Intersection vertices: ",Length[PolygonPoints[meet]]];
Print["Intersection area: ",Area[meet]];
plotobj1 = Graphics[{{Hue[0.2],poly1},{Hue[0.5],poly2}}];
plotobj2 = If[meet=!={},Graphics[{{Hue[0.3],meet}}],Graphics[]];
Show[{plotobj1,plotobj2},Axes->Automatic,PlotRange->{{0,1},{0,1}}]
);
TestPolygonIntersection[6, 7]