Message Boards Message Boards

1
|
4790 Views
|
10 Replies
|
6 Total Likes
View groups...
Share
Share this post:

Comparing two lists and use of resolve

I have few general issues related to a problem I have been working on for some time. The main problem I am trying to solve is, the following:

Given two multisets of equations (represented as lists), call them A an B, and I need to compute if there is some setting of the variables in these equations over the positive integers such that every element of A and B is a positive integer and, for each element x in A, there are at least as many copies of x in B as in A.

As an example, the case of A={a-b,c} B={x,y,z} has many solutions, such as a,c,x=2, b=1, y=1, z=1 which gives us the multisets A={1,2} and B={1,1,2}. On the other hand, A={a-b,b-c} B={a-c,x} has no solution.

Ideally, I'd like to be able to print the True/False answer to this, as well as, if True, print a solution. Unfortunately, I am struggling with even much simpler issues. I originally tried things like the following:

i = 1;
   f[Y_, L_, 1] := (Count[L, First[Sort[L]]] <= Count[Y, First[Sort[L]]]);
   While[i < Length[DeleteDuplicates[L]],
    i++;
    f[Y_, L_, i_] := 
     f[Y, L, i - 1] && f[Y, Drop[Sort[DeleteDuplicates[L]], i - 1]];
    ]; (*Checks validity of solution to L*)

   FindInstance[ f[Y, L, Length[DeleteDuplicates[L]]], Z, PositiveIntegers]

This failed miserably, even with many adjustments, large and small (example: swap FinInstance for Reduce and Resolve, define the function differently, etc). In the end, it turned out even simple things such as the following don't seem to behave as I would expect:

A = {1, 1, 2, 2}
B = {1, 2, 2}
Resolve[ForAll[x, (1 <= Count[A, x]), Count[A, x] <= Count[B, x]], PositivieIntegers]

From my understanding, I'd assume the above would return False. Alas, it returns True despite multiple iterations of trying to get something to do the above comparison properly. At this point, I am certain that I am misunderstanding how some of these automated solving functions such as Resolve and Reduce actually work and interact with variables and would greatly appreciate any explanations as to my misunderstandings anyone could offer and/or suggested readings/videos on the topic (of coarse I have already been trying to solve the issue by reading the documentation, but with little success). Thank you in advance for any help people can provide!

POSTED BY: Jesse Stern
10 Replies

My guess is that Count isn't designed to play nice with Resolve, though I may be mistaken. A strange partial workaround is to 'manually define Count' like so

A={1,1,2,2};B={1,2,2};
coolcount[list_,guy_]:=Sum[Sinc[\[Pi](guy-e)],{e,list}];
Solve[coolcount[A,x]<=coolcount[B,x],x,PositiveIntegers]
(*{{x->1}}*)

Apparently WL is smart enough to solve equations with Sinc, $\frac{\sin x}x$ (defined on $\pi\mathbb Z$ is indicator function for zero). Sadly I can't get WL to do proper logical elimination with Resolve.

That code returns an error, I had a typo that made erroneous results. Strangely, when <= is changed to ==, {{x->397}} is somehow concluded.

POSTED BY: Adam Mendenhall

Ya, as to your crossed out suggestions, I have tried varies workarounds using tally, edit distance, and other measures I can use to get the same results, but to no avail. I have been wondering if it is some sort of type issue, but have not been able to decide one way or the other on that mark. Thanks for the effort!

POSTED BY: Jesse Stern

What's wrong with using simple procedural programming for this.

  1. ask if all are positive integers
  2. see if all members of A are in B
  3. check if members of A in B have at least the same count

or am I missing something?

    posInt[list_] := AllTrue[list, IntegerQ[#] && Positive[#] &]

    isSolution[A_, B_] := Block[{uniqueA},
      (*1. check if all members of A and B are positive integers*)
      If[! (posInt[A] && posInt[B]), False,
       (*get unique members of A*)
       uniqueA = DeleteDuplicates[A];
       (*2. if so check if all members of A are also in B*)
       If[! AllTrue[MemberQ[B, #] & /@ uniqueA, # &], False,
        (*3. see if for each unique member in A its count in B is equal or larger*)
        AllTrue[(Count[B, #] >= Count[A, #]) & /@ uniqueA, # &]
        ]]]

    In[277]:= isSolution[{1, 1, 2, 2}, {1, 2, 2}]
    isSolution[{1, 1.1, 2, 2}, {1, 2, 2}]
    isSolution[{1, 1, 2, 2}, {1, 1, 2, 2}]
    isSolution[{1, 1, 2, 2}, {1, 1.1, 2, 2}]
    isSolution[{1, 2, 3}, {1, 1, 2, 2}]

    Out[277]= False

    Out[278]= False

    Out[279]= True

    Out[280]= False

    Out[281]= False

provided a list of solutions you want to check, print, and return the valid solutions.

possibleSolutions = {
   {{1, 1, 2, 2}, {1, 2, 2}},
   {{1, 1.1, 2, 2}, {1, 2, 2}},
   {{1, 1, 2, 2}, {1, 1, 2, 2}},
   {{1, 1, 2, 2}, {1, 1.1, 2, 2}},
   {{1, 2, 3}, {1, 1, 2, 2}}
   };

printIsSolution[A_, B_] := If[isSolution[A, B], Print[{A, B}]; {A, B}, Nothing];

solutions = printIsSolution @@@ possibleSolutions;

{{1,1,2,2},{1,1,2,2}}

Or as a one-line function

isSolutionLine[A_, B_] := With[{uniqueA = DeleteDuplicates[A]},
  posInt[A] && posInt[B] && AllTrue[MemberQ[B, #] & /@ uniqueA, # &] &&
    AllTrue[(Count[B, #] >= Count[A, #]) & /@ uniqueA, # &]
  ]

printIsSolution[A_, B_] := 
  If[isSolutionLine[A, B], Print[{A, B}]; {A, B}, Nothing];

isSolutionLine @@@ possibleSolutions
solutions = printIsSolution @@@ possibleSolutions;
POSTED BY: Martijn Froeling
Posted 3 years ago

Ah, wait now I get it, you don't want to brute force, but find if there is any possible solution to the problem.

Then I would not use things as Count and DeleteDuplicates. Basically you want to check if each element of A is equal to any element of B.

Based on you description of the two cases that should resolve to True and False you also define that each element of B is present in A. else the second case also has a solution.

In[1]:= findSolution[A_, B_, n_ : 1] := 
 Block[{var, func, memberAofB, memberBofA, elem, ex, res, sol},
  (*get unique variables*)
  var = DeleteDuplicates[Flatten[Variables /@ Join[A, B]]];
  (*define functions, each has to be >0*)
  func = And @@ (# > 0 & /@ Join[A, B]);
  (*define that each element of A has to be equal to at least one \
element of B*)
  memberAofB = And @@ ((am = #; Or @@ ((am == #) & /@ B)) & /@ A);
  (*define that each element of B has to be equal to at least one \
element of A*)
  (*was not in the description but seems to be needed for second \
solution to be False*)
  memberBofA = And @@ ((bm = #; Or @@ ((bm == #) & /@ A)) & /@ B);
  (*define that all variables are positive Integers*)
  elem = Element[Alternatives @@ var, PositiveIntegers];
  (*define exist*)
  ex = Exists[#, Element[Alternatives @@ var, PositiveIntegers], 
      func && memberAofB && memberBofA] &[var];
  (*resolve solution*)
  res = Resolve[ex, PositiveIntegers];
  (*if solution exists find solution*)
  sol = If[res,
    sol = 
     FindInstance[func && memberAofB && memberBofA && elem, #, n] &[
      var];
    {Column[Thread[sol -> ({A, B} /. sol)]]},
    None
    ];
  {res, sol}
  ]

In[2]:= findSolution[{a - b, c}, {x, y, z}]
findSolution[{a - b, c}, {x, y, z}, 2]
findSolution[{a - b, c}, {x, y, z}, 10]
findSolution[{a - b, b - c}, {a - c, x}, 1]

Out[2]= {True, { \!\(\*
TagBox[GridBox[{
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "3"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "2"}], ",", 
RowBox[{"x", "->", "2"}], ",", 
RowBox[{"y", "->", "2"}], ",", 
RowBox[{"z", "->", "2"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"2", ",", "2"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"2", ",", "2", ",", "2"}], "}"}]}], "}"}]}]}
},
DefaultBaseStyle->"Column",
GridBoxAlignment->{"Columns" -> {{Left}}},
GridBoxItemSize->{
       "Columns" -> {{Automatic}}, "Rows" -> {{Automatic}}}],
"Column"]\) }}

Out[3]= {True, { \!\(\*
TagBox[GridBox[{
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "180"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "179"}], ",", 
RowBox[{"x", "->", "179"}], ",", 
RowBox[{"y", "->", "179"}], ",", 
RowBox[{"z", "->", "179"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"179", ",", "179"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"179", ",", "179", ",", "179"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "31"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "30"}], ",", 
RowBox[{"x", "->", "30"}], ",", 
RowBox[{"y", "->", "30"}], ",", 
RowBox[{"z", "->", "30"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"30", ",", "30"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"30", ",", "30", ",", "30"}], "}"}]}], "}"}]}]}
},
DefaultBaseStyle->"Column",
GridBoxAlignment->{"Columns" -> {{Left}}},
GridBoxItemSize->{
       "Columns" -> {{Automatic}}, "Rows" -> {{Automatic}}}],
