Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2010

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Special permutation pattern ascending groups sum of

  • To: mathgroup at smc.vnet.net
  • Subject: [mg113195] Re: Special permutation pattern ascending groups sum of
  • From: Daniel Lichtblau <danl at wolfram.com>
  • Date: Mon, 18 Oct 2010 05:47:13 -0400 (EDT)

----- Original Message -----
> From: "me you" <coconut_dj at yahoo.com>
> To: mathgroup at smc.vnet.net
> Sent: Sunday, October 17, 2010 5:06:25 AM
> Subject: [mg113187] Special permutation pattern ascending groups sum of subset
> hi,
> 
> i'm very new to Mathematica and i would like to ask for some help, i
> need some code which can handle with the following problem
> 
> i have a vector of 9 elements {0, 0, 1, 2, 3, 4, 5, 7, 8}
> i have k = 3, k is the number of subsets
> each subset should contain elements in ascending order
> i need to get all the permutation that fit the following conditions
> a1 <= a2 <= a3
> a2 <= a5 <= a6
> a7 <= a8 <= a9
> a1 <= a4 <= a7
> a1 + a2 + a3 = 10
> a4 + a5 + a6 = 10
> a7 + a8 + a9 = 10
> 
> possible solution would be
> {0, 2, 8, 0, 3, 7, 1, 4, 5}
> and
> {0, 3, 7, 0,2, 8, 1, 4, 5}
> 
> the script should be very dynamic because i would like to use it on a
> largeset of numbers (40)
> somehow before we can check for the sum of elements we need to
> generate just those permutation where elements in subset sare
> ascending order (a1<=a2<=a3) (a4<=a6<=a6) (a7<=a8<=a9)
> 
> Thanks

If I follow correctly, your aj's are meant as for a permutation where set element j goes to aj. If so, I think you want a4 rather than a2 for the middle inequality constraint.

But it can be handled without finding explicit permutations that require ordering constraints. Can instead treat as a 0-1 assignment problem. Set up a 9x3 array of variables, where a[j,k] is one if element j is in subset k. We can then set up various constraints and solve as an integer linear constraint satisfaction problem.

In[174]:= set = {0, 0, 1, 2, 3, 4, 5, 7, 8};
n = Length[set];
k = 3;
ssize = n/3;
target = 10;

In[184]:= vars = Array[a, {k, n}];
fvars = Flatten[vars];

Now we require that each variable be 0 or 1 (using inequalities and a domain restriction later). Also need rows to sum to the number of items in each subset (3, in this example). And we need that certain linear equalities be met (subsets sum to 10).

Finally, in order to cut down on essentially equivalent solutions, we force the last element into the first subset, and also decree that the second subset receive either the next to last or third to last unless the last subset receives neither. This tends to work for the example in question (we get a unique solution). Maybe there is a better way of forcing solutions to be essentially unique, I'm not sure. (By essentially unique, I mean we do not get solutions that are simply subset reorderings of one another. If the meaning of this is not clear, try the setup but without c5 below.)

In[201]:= c1 = Map[0 <= # <= 1 &, fvars];
c2 = Map[Total[#] == ssize &, vars];
c3 = Map[Total[#] == 1 &, Transpose[vars]];
c4 = Map[set.# == target &, vars];
c5 = {vars[[1, -1]] == 1, vars[[2, -2]] >= vars[[3, -2]], 
   Total[vars[[2, -3 ;; -2]]] >= Total[vars[[3, -3 ;; -2]]]};
constraints = Flatten[Join[c1, c2, c3, c4, c5]];

In[207]:= Timing[
 solns = Map[Pick[set, #, 1] &, 
   vars /. {ToRules[Reduce[constraints, fvars, Integers]]}, {2}]]

Out[207]= {0.016, {{{0, 2, 8}, {0, 3, 7}, {1, 4, 5}}, {{0, 2, 8}, {0, 
    3, 7}, {1, 4, 5}}}}

Daniel Lichtblau
Wolfram Research


  • Prev by Date: Re: Mathematica and infinite series
  • Next by Date: Correct answer for all n
  • Previous by thread: simplifying an expression using non-commutative algebra
  • Next by thread: Correct answer for all n