Permutation with "n" numbers

I have three "slots". I have "n" numbers (at least three). I have to place these numbers into the slots in all available variation, without leaving empty slots. Like if I get the numbers 1, 2 and 3, the variations are: 1 2 3; 1 3 2; 2 1 3
2 3 1; 3 1 2; 3 2 1.
The question is what is the code for that? With 4 numbers or 5 or ANY.
Naturally, a "slot" can hold any numbers, but at least one!
Psycho1Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Psycho1Author Commented:
If i get the numbers 1, 2 and 2 there's 6 solutions too. The user can enter anything. I have to separate'em.
0
amebaCommented:
>If i get the numbers 1, 2 and 2 there's 6 solutions too
What 6 solutions?
0
deightonprogCommented:
use this allanags routine, sends them to the debug window at the moment

Option Explicit


Private Function bubble(x() As String, i As Long)

    Dim c As Long
    Dim bF As Boolean
    Dim z As String
   
    Dim y() As String
   
    ReDim y(i)
   
    Do
       
        bF = True
        For c = 1 To i - 1
       
            If x(c) > x(c + 1) Then
                bF = False
                z = x(c)
                x(c) = x(c + 1)
                x(c + 1) = z
            End If
        Next
    Loop Until bF
   

End Function

Private Function factorial(i As Integer) As Long

    Dim c As Integer
   
    factorial = 1
    For c = 2 To i
        factorial = factorial * c
    Next

End Function

Private Function perm(x() As String, sString, number)

    Dim iLen As Integer
    Dim sTarget As String
    Dim lCount As Long
    Dim c As Integer
    Dim d As Long
    Dim l, r
   
    iLen = Len(sString)

    If iLen = 1 Then
   
       
        x(1) = sString
        number = 1
       
    Else
   
        Dim a() As String
        ReDim a(factorial(iLen))
               
        For c = 1 To iLen
               
            If c > 1 Then
                l = Mid(sString, 1, c - 1)
            Else
                l = ""
            End If
            If c < iLen Then
                r = Mid(sString, c + 1, iLen - c)
            Else
                r = ""
            End If
           
            sTarget = l & r
            lCount = 0
            Call perm(a, sTarget, lCount)
            For d = 1 To lCount
                number = number + 1
                x(number) = Mid(sString, c, 1) & a(d)
            Next
           
        Next
       
    End If
           

End Function




Private Sub allanags(sstr As String)

    Dim x() As String
    Dim number As Long
    Dim c As Long
   
    ReDim x(factorial(Len(sstr)))
   
   
    Call perm(x(), sstr, number)
   
    Call bubble(x, number)
   
    For c = 1 To number
   
        Debug.Print x(c)
       
    Next
    Stop
   
   

End Sub

Private Sub Command1_Click()

    Call allanags("1234")

End Sub
0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

anthonycCommented:
Here is the theory on how to do it

1)  Calculate how many permutations there are.  Basically the calculation is:

Size = N! / (A! * (N-A)!)

Where N is the total number, and A is the container size (! is factorial)


2)  Build a 2 dimensional array:

redim x(1 to N, 1 to A) as integer

3)  Populate the array with this code

k = 0 'offset
for i = 1 to Size
   for j = 1 to A
      x(i,j) = (((i - 1) mod n) + 1)
      if j = 1 then  
         x(i,j) = x(i,j) + k
         k = k + 1
         if k >= n then k = 0
      end if
   next j
next i

Now the array will contain all of the combinations, "vertically".  

For example, perm #1 is

x(1, 1) & x(1, 2) & ... & x(1,n)



Make sense?
0
johnny6Commented:
Interesting question...I think anthonyc has a good, simple algorithm.
0
tureCommented:
Psycho1,

Here's my suggestion:

Sub SlotMachine()
  Dim n As Long, s1 As Long, s2 As Long, s3 As Long, c As Long
  n = 3
  Debug.Print "List of possible combinations"
  For s1 = 1 To n
    For s2 = 1 To n
      For s3 = 1 To n
        If s1 <> s2 And s1 <> s3 And s2 <> s3 Then
          c = c + 1
          Debug.Print s1, s2, s3
        End If
      Next s3
    Next s2
  Next s1
  Debug.Print "Number of combinations: "; c
