Re: Re: Numbers problem
- To: mathgroup at smc.vnet.net
- Subject: [mg19536] Re: [mg19524] Re: [mg19520] Numbers problem
- From: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
- Date: Tue, 31 Aug 1999 00:52:25 -0400
- Sender: owner-wri-mathgroup at wolfram.com
Just after I sent my previous message I realized that there is an well known
algorithm which is at least superior to the stupid one I used below. It is
known as backtracking and a function which does the main job for you is
included in the DiscreteMath`Combinatorica` package.
First we load the package.
<< DiscreteMath`Combinatorica`
In[1]:=
?Backtrack
"Backtrack[s, partialQ, solutionQ] performs a backtrack search of the state
space s, expanding a partial solution so long as partialQ is True and
returning the first complete solution, as identified by solutionQ."
What Backtrack does is basically constructs partial solutions and then tests
them. If they are O.K. it extends them, if not it goes back and tries
another.
Our solution space will be
In[2]:=
space[n_] := Table[Range[n], {2n}]
Just as before we define the function test:
In[3]:=
test[l_List, i_] := (Last[#] - First[#]) &@Flatten[Position[l, i]] - 1 == i
A list will be a partial solution if its last element appears in in less
then 2 times, and it either satisifes the condition given in test or it only
occurs once:
In[4]:=
partialQ[l_] := (Count[l, Last[l]] <=
2 && (test[l, Last[l]] || Count[l, Last[l]] == 1))
Thus
In[5]:=
partialQ[{2, 3, 1, 2}]
Out[5]=
True
but
In[6]:=
partialQ[{2, 3, 1, 3}]
Out[6]=
False
The test for a final solution is as before:
In[7]:=
finalQ[l_] := Apply[And, Map[test[l, #] &, Union[l]]]
Now we can look for our solutions:
In[8]:=
problem[n_] := Backtrack[space[n], partialQ, finalQ, All]
In[9]:=
problem[3]
Out[9]=
{{2, 3, 1, 2, 1, 3}, {3, 1, 2, 1, 3, 2}}
In[10]:=
problem[4]
Out[10]=
{{2, 3, 4, 2, 1, 3, 1, 4}, {4, 1, 3, 1, 2, 4, 3, 2}}
In[11]:=
problem[5]
Out[11]=
{}
In[12]:=
problem[6]
Out[12]=
{}
There is a surprisingly large number of solutions in the case n=7
In[13]:=
problem[7]
Out[13]=
{{1, 4, 1, 5, 6, 7, 4, 2, 3, 5, 2, 6, 3, 7}, {1, 4, 1, 6, 7, 3, 4, 5, 2, 3,
6, 2, 7, 5}, {1, 5, 1, 4, 6, 7, 3, 5, 4, 2, 3, 6, 2, 7}, {1, 5, 1, 6, 3, 7,
4, 5, 3, 2, 6, 4, 2, 7}, {1, 5, 1, 6, 7, 2, 4, 5, 2, 3, 6, 4, 7, 3}, {1, 5,
1, 7, 3, 4, 6, 5, 3, 2, 4, 7, 2, 6}, {1, 6, 1, 3, 5, 7, 4, 3, 6, 2, 5, 4, 2,
7}, {1, 6, 1, 7, 2, 4, 5, 2, 6, 3, 4, 7, 5, 3}, {1, 7, 1, 2, 5, 6, 2, 3, 4,
7, 5, 3, 6, 4}, {1, 7, 1, 2, 6, 4, 2, 5, 3, 7, 4, 6, 3, 5}, {2, 3, 6, 2, 7,
3, 4, 5, 1, 6, 1, 4, 7, 5}, {2, 3, 7, 2, 6, 3, 5, 1, 4, 1, 7, 6, 5, 4}, {2,
4, 7, 2, 3, 6, 4, 5, 3, 1, 7, 1, 6, 5}, {2, 5, 6, 2, 3, 7, 4, 5, 3, 6, 1, 4,
1, 7}, {2, 6, 3, 2, 5, 7, 3, 4, 6, 1, 5, 1, 4, 7}, {2, 6, 3, 2, 7, 4, 3, 5,
6, 1, 4, 1, 7, 5}, {2, 6, 7, 2, 1, 5, 1, 4, 6, 3, 7, 5, 4, 3}, {2, 7, 4, 2,
3, 5, 6, 4, 3, 7, 1, 5, 1, 6}, {3, 4, 5, 7, 3, 6, 4, 1, 5, 1, 2, 7, 6, 2},
{3, 4, 6, 7, 3, 2, 4, 5, 2, 6, 1, 7, 1, 5}, {3, 5, 7, 2, 3, 6, 2, 5, 4, 1,
7, 1, 6, 4}, {3, 5, 7, 4, 3, 6, 2, 5, 4, 2, 7, 1, 6, 1}, {3, 6, 7, 1, 3, 1,
4, 5, 6, 2, 7, 4, 2, 5}, {3, 7, 4, 6, 3, 2, 5, 4, 2, 7, 6, 1, 5, 1}, {4, 1,
6, 1, 7, 4, 3, 5, 2, 6, 3, 2, 7, 5}, {4, 1, 7, 1, 6, 4, 2, 5, 3, 2, 7, 6, 3,
5}, {4, 5, 6, 7, 1, 4, 1, 5, 3, 6, 2, 7, 3, 2}, {4, 6, 1, 7, 1, 4, 3, 5, 6,
2, 3, 7, 2, 5}, {4, 6, 1, 7, 1, 4, 5, 2, 6, 3, 2, 7, 5, 3}, {4, 6, 3, 5, 7,
4, 3, 2, 6, 5, 2, 1, 7, 1}, {5, 1, 7, 1, 6, 2, 5, 4, 2, 3, 7, 6, 4, 3}, {5,
2, 4, 6, 2, 7, 5, 4, 3, 1, 6, 1, 3, 7}, {5, 2, 4, 7, 2, 6, 5, 4, 1, 3, 1, 7,
6, 3}, {5, 2, 6, 4, 2, 7, 5, 3, 4, 6, 1, 3, 1, 7}, {5, 2, 7, 3, 2, 6, 5, 3,
4, 1, 7, 1, 6, 4}, {5, 3, 6, 4, 7, 3, 5, 2, 4, 6, 2, 1, 7, 1}, {5, 3, 6, 7,
2, 3, 5, 2, 4, 6, 1, 7, 1, 4}, {5, 6, 1, 7, 1, 3, 5, 4, 6, 3, 2, 7, 4, 2},
{5, 7, 1, 4, 1, 6, 5, 3, 4, 7, 2, 3, 6, 2}, {5, 7, 2, 3, 6, 2, 5, 3, 4, 7,
1, 6, 1, 4}, {5, 7, 2, 6, 3, 2, 5, 4, 3, 7, 6, 1, 4, 1}, {5, 7, 4, 1, 6, 1,
5, 4, 3, 7, 2, 6, 3, 2}, {6, 1, 5, 1, 7, 3, 4, 6, 5, 3, 2, 4, 7, 2}, {6, 2,
7, 4, 2, 3, 5, 6, 4, 3, 7, 1, 5, 1}, {7, 1, 3, 1, 6, 4, 3, 5, 7, 2, 4, 6, 2,
5}, {7, 1, 4, 1, 6, 3, 5, 4, 7, 3, 2, 6, 5, 2}, {7, 2, 4, 5, 2, 6, 3, 4, 7,
5, 3, 1, 6, 1}, {7, 2, 4, 6, 2, 3, 5, 4, 7, 3, 6, 1, 5, 1}, {7, 2, 6, 3, 2,
4, 5, 3, 7, 6, 4, 1, 5, 1}, {7, 3, 1, 6, 1, 3, 4, 5, 7, 2, 6, 4, 2, 5}, {7,
3, 6, 2, 5, 3, 2, 4, 7, 6, 5, 1, 4, 1}, {7, 4, 1, 5, 1, 6, 4, 3, 7, 5, 2, 3,
6, 2}}
It took about half an hour to get this, which is about the limit of my
patience in this case. However, I gues sth ealgorithm is still capable of a
few more answers.
Andrzej Kozlowski
Toyama International University
JAPAN
http://sigma.tuins.ac.jp
http://eri2.tuins.ac.jp
----------
>From: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
To: mathgroup at smc.vnet.net
>To: mathgroup at smc.vnet.net
>Subject: [mg19536] [mg19524] Re: [mg19520] Numbers problem
>Date: Sun, Aug 29, 1999, 10:21 PM
>
> Problems like this one consist of two parts, a hard one and a (realtively)
> easy one. The hard one is finding a workable algorithm. The easy one is
> writing a mathematica program to implement it. In your case I do not know
> any workable algorithm (but then I have given this matter no time at all). I
> know of course the obvious one: find all possible distinct permutations of a
> list of your type and select from it elements satisfying your condition.
> Clearly no implementation of this algorithm will be workable for anything
> but small values of n. But anyway, here is a quick implementation of this
> essentially useless method:
>
> First we load the combinatorica package in order to use its
> DistinctPermutations function:
>
> In[1]:=
> << DiscreteMath`Combinatorica`
>
>
> Next we define our test function.
>
> In[2]:=
> test[l_List, i_] := (Last[#] - First[#]) &@Flatten[Position[l, i]] - 1 == i;
> test[l_List] := Apply[And, Map[test[l, #] &, Union[l]]]
>
> Now we can find the solution of your example:
>
> In[3]:=
> Select[DistinctPermutations[{1, 1, 2, 2, 3, 3}], test]
> Out[3]=
> {{2, 3, 1, 2, 1, 3}, {3, 1, 2, 1, 3, 2}}
>
> We can also get the next case:
>
> In[4]:=
> Select[DistinctPermutations[{1, 1, 2, 2, 3, 3, 4, 4}], test]
> Out[4]=
> {{2, 3, 4, 2, 1, 3, 1, 4}, {4, 1, 3, 1, 2, 4, 3, 2}}
>
> Beyond that things will get very slow. I have not considered the efficiency
> of my implementation at all because I am pretty sure that unless you or
> someone else can propose a better algorithm not even a Mathematica speed
> demon like Carl Woll can make any significant difference here.
> --
> Andrzej Kozlowski
> Toyama International University
> JAPAN
> http://sigma.tuins.ac.jp
> http://eri2.tuins.ac.jp
>
>
> ----------
>>From: Mecit Yaman <mecit at iname.com>
To: mathgroup at smc.vnet.net
> To: mathgroup at smc.vnet.net
>>To: mathgroup at smc.vnet.net
>>Subject: [mg19536] [mg19524] [mg19520] Numbers problem
>>Date: Sun, Aug 29, 1999, 8:00 AM
>>
>
>>
>> Hi there,
>>
>> I am trying to solve a problem with Mathematica. You
>> have numbers from 1 to n all
>> numbers twice , namely.
>>
>> 1 1 2 2 3 3 4 4 5 5 for example for n=5
>>
>> I am trying to sort the numbers o that between two 'n's
>> there must be exactly n
>> numbers.
>>
>> For example if n=3 the solution is
>> 2 3 1 2 1 3 . You see there is 1 number between 1 and
>> 1. and 2 numbers between 2
>> and 2, and 3 between 3's.
>>
>> I know this forum is not for asking problems. But i am
>> learning Mathematica and
>> wanna see how professionals solve a real problem with
>> Mathematica.
>>
>> Thank you very much for giving me a chance to ask my
>> question.
>> Best wishes to everyone.
>>
>>
>>
>>
>>
>>
>
>