Re: Need a Faster Solution to Number Theory Problem

• To: mathgroup at smc.vnet.net
• Subject: [mg91402] Re: [mg90990] Need a Faster Solution to Number Theory Problem
• From: Daniel Lichtblau <danl at wolfram.com>
• Date: Wed, 20 Aug 2008 04:04:48 -0400 (EDT)
• References: <200808020726.DAA24898@smc.vnet.net>

```John Snyder wrote:
> I got hooked on the following little number theory problem which appears in
> the August issue of Discovery magazine.  "Susan has more than one dollar in
> change, but she still can't make exact change for a dollar bill. What is the
> maximum amount of money that Susan could have in pennies, nickels, dimes and
> quarters for this to be true?"
>
> I solved the problem using the following Mathematica code:
>
> coins={1,5,10,25};
> dollar=FrobeniusSolve[coins,100];
>
> Catch[Do[t=Times@@Length/@(Cases[dollar,{p_,n_,d_,q_}/; (p<=#1&&n<=#2 &&
> d<=#3 && q<=#4)]&@@@FrobeniusSolve[coins,a]);
> If[t==0,Throw[a]],{a,130,101,-1}]]
>
> Starting with a maximum guess of \$1.30 this gives the correct answer of
> \$1.19 in about 5 seconds.  The problem is that if the problem is made more
> complicated by adding more possible coin denominations (and/or paper
> currency) the execution time become very long indeed.
>
> Is there a way to speed up the solution to this type of problem so that I
> can handle more complicated cases in a reasonable time?
>
> Thanks,
>
> John

Late response, but I didn't get time to look hard at this until now. It
seems to be a difficult problem in terms of complexity, though I'm not
certain I have the best possible approach.

First the uninteresting case: if one denomination does not divide the
avoided amount then the answer is infinity. So we'd want to rule out
that case, and just handle the rest under the assumption that all
denominations divide the value we need to avoid.

Frobenius instance problem carve out a "staircase" in the denominations.
Any set giving a maximum value must always have an element below the
"elbows" of this staircase. In effect this gives a domain quite similar
to the "fundamental domain" of the Frobenius number problem, as
discussed here:

http://www.integers-ejcnt.org/vol7.html
(look for A15: Frobenius Numbers by Lattice Point Enumeration)

or

http://citeseerx.ist.psu.edu/viewdoc/summary;jsessionid=A56BBBFE608FF49E382BE25E84F2EBC3?doi=10.1.1.88.9057

Given the elbows, we need to find a maximal corner, with l_1 norm (that
is, Manhattan distance) weighted by the set of denominations. There are
various ways to do this. I'll give code for one such below (it's adapted
from code related to the paper at the URLs above). Other ways involve
ideas from the theory of monomial ideals; see work by Bjarke Roune for
details on efficient approaches.

Explaining the code below would be an article in itself, so I defer to
the reference. I simply mention that there might be ways to simplify it
because the original was written for a slightly different problem, and I
may have missed modifications that could make it better for the problem
now at hand. Suffice it to say that the slow step is in tracking through
all the corners to find the largest. Possibly there is a smart way to
improve on this.

dominationKernel[X_] :=
Module[{Y = X[[Ordering[Map[Tr, X]]]], Z, i = 2, len = 1, k},
Z = Table[{}, {Length[Y]}];
Z[[1]] = Y[[1]];
While[i <= Length[Y] && Tr[Y[[i]]] == Tr[Y[[1]]], len++;
Z[[len]] = Y[[i]]; i++];
Do[k = 1;
While[k <= len,
If[And @@ Thread[Z[[k]] <= Y[[j]]], k = len + 2; Break[],
k++]];
If[k == len + 1, len++; Z[[len]] = Y[[j]]], {j, len + 1,
Length[Y]}];
Sort[Take[Z, len]]]

ClearNegsAndDeleteZeroVector[vecs_] :=
If[vecs == {}, {},
Union[DeleteCases[vecs /. _?Negative :> 0,
Table[0, {Length[vecs[[1]]]}]]]];

farthest[corns_, A_] :=
Fold[If[#2.A > #1[[2]], {#2, #2.A}, #1] &, {Table[0, {Length[A]}],
0}, corns][[1]]

FarthestCorner[A_, elbows_?MatrixQ] :=
Module[{pts, p1, p2, B, cc, trQ, farvertex, maxes, currfar},
currfar = farthest[elbows, A].A;
pts = Select[elbows, #[[1]] > 0 &];
Scan[({p1, p2} = {First[#], Rest[#]};
B = Rest /@ Select[elbows, #[[1]] < p1 &];
B =
dominationKernel[
ClearNegsAndDeleteZeroVector[# - p2 & /@ B]];
maxes = Prepend[Max /@ Transpose[B], 0];
If[(maxes + #).A > currfar,
cc = FarthestCornerSub[A, B, currfar, #];
farvertex = farthest[Prepend[# + p2, p1] & /@ cc, A];
currfar = Max[currfar, farvertex.A];
]) &, pts];
{currfar - Total[A], farvertex - 1}] /; Length[elbows[[1]]] > 2;

FarthestCorner[A_, elbows_?MatrixQ] :=
farthest[FarthestCornerSub[A, elbows], A].Rest[A] - Total[A] /;
Length[elbows[[1]]] == 2

FarthestCornerSub[A_, elbows_, currfar_, backdata_] :=
Module[{p1, p2, pts, B, maxes},
pts = Select[elbows, First[#] > 0 &];
Flatten[Map[(
{p1, p2} = {#[[1]], Rest[#]};
B = Rest /@ Select[elbows, First[#] < p1 &];
B = dominationKernel[
ClearNegsAndDeleteZeroVector[# - p2 & /@ B]];
If[B == {}, {},
maxes = Prepend[Max /@ Transpose[B], 0];
If[(PadLeft[maxes + #, Length[A]] + backdata).A > currfar,
Prepend[# + p2, p1] & /@
FarthestCornerSub[A, B, currfar,
]) &, pts], 1]] /; Length[elbows[[1]]] > 2;

FarthestCornerSub[_,
elbows_, ___] := (Partition[
Take[Flatten[Reverse /@ Reverse[elbows]], {2, -2}], 2]) /;
Length[elbows[[1]]] == 2;

maxNoChange[coins_List, amount_Integer /; amount >= 1] /;
Not[And @@ Map[IntegerQ, amount/coins]] := Infinity

maxNoChange[coins_List, amount_Integer /; amount >= 1] :=
FarthestCorner[coins, FrobeniusSolve[coins, amount]]

In[230]:= maxNoChange[{1, 5, 10, 25}, 100] // Timing
Out[230]= {0.96806, {119, {4, 0, 4, 3}}}

We'll add one coin and up the amount.

In[231]:= maxNoChange[{1, 5, 10, 25, 50}, 150] // Timing
Out[231]= {13.9929, {169, {4, 0, 4, 1, 2}}}

It gets slow quickly, so to speak.

In[235]:= maxNoChange[{1, 5, 10, 25, 50}, 200] // Timing
Out[235]= {82.3371, {219, {4, 0, 4, 1, 3}}}

Daniel Lichtblau
Wolfram Research

```

• Prev by Date: Re: NDSolve[] with nested If[] and Piecewise[] usage:
• Next by Date: Re: NDSolve
• Previous by thread: Need a Faster Solution to Number Theory Problem
• Next by thread: Re: Re: Need a Faster Solution to Number Theory