End Sub

Ture Magnusson
Karlstad, Sweden
0
Psycho1Author Commented:
Thanks but (how I wrote) I have to place them into that three slots (a simple List). So if the user gave me four numbers the solutions can be (for example):

1  2  3
4

or

1  3  4
2

and so on.

The "permutation-section" not solves this exactly.
0
Psycho1Author Commented:
deighton:

I'm increased the points to 200.
0
tureCommented:
Psycho1,

Do you mean that you want to save all combinations in an array? Here is a procedure that does that. and shows the array afterwards.

Sub TuresSlotMachine()
  Dim slots() As Long
  Dim n As Long, s1 As Long, s2 As Long, s3 As Long, c As Long, r As Long
  n = 3
       
  'Save all possible combinations to an array
  For s1 = 1 To n
    For s2 = 1 To n
      For s3 = 1 To n
        If s1 <> s2 And s1 <> s3 And s2 <> s3 Then
          c = c + 1
          ReDim Preserve slots(1 To 3, 1 To c)
          slots(1, c) = s1
          slots(2, c) = s2
          slots(3, c) = s3
        End If
      Next s3
    Next s2
  Next s1
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For r = 1 To c
    Debug.Print slots(1, r), slots(2, r), slots(3, r)
  Next r
  Debug.Print "Number of combinations: "; c
End Sub

/Ture
0
Psycho1Author Commented:
deighton:

Another thing! The user can enter ANY numbers. Like 34, 125, 1987065, 1, 9 etc.
0
tureCommented:
Psycho1,

It seems as if you are communicating only with deighton. Are the rest of us completely off target?

/Ture
0
tureCommented:
My procedure again, modified to enter all possible combinations of a list of numbers into the three slots.

Sub TuresSlotMachine()
  Dim numbers, slots() As Long
  Dim s1 As Long, s2 As Long, s3 As Long, c As Long, r As Long
   
  numbers = Array(5, 11, 793, 1024)
       
  'Save all possible combinations to an array
  For s1 = 0 To UBound(numbers)
    For s2 = 0 To UBound(numbers)
      For s3 = 0 To UBound(numbers)
        If s1 <> s2 And s1 <> s3 And s2 <> s3 Then
          c = c + 1
          ReDim Preserve slots(1 To 3, 1 To c)
          slots(1, c) = numbers(s1)
          slots(2, c) = numbers(s2)
          slots(3, c) = numbers(s3)
        End If
      Next s3
    Next s2
  Next s1
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For r = 1 To c
    Debug.Print slots(1, r), slots(2, r), slots(3, r)
  Next r
  Debug.Print "Number of combinations: "; c
End Sub

/Ture
0
Psycho1Author Commented:
ture:

It works, but (I wrote it before) I need all the combinations. Any slot can hold any numbers(at least one). So with your example (5, 11, 793, 1024) one of the solutions is:

slot1  slot2  slot3
 5      11     793
1024

If you give me another code wich one is doing this thing I'll unlock the question for you and the points are yours.
0
tureCommented:
Psycho1,

Thanks for responding.

I think that I misunderstood you before. Is this interpretation correct?

1. Each slot can hold one OR SEVERAL numbers.

2. In each combination, ALL the numbers should be put into slots.

What result do you want? A three-dimensional array with all combinations? Or perhaps it's enough with just a count of the number of combinations?

