Group Abstract Group Abstract

Message Boards Message Boards

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

Comparing two lists and use of resolve

POSTED BY: Jesse Stern
10 Replies
Sort By:

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

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
Updating Name
Updating Name
Posted 4 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
Updating Name
Updating Name
Posted 4 years ago

Excellent answers! Thank you to both of you for the original idea and the refinement. Working smoothly now =)
POSTED BY: Updating Name
Updating Name
Updating Name
Posted 4 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

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

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

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
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard