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]