/Ture
0
deightonprogCommented:
'Here it is

    Dim N As Integer 'number of numbers
    Dim iSlot() As Integer
    Dim x As Integer
    Dim y As Integer
    Dim z As Integer
    Dim O() As Integer
    Dim c As Long
    Dim bSorted As Boolean, b As Boolean
    Dim d As Long
    Dim temp1, temp2, temp3
   
   
    N = 4
    ReDim iSlot(1 To 3, factorial(N))
    ReDim O(1 To N)
   
   
    O(1) = 1
    O(2) = 4
    O(3) = 4
    O(4) = 4
   
    For x = 1 To N
    For y = 1 To N
    For z = 1 To N
       
        If x <> y And y <> z And x <> z Then
           
            c = c + 1
            iSlot(1, c) = O(x)
            iSlot(2, c) = O(y)
            iSlot(3, c) = O(z)
           
        End If
       
    Next z, y, x
   
           
    Do
        bSorted = True
        For d = 1 To c - 1
            b = False
            If iSlot(1, d) > iSlot(1, d + 1) Then
                b = True
            ElseIf iSlot(1, d) = iSlot(1, d + 1) Then
                If iSlot(2, d) > iSlot(2, d + 1) Then
                    b = True
                ElseIf iSlot(2, d) = iSlot(2, d + 1) Then
                    If iSlot(3, d) > iSlot(3, d + 1) Then
                        b = True
                    End If
                End If
            End If
            If b Then
                temp1 = iSlot(1, d)
                temp2 = iSlot(2, d)
                temp3 = iSlot(3, d)
                iSlot(1, d) = iSlot(1, d + 1)
                iSlot(2, d) = iSlot(2, d + 1)
                iSlot(3, d) = iSlot(3, d + 1)
                iSlot(1, d + 1) = temp1
                iSlot(2, d + 1) = temp2
                iSlot(3, d + 1) = temp3
                bSorted = False
            End If
        Next
    Loop Until bSorted
           
    temp1 = iSlot(1, 1)
    temp2 = iSlot(2, 1)
    temp3 = iSlot(3, 1)
   
    'islot holds all different permutations
    'print a list without repeated permutations
    'seems wise
   
    Debug.Print "**"
    Debug.Print temp1, temp2, temp3
    For d = 2 To c
        If temp1 <> iSlot(1, d) Or _
           temp2 <> iSlot(2, d) Or _
           temp3 <> iSlot(3, d) Then
            Debug.Print iSlot(1, d), iSlot(2, d), iSlot(3, d)
            temp1 = iSlot(1, d)
            temp2 = iSlot(2, d)
            temp3 = iSlot(3, d)
           
        End If
    Next

0
amebaCommented:
0
Psycho1Author Commented:
ture:

I want a 3 dimensional array with all the combinations.

for example:

1  2  3          |BUT! This one's are 4                |the same!:
                 |
1  2  3          |1  2  3
   4             |4
                 |
etc.             |4  2  3
                 |1

I have to sort out the right side's solutions because they are the same.
And I need all the possible combinations with using every time all the numbers, and all the slots (can't be an empty slot).

deighton:
It looks like ture can give me a much smaller code.

I've increased the points to 250!
0
Psycho1Author Commented:
The example again, 'cause it looks dizzy... Sorry. :-(

1 2 3
4

1 2 3
  4
etc.

INCORRECT:

1 2 3
4

4 2 3
1

The first slot contains the same solution.
0
anthonycCommented:
guys..  Don't use 3 dimensional arrays.  Use collections or something instead.  There is never a need for a 3 dimensional array.  Not for something this trivial.

Did you read my theory, or just skip it because it didn't contain code?
0
amebaCommented:
>guys..  Don't use 3 dimensional arrays.  
I am not using it. :)
0
tureCommented:
Psycho1,

Here's another one for you!