"Column"]\) }}

Out[4]= {True, { \!\(\*
TagBox[GridBox[{
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "251"}], ",", 
RowBox[{"b", "->", "40"}], ",", 
RowBox[{"c", "->", "211"}], ",", 
RowBox[{"x", "->", "211"}], ",", 
RowBox[{"y", "->", "211"}], ",", 
RowBox[{"z", "->", "211"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"211", ",", "211"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"211", ",", "211", ",", "211"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "94"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "93"}], ",", 
RowBox[{"x", "->", "93"}], ",", 
RowBox[{"y", "->", "93"}], ",", 
RowBox[{"z", "->", "93"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"93", ",", "93"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"93", ",", "93", ",", "93"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "464"}], ",", 
RowBox[{"b", "->", "41"}], ",", 
RowBox[{"c", "->", "423"}], ",", 
RowBox[{"x", "->", "423"}], ",", 
RowBox[{"y", "->", "423"}], ",", 
RowBox[{"z", "->", "423"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"423", ",", "423"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"423", ",", "423", ",", "423"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "452"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "451"}], ",", 
RowBox[{"x", "->", "451"}], ",", 
RowBox[{"y", "->", "451"}], ",", 
RowBox[{"z", "->", "451"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"451", ",", "451"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"451", ",", "451", ",", "451"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "90"}], ",", 
RowBox[{"b", "->", "89"}], ",", 
RowBox[{"c", "->", "1"}], ",", 
RowBox[{"x", "->", "1"}], ",", 
RowBox[{"y", "->", "1"}], ",", 
RowBox[{"z", "->", "1"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"1", ",", "1"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"1", ",", "1", ",", "1"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "112"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "1"}], ",", 
RowBox[{"x", "->", "111"}], ",", 
RowBox[{"y", "->", "1"}], ",", 
RowBox[{"z", "->", "1"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"111", ",", "1"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"111", ",", "1", ",", "1"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "859"}], ",", 
RowBox[{"b", "->", "97"}], ",", 
RowBox[{"c", "->", "762"}], ",", 
RowBox[{"x", "->", "762"}], ",", 
RowBox[{"y", "->", "762"}], ",", 
RowBox[{"z", "->", "762"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"762", ",", "762"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"762", ",", "762", ",", "762"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "636"}], ",", 
RowBox[{"b", "->", "1"}], ",", 
RowBox[{"c", "->", "635"}], ",", 
RowBox[{"x", "->", "635"}], ",", 
RowBox[{"y", "->", "635"}], ",", 
RowBox[{"z", "->", "635"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"635", ",", "635"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"635", ",", "635", ",", "635"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "936"}], ",", 
RowBox[{"b", "->", "9"}], ",", 
RowBox[{"c", "->", "37"}], ",", 
RowBox[{"x", "->", "37"}], ",", 
RowBox[{"y", "->", "927"}], ",", 
RowBox[{"z", "->", "927"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"927", ",", "37"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"37", ",", "927", ",", "927"}], "}"}]}], "}"}]}]},
{
RowBox[{
RowBox[{"{", 
RowBox[{
RowBox[{"a", "->", "44"}], ",", 
RowBox[{"b", "->", "43"}], ",", 
RowBox[{"c", "->", "1"}], ",", 
RowBox[{"x", "->", "1"}], ",", 
RowBox[{"y", "->", "1"}], ",", 
RowBox[{"z", "->", "1"}]}], "}"}], "->", 
RowBox[{"{", 
RowBox[{
RowBox[{"{", 
RowBox[{"1", ",", "1"}], "}"}], ",", 
RowBox[{"{", 
RowBox[{"1", ",", "1", ",", "1"}], "}"}]}], "}"}]}]}
},
DefaultBaseStyle->"Column",
GridBoxAlignment->{"Columns" -> {{Left}}},
GridBoxItemSize->{
       "Columns" -> {{Automatic}}, "Rows" -> {{Automatic}}}],
"Column"]\) }}

Out[5]= {False, None}
POSTED BY: Updating Name

A={a-b,b-c} B={a-c,x} has no solution because it cannot be the case that a-c=a-b, nor can it be the case that a-c=b-c, so while x can equal either element of A, not every element of A has more copies of itself in B. That aside, this is definitely a very meaningful departure from the ways I tried to handle this and I think it should work with some adjustment! Still not totally sure what went wrong when using Count, but clearly it wasn't playing nice, so I'll give this way a shot. Thanks for the ideas!

POSTED BY: Jesse Stern

You can recast it as an algebraic problem by adding a new variable to make the vectors have the same length, a new set of variables to construct a permutation matrix, and equations that set the augmented first vector equal to the permuted second vector.

