# Permutations - An advance way?

I have a basic permutations script, which allows you to input a string of letters/numbers, etc and it will give you all the different variations.. But I want to go further then that. Let's say I have two 6 letter words...  NNTMMP, PMLANP.. Randomish right?

Okay, so generally I'd do a permuation (the script I'm attaching) to both of them. But theres a twist I wanted to addon. Basicly it would be:

NNTMMP
PMLANP

I also would want it to take the letters and mix and match, BUT, the letters have to be SWAPPED.. and still in the same POSITION. for example

PNTMMP
NMLANP
(swapped N/P..) or..

PNLMMP
NMTANP
(swapped N/P and L/T)...

NNLMNP
PMTAMP
(swapped L/T, M/N)

Anyways... it would THEN have to get the permutations of each new 6 letter word, unless no differ (as you see the two p's would make no differ), but neverless it can still go through and create duplicates, it's not a huge deal, it all gets weaved out in the end anyways. Whatever would be easier.

How would this be solved? Is there any examples around/help?
``````Option Explicit
Private StrArray(0 To 8) As String

Dim w

StrArray(0) = ""
StrArray(1) = ""
StrArray(2) = "ABC"
StrArray(3) = "GHI"
StrArray(4) = "JKL"
StrArray(5) = "MNO"
StrArray(6) = "PQRS"
StrArray(7) = "TUV"
StrArray(8) = "WXYZ"

For Each w In Permutate("234567")
Debug.Print w
Next

End Sub

Private Function Permutate(User As String) As Collection
Dim idx As Long, siz As Long
Dim halt As String, word As String

' Test input
Set Permutate = New Collection
If User Like "*[!0-8]*" Then Exit Function

' Init variables
siz = Len(User)
word = Space\$(siz)

' Init odometer, convert input to mumerical values
ReDim odm(1 To siz) As Byte
ReDim usr(1 To siz) As Byte
For idx = 1 To siz
odm(idx) = 1
usr(idx) = Val(Mid\$(User, idx, 1))
Next

' Run counting loop
Do
' Build word, save it
For idx = 1 To siz
Mid(word, idx, 1) = Mid\$(StrArray(usr(idx)), odm(idx), 1)
Next

' Increment odometer
odm(siz) = odm(siz) + 1

' Handle rollovers
idx = siz
Do While odm(idx) > Len(StrArray(usr(idx)))
odm(idx) = 1
idx = idx - 1
If idx = 0 Then Exit Function
odm(idx) = odm(idx) + 1
Loop
Loop

End Function
``````
LVL 7
###### 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.

Commented:
This is off the cuff, so my syntax might be a little rough.  Give this a shot

Private Function Permutate(User As String) As Collection
Dim i As Long
Dim p as String

' Test input
Set Permutate = New Collection
If User Like "*[!0-8]*" Then Exit Function

For i = 1 to Len(User)
For Each p In Permutate(Mid\$(User,2))
Next
User = Mid\$(User,2) & Left\$(User,1)
Next
End Function
0
Commented:
I am not certain I understand the question.  Since you already have code to do the permutations are you looking for code to identify all possible letter swap combinations?
I.e., swap the letters in position 1 or the letters in position 2, etc. or
the letters in positions 1 and 2; 1 and 3, etc. or
the letters in positions 1, 2, and 3; 1, 2 and 4, etc.

If this is what you want there is a simple solution I believe.
0
Author Commented:
Yes basicly swap combinations, thats what I ment to say. But also be able to swap more then one number at a time. So you can swap one/two/three/four/five.. But they must swap only down and up, as in 1 and 4 cannot swap, but 1 and 2 can.. heres what I mean.. lets pretend the numbers are letters. There are supposed to be 6 letters per word, but I've only done five so I can use all the numbers only once:

So ignoring the permuatations:

01234
56789

Are the set. Basicly numbers can swap up and down, but not across.... For example 0 and 5 can swap, but not 0 and 6 (or any other number)... 2 and 7 can swap, 4 and 9 can swap, since there in the same range.... So for example you can do:

51784
06239

So they can move up and down just not left and right. And after each up and down movement I'll be calling the permuatations script.

It's basicly like a permuatation script for swapping up and down, since I would basicly need all combinations.

0
Commented:
So you need a procedure that will take 2 parameters and generate all the permutations of both including the special swap rules?

ok will post shortly
0
Author Commented:
Yep! thanks!
0
Commented:
It appears to me that each operation can be expressed by a 5 bit binary number.  For example, if you want to swap the elements in positions 1 3 and 5, say
ABCDE
FGHJK
to produce
FBHDK
AGCJE
The you are using the bit pattern 10101
Every 5 bit pattern corresponds to a valid swap unless it is repetitious due to repetitions in letters.
So, all you need to do is generate every 5 bit pattern.
These are, of course, the numbers from 1 to 31 in binary.
I hope this is of use.
0
Commented:
try this...

``````Option Explicit

Dim s As Variant
Dim p As Variant
Dim i As Integer

'    i = 0
'    For Each s In ListSwaps("123", "456")
'        i = i + 1
'        debug.print Text1.Text & i & "-" & s
'        Text1.Text = Text1.Text & i & "-" & s & vbCrLf
'    Next

'    i = 0
'    For Each s In Permutate("123")
'        i = i + 1
'        Debug.Print Text1.Text & i & "-" & s
'        'Text1.Text = Text1.Text & i & "-" & s & vbCrLf
'    Next

For Each s In ListSwaps("123", "456")
For Each p In Permutate(Trim(Str(s)))
Debug.Print Text1.Text & p
'            Text1.Text = Text1.Text & p & vbCrLf
Next
Next

End Sub

Private Function Permutate(pString As String) As Collection
Dim i As Integer
Dim s As Variant
Dim temp As String

If Len(pString) = 0 Then Exit Function

Set Permutate = New Collection

If Len(pString) = 1 Then
Else
temp = pString

For i = 1 To Len(temp)
For Each s In Permutate(Mid\$(temp, 2))
Next
temp = Mid\$(temp, 2) & Left\$(temp, 1)
Next
End If
End Function

Private Function ListSwaps(pStr1 As String, pStr2 As String) As Collection
Dim i As Integer
Dim j As Integer
Dim minlen As Integer
Dim temp1 As String
Dim temp2 As String

Set ListSwaps = New Collection
If Len(pStr1) > Len(pStr2) Then
minlen = Len(pStr2)
Else
minlen = Len(pStr1)
End If

For i = 1 To (2 ^ minlen)
temp1 = pStr1
temp2 = pStr2
For j = 1 To minlen
If i And (2 ^ (j - 1)) Then
temp1 = Left\$(temp1, j - 1) & Mid\$(pStr2, j, 1) & Mid\$(temp1, j + 1)
temp2 = Left\$(temp2, j - 1) & Mid\$(pStr1, j, 1) & Mid\$(temp2, j + 1)
End If
Next
Next
End Function
``````
0

Experts Exchange Solution brought to you by