Sub TuresSlotMachine()
  'Declare variables
  Dim Numbers As Variant
  Dim CountOfNumbers As Integer
  Dim Slots() As Long
  Dim CountOfNumbersInSlot(1 To 3) As Integer
  Dim SlotForThisNumber() As Integer
 
  Dim Counter As Long
  Dim WhichNumber As Integer
  Dim SlotNumber As Integer
  Dim SlotRowNumber As Integer
 
  Dim x As Long
  Dim r As Long
     
  'Initialize variables
  Numbers = Array(5, 11, 793, 1024)
  CountOfNumbers = UBound(Numbers) + 1
  ReDim SlotForThisNumber(1 To CountOfNumbers)
  ReDim Slots(1 To 3, 1 To CountOfNumbers, 1 To 1)
 
  'Initialize SlotForThisNumber to 1 for all numbers
  For WhichNumber = 1 To CountOfNumbers
    SlotForThisNumber(WhichNumber) = 1
  Next WhichNumber
 
  Do
    'Increase number of combinations and expand the Slots array
    Counter = Counter + 1
    ReDim Preserve Slots(1 To 3, 1 To CountOfNumbers, 1 To Counter)
   
    'Clear the number of entries in each Slot
    For SlotNumber = 1 To 3
      CountOfNumbersInSlot(SlotNumber) = 0
    Next SlotNumber

    'Loop through all numbers from 1 to CountOfNumbers
    For WhichNumber = 1 To CountOfNumbers
      SlotNumber = SlotForThisNumber(WhichNumber)
      CountOfNumbersInSlot(SlotNumber) = CountOfNumbersInSlot(SlotNumber) + 1
      SlotRowNumber = CountOfNumbersInSlot(SlotNumber)
      Slots(SlotNumber, SlotRowNumber, Counter) = Numbers(WhichNumber - 1)
    Next WhichNumber
   
    'Clear the Slots array for the last combination
    'and decrease Counter with 1 if any slots are empty
    For SlotNumber = 1 To 3
      If CountOfNumbersInSlot(SlotNumber) = 0 Then
        For SlotRowNumber = 1 To CountOfNumbers
          Slots(1, SlotRowNumber, Counter) = 0
          Slots(2, SlotRowNumber, Counter) = 0
          Slots(3, SlotRowNumber, Counter) = 0
        Next SlotRowNumber
        Counter = Counter - 1
        Exit For
      End If
    Next SlotNumber

    'Exit loop if all entries in SlotForThisNumber are 3
    For WhichNumber = 1 To CountOfNumbers
      If SlotForThisNumber(WhichNumber) <> 3 Then Exit For
      Exit Do
    Next WhichNumber
   
    'Increase SlotForThisNumber counters
    SlotForThisNumber(CountOfNumbers) = SlotForThisNumber(CountOfNumbers) + 1
    For WhichNumber = CountOfNumbers To 2 Step -1
      If SlotForThisNumber(WhichNumber) = 4 Then
        SlotForThisNumber(WhichNumber) = 1
        SlotForThisNumber(WhichNumber - 1) = SlotForThisNumber(WhichNumber - 1) + 1
      End If
    Next WhichNumber
  Loop
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For x = 1 To Counter
    Debug.Print "Combination #"; x
    For SlotRowNumber = 1 To CountOfNumbers
      If (Slots(1, SlotRowNumber, x) + Slots(2, SlotRowNumber, x) + Slots(3, SlotRowNumber, x)) <> 0 Then
        For SlotNumber = 1 To 3
          Debug.Print Slots(SlotNumber, SlotRowNumber, x),
        Next SlotNumber
        Debug.Print
      End If
    Next SlotRowNumber
  Next x
End Sub

/Ture
0
Psycho1Author Commented:
Ture:

It gaves me 24 solutions. I think it have to be 36? Am I right?
'Cause with 4 numbers # of solutions are:

(3 'on' 4 - 3 slots and 4 numbers)

(3*3*3*3 - (3*(2*2*2*2))) + 3

And it gives you 36. I fake it somewhere or your code is not perfect(yet :-)?
0
tureCommented:
My code is not perfect yet. It still reports both of these as different combinations:

1 2 3
4

4 2 3
1

/Ture
0
Psycho1Author Commented:
Ture:

I hope that you want to make it perfect, because I want to give you that points! :-))
Anyway! With four numbers there's must be 36 solutions! I'm sure.
0
Psycho1Author Commented:
Another comment for Ture:

Do not forget that the three slots are different! So this is a good group:

slot #1 #2 #3
     1  2  3
     4

     2  3  4
           1

That's why 36 solutions exists with 4 numbers.
0
tureCommented:
Psycho1,

This code correctly produces 36 combinations for the four numbers given.
The problem with the previous code was that it ended before looping through all possible combinations.