This will set up the desired equations.

pmat = Array[p, {3, 3}];
c1 = Thread[Total[pmat] - 1 == 0];
c2 = Thread[Total[Transpose@pmat] - 1 == 0];
c3 = Map[0<=#<=1 &, Flatten[pmat]];
c4 = Thread[{a - b, c, d} == pmat . {x, y, z}];
c5 = Thread[{a, b, c, d, x, y, z} >= 1];

Now see if we can find a solution:

result = FindInstance[Flatten[{c1, c2, c3, c4, c5}], 
   Join[Flatten[pmat], {a, b, c, d, x, y, z}], Integers];
{{a - b, c}, pmat . {x, y, z}} /. result

(* Out[139]= {{{2, 1}, {2, 1, 1}}} *)

Here is the example with no solution.

pmat = Array[p, {2, 2}];
c1 = Thread[Total[pmat] - 1 == 0];
c2 = Thread[Total[Transpose@pmat] - 1 == 0];
c3 = Map[#^2 == # &, Flatten[pmat]];
c4 = Thread[{a - b, b - c} == pmat . {a - c, x}];
c5 = Thread[{a, b, c, x} >= 1];

result = 
 FindInstance[Flatten[{c1, c2, c3, c4, c5}], 
  Join[Flatten[pmat], {a, b, c, d, x, y, z}], Integers]

(* Out[146]= {} *)
POSTED BY: Daniel Lichtblau

Ah i missed a key part of the last condition. "there are at least as many copies of x in B as in A.".

So my solution would not work since it looks for at least one copy and not as many.

POSTED BY: Martijn Froeling
Posted 3 years ago

A very interesting approach, I don't think you have to actually make an extra variable if you would define the constrains on the projection matrix differently.

In[1]:= findSolution[A_, B_, n_ : 1] := 
 Block[{vari, pmat, p, pmatDef, pmatCon, varCon, fun, var, res, sol},
  (*find input variables*)
  vari = DeleteDuplicates[Flatten[Variables /@ Join[A, B]]];

  (*make projection matrix*)
  pmat = Array[p, {Length[A], Length[B]}];

  (*define form of projection matrix*)
  pmatDef = Flatten[{
     Thread[0 <= Total[pmat] <= 1],
     Thread[Total[Transpose@pmat] == 1],
     Thread[A == pmat . B]}];

  (*constrain variables*)
  pmatCon = Map[0 <= # <= 1 &, Flatten[pmat]];
  varCon = Thread[vari >= 1];

  (*functions and variables*)
  fun = Flatten[{pmatDef, pmatCon, varCon}];
  var = Join[Flatten[pmat], vari];

  (*can it be resolved*)
  res = Resolve[Exists[#, fun] &[var], Integers];

  (*if solution exists find n solutions*)
  sol = If[res,
    sol = FindInstance[fun, Join[var], Integers, n];
    sol = Drop[#, Length[Flatten[pmat]]] & /@ sol;
    {Thread[sol -> ({A, B} /. sol)]},
    None
    ];

  (*output found solutions*)
  {res, sol}
  ]

In[4]:= findSolution[{a - b, c}, {x, y, z}, 1]
findSolution[{a - b, c}, {x, y, z}, 2]
findSolution[{a - b, b - c}, {a - c, x}]

Out[4]= {True, {{{a -> 3, b -> 1, c -> 1, x -> 1, y -> 1, 
     z -> 2} -> {{2, 1}, {1, 1, 2}}}}}

Out[5]= {True, {{{a -> 76, b -> 75, c -> 1, x -> 1, y -> 54, 
     z -> 1} -> {{1, 1}, {1, 54, 1}}, {a -> 67, b -> 1, c -> 107, 
     x -> 1, y -> 107, z -> 66} -> {{66, 107}, {1, 107, 66}}}}}

Out[6]= {False, None}
POSTED BY: Updating Name
Posted 3 years ago

Excellent answers! Thank you to both of you for the original idea and the refinement. Working smoothly now =)

POSTED BY: Updating Name

Hmm only downside is it seems to perform very poorly even on inputs of limited size. The following didn't terminate even after 15 minutes:

A={Subscript[x, 1],Subscript[x, 2],Subscript[x, 3],Subscript[x, 1]-Subscript[x, 3],Subscript[x, 2]-Subscript[x, 3],Subscript[x, 1]-Subscript[x, 2],-Subscript[x, 1]+Subscript[x, 2]+Subscript[x, 3]}

B={Subscript[y, 1],Subscript[y, 2],Subscript[y, 3],Subscript[y, 4],Subscript[y, 5],Subscript[y, 6],Subscript[y, 7],Subscript[y, 8],Subscript[y, 9],Subscript[y, 10]}
POSTED BY: Jesse Stern
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract