Art of problem solving with WL

Presenter: Shenghui Yang, Wolfram Alpha

Abstract

Materials from last year

Inversion geometry

Combinatorics

Graph in number theory visualization (Weissman, An Illustrated Theory of Numbers) and  (AIME/CRUX)

Asymptotics (Bataille, CRUX V47 No. 5 ) and bonus

Inversion geometry

Introduce the  function in WFR

Explore basic concepts and basic examples in the function

A beautiful conclusion from inversion w.r.t. incenter of triangle:

Demo

The inversion of the circumcircle about the incenter is same as the nine point circle of the contact triangle.

Manipulate[
in=TriangleConstruct[{a,b,c},"Incircle"];
cir=TriangleConstruct[{a,b,c},"Circumcircle"];
Graphics[{
{EdgeForm[Thick],Gray,Triangle[{a,b,c}]},
{White,ContactTriangle[a,b,c]},
{Yellow,in},{Blue,Thick,cir},
{Blue,Thick,[in,cir]}},
PlotRange->{{-.5,2.5},{-.8,2}}],{{c,{1.5,1.7}},Locator},
SaveDefinitions->True,Initialization:>({a,b}={{0,0},{2,0}})]

{a,b,c}={{0,0},{2,0},{1.5,1.7}};

in=TriangleConstruct[{a,b,c},"Incircle"]

cir=TriangleConstruct[{a,b,c},"Circumcircle"]

Directly check the inversion of circumcircle

[in,cir]

Define contract triangle from the foot of incenter triangle:

ContactTriangle[a_,b_,c_]:=With[{inc=TriangleCenter[{a,b,c},"Incenter"]},
Triangle[TriangleConstruct[#,{"Foot",inc}][[1]]&/@{{inc,b,c},{inc,c,a},{inc,a,b}}]
]

It is the same as the result above

TriangleConstruct[ContactTriangle[a,b,c],"NinePointCircle"]

Combinatorics

C1: CRUX MA 122

Four people Mr Baker, Ms Carpenter, Mr Driver, and Ms Plumber
are employed for four jobs as a baker, carpenter, driver, and plumber. None of
them has a name identifying their occupation. They make four statements:
1. Mr Baker says he is the plumber.
2. Mr Driver says he is the baker.
3. Ms Carpenter says she is not the plumber.
4. Ms Plumber says she is not the carpenter.
Exactly  of the four statements are true. 
Who is the driver? (One of the editors apologizes for spilling coffee on the page, but we are sure the question used to have a unique answer!)

Generate derangement (SE) from the problem

Derangement[s_List]:=Pick[#,Inner[SameQ,#,s,Nor]]&[Permutations@s]

Assign names to variable

names={"Baker","Carpenter","Driver","Plumber"};

Possible Candidates

occupationPermutations=Derangement@{"baker","carpenter","driver","plumber"}

Compare with the derangement formula

Round[4!/E]

Check valid permutations and count the number of solutions

status=AssociationThread[names->occupationPermutations[[1]]]

Module[{status=AssociationThread[names->#]},{Count[{status["Baker"]==="plumber",status["Driver"]==="baker",status["Carpenter"]=!="plumber",status["Plumber"]=!="carpenter"},True],PositionIndex[status]["driver"][[1]]}]&/@occupationPermutations

Pick up the right combination with unique solution

GroupBy[%,First]

C2: Bonus POSET related problem

CRUX V47 N6: 
A  rectangular array is made up of the positive integers  arranged in such a way that each row and each column is monotonically decreasing. In particular,  must appear in the upper left corner and 1 in the lower right corner. 

An operation of the array is as follows. The number in the lower right corner is circled. Once any number is circled, the smaller of two of its neighbours, one immediately to the left in the same row and the other immediately above in the same column, is also circled. If there is only one such number, it is circled. 

In this way, a track of  circled numbers from the lower right to the upper left is obtained. Now the number in the lower right is transferred to the upper left position and the rest of the circled numbers are displaced one position along the track. The un-circled numbers are not moved. The same operation is then repeated, with the understanding that, once any number k is transferred from the lower right position to the upper left position, it is treated as though its magnitude were .

Function Definition:

Rotate array:

CWRotateArray[arr_]:=Transpose@(Reverse/@arr)

Generate array satisfying decreasing row and column-wise order:

Clear[RandomDecreasingArray]

RandomDecreasingArray::ndiv="`1` is not divisable by `2`"

RandomDecreasingArray[n_Integer,rows_Integer]/;If[TrueQ[Divisible[n,rows]],True,Message[RandomDecreasingArray::ndiv,n,rows]]:=With[{arr=BlockMap[Sort,RandomSample[Range[n],n],n/rows]},Nest[CWRotateArray,Transpose[Sort/@Transpose[arr]],2]]

Compare the value of neighboring item to determine the location of the next frame:

chooseNeighbor[arr_?MatrixQ,{i_Integer,j_Integer}]:=Which[
i==1&&j==1,
{1,1},
i==1&&j!=1,{1,j-1},
i!=1&&j==1,{i-1,1},
i!=1&&j!=1,
If[arr[[i-1,j]]<arr[[i,j-1]],{i-1,j},{i,j-1}],
True,Abort[]
]

FramedChain[arr_?MatrixQ]:=With[{dim=Dimensions[arr]},NestList[chooseNeighbor[arr,#]&,dim,Total[dim]-2]]

MarkedGrid[arr_?MatrixQ]:=Module[{markedGrid=arr,chain=Transpose@FramedChain[arr],chainValue},
chainValue=MapThread[arr[[#1,#2]]&,chain];MapThread[(markedGrid[[#1,#2]]=Framed[#3])&,chain~Join~{chainValue}];
markedGrid
]

NewGrid[arr_?MatrixQ]:=Module[{chain=Transpose@FramedChain[arr],newChainValue,newGrid},
newChainValue=RotateLeft[MapThread[arr[[#1,#2]]&,chain]];
newGrid=arr;
MapThread[(newGrid[[#1,#2]]=#3)&,chain~Join~{newChainValue}];
newGrid
]

Sample:

mn=12;m=3;

l=6;

arr=RandomDecreasingArray[mn,m]

res=NestList[NewGrid,arr,3*mn];

Rasterize[LongRightArrow@@(MatrixForm@*MarkedGrid/@(res[[;;l]]))]

indices=Flatten[FirstPosition[res,#]&/@res];
formattedGrid=MatrixForm@*MarkedGrid/@res;
labels=Flatten[{#->Placed[formattedGrid[[#]],Tooltip]}&/@indices];
links=Flatten[BlockMap[Rule@@#&,indices,2,1]];

g=Graph[links,VertexLabels->"Name",GraphLayout->"TutteEmbedding"]

g=TransitiveReductionGraph[links,VertexLabels->"Name",GraphLayout->"TutteEmbedding"];
loop=FindCycle[g];
HighlightGraph[g,loop]

Max[Length/@loop]

Visualize number theory and graph

N1: Hasse diagram

Introduce ({{"[◼]", "DivisorHasseDiagram" }})

[720,PlotTheme->"LargeNetworkDefault",VertexLabels->"Name"]

N2: Modular dynamics + Graph

AIME 1988: Find the smallest positive integer whose cube ends in 888.

Let’s explore the problem more than the question itself.

Possible endings

Length[Mod[Range[999]^3,1000]//Union]

Modular Dynamics explanation

n=Range[999];
(*labels=(#->Placed[Style[#,9],Center])&/@n;*)
edges=Thread[n\[DirectedEdge]Mod[n^3,1000]];

g=Graph[edges]

To separate graphs into disjoint components

comm=FindGraphCommunities[g];

v=RandomChoice[comm]

wcgc=WeaklyConnectedGraphComponents[edges,v];

(* v={21,261,61,981,141,221,181,741,861,581,341,821,381,421,461,541,941,621,661,781};
WeaklyConnectedGraphComponents[edges,v]*)GraphPlot[#,VertexShape->Inherited]&/@wcgc

Take one quarter of the graph

ImageTake[ImageCrop@GraphPlot[#,VertexLabels->Placed[Automatic,Center],VertexSize->1.2,VertexLabelStyle->Directive[Red,Italic,10],ImageSize->800]&/@Rest[Flatten[WeaklyConnectedGraphComponents[edges,#]&/@MaximalBy[comm,Length,5]]]//RandomChoice,{1,400},{1,400}]//Framed

Find graph by number of vertices, in particular k = 1 is fixed point. Try k = 2,4,7,16.

249^3

Union[Length/@(comm)]

Manipulate[Grid[Partition[WeaklyConnectedGraphComponents[edges,#,VertexLabels->Placed[Automatic,Center],VertexSize->0.7*(Sqrt[scaleFunc[k]/60]),VertexLabelStyle->Directive[Blue,Italic,9],ImageSize->85*(Sqrt[scaleFunc[k]])]&/@Cases[comm,_?(Length[#]==k&)]//Flatten,UpTo@2],Dividers->All],
{k,{1,2,4,8,16,20,25,28,32,36,44,100}},SaveDefinitions->True,Initialization:>(scaleFunc=Interpolation[{{1,0.9},{2,3.5},{16,20},{28,100},{44,100},{100,50}}])]

Asymptotics (Bataille, CRUX V47 No. 5 )

Bataille has a special section on asymptotic expansion to find limit of sophisticated expression, involving infinite sum, rational functions and special functions. I would like to show how to use the WL’s asymptotic function to tackle some of the problems:

Basic Examples:

DiscreteAsymptotic[HarmonicNumber[n],n->∞]

DiscreteAsymptotic[Sum[1/k,{k,1,n}],n->∞]

DiscreteAsymptotic[Sum[HarmonicNumber[k],{k,1,n}],n->∞]

AsymptoticSum[1/(Sqrt[k]),{k,1,n},n-> Infinity]

AsymptoticSum[(Sqrt[k]),{k,1,n},n-> Infinity]

DiscreteAsymptotic[(((n!)^(1/n))/n),{n,Infinity,3}]

Limit[(((n!)^(1/n))/n),n->∞]

Examples

u[n_]:=(n+1)^(n+1)-n^n

expr1=DiscreteAsymptotic[(u[n+2]*u[n]-u[n+1]^2)/(u[n+1]*u[n]),n->∞]//Together

Limit[expr1,n->Infinity]

Compare direct computation

Block[{n},Limit[(u[n+2]*u[n]-u[n+1]^2)/(u[n+1]*u[n]),n->∞]]

Pairwise difference is also helpful to find the more refined structure of asymptotic expansion

AsymptoticSum[(((Sqrt[2k])-(Sqrt[2k-1]))/(Sqrt[n])),{k,1,n},{n,Infinity,1}]

For nested sum, I usually find the asymptotic expression for the inner most case. If necessary

AsymptoticSum[(1/(2k-1)),{k,1,n},{n,Infinity,4}]

Limit[1/n*(1+2*(%)/n)^n,n->Infinity]

FullSimplify[%]

Summary

WL has evolved for more than 30 years and curated a large number of efficient algorithm to solve many challenging problems in many fields. This article focuses on the problem solving skills that really benefits our users to grind skill in cases that it show no obvious direct path. But once we understand the problem, WL really helps grabbing the core of the problem and generalize our thought beyond the scope of original problem easily.