Sub TuresSlotMachine()
  'Declare variables
  Dim Numbers As Variant
  Dim CountOfNumbers As Integer
  Dim Slots() As Long
  Dim CountOfNumbersInSlot(1 To 3) As Integer
  Dim SlotForThisNumber() As Integer
  Dim Counter As Long
  Dim WhichNumber As Integer
  Dim SlotNumber As Integer
  Dim SlotRowNumber As Integer
  Dim x As Long
     
  'Initialize variables
  Numbers = Array(5, 11, 793, 1024)
  CountOfNumbers = UBound(Numbers) + 1
  ReDim SlotForThisNumber(1 To CountOfNumbers)
  ReDim Slots(1 To 3, 1 To CountOfNumbers, 1 To 1)
 
  For WhichNumber = 1 To CountOfNumbers
    SlotForThisNumber(WhichNumber) = 1
  Next WhichNumber
 
  Do
    'Exit loop if all entries in SlotForThisNumber are 3
    x = 0
    For WhichNumber = 1 To CountOfNumbers
      x = x + SlotForThisNumber(WhichNumber)
    Next WhichNumber
    If x = CountOfNumbers * 3 Then Exit Do
   
    'Increase number of combinations and expand the Slots array
    Counter = Counter + 1
    ReDim Preserve Slots(1 To 3, 1 To CountOfNumbers, 1 To Counter)
   
    'Clear the number of entries in each Slot
    For SlotNumber = 1 To 3
      CountOfNumbersInSlot(SlotNumber) = 0
    Next SlotNumber

    'Loop through all numbers from 1 to CountOfNumbers
    For WhichNumber = 1 To CountOfNumbers
      SlotNumber = SlotForThisNumber(WhichNumber)
      CountOfNumbersInSlot(SlotNumber) = CountOfNumbersInSlot(SlotNumber) + 1
      SlotRowNumber = CountOfNumbersInSlot(SlotNumber)
      Slots(SlotNumber, SlotRowNumber, Counter) = Numbers(WhichNumber - 1)
    Next WhichNumber
   
    'Clear the Slots array for the last combination
    'and decrease Counter with 1 if any slots are empty
    For SlotNumber = 1 To 3
      If CountOfNumbersInSlot(SlotNumber) = 0 Then
        For SlotRowNumber = 1 To CountOfNumbers
          Slots(1, SlotRowNumber, Counter) = 0
          Slots(2, SlotRowNumber, Counter) = 0
          Slots(3, SlotRowNumber, Counter) = 0
        Next SlotRowNumber
        Counter = Counter - 1
        Exit For
      End If
    Next SlotNumber
   
    'Increase SlotForThisNumber counters
    SlotForThisNumber(CountOfNumbers) = SlotForThisNumber(CountOfNumbers) + 1
    For WhichNumber = CountOfNumbers To 2 Step -1
      If SlotForThisNumber(WhichNumber) = 4 Then
        SlotForThisNumber(WhichNumber) = 1
        SlotForThisNumber(WhichNumber - 1) = SlotForThisNumber(WhichNumber - 1) + 1
      End If
    Next WhichNumber
  Loop
 
  'Now, let's see the list
  Debug.Print "List of possible combinations:"
  For x = 1 To Counter
    Debug.Print "Combination #"; x
    For SlotRowNumber = 1 To CountOfNumbers
      If (Slots(1, SlotRowNumber, x) + Slots(2, SlotRowNumber, x) + Slots(3, SlotRowNumber, x)) <> 0 Then
        For SlotNumber = 1 To 3
          Debug.Print Slots(SlotNumber, SlotRowNumber, x),
        Next SlotNumber
        Debug.Print
      End If
    Next SlotRowNumber
  Next x
End Sub

/Ture
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
tureCommented:
*******************************************************************
0
cvidlerCommented:
what exactly are you trying to do. What will your program be used for - maybe I'll beable to give you a solution if I know what's going to happen with the results?
0
Psycho1Author Commented:
ture:

It's PERFECT! Thank You very much! You've saved my life! These points are yours!

0
Psycho1Author Commented:
Thanks again...
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.