• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 270
  • Last Modified:

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
 
Private Sub Form_Load()
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
    Permutate.Add word
 
    ' 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

Open in new window

0
Valleriani
Asked:
Valleriani
  • 3
  • 3
  • 2
1 Solution
 
sdstuberCommented:
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))
          Permutate.Add Left$(User,1) & p
      Next          
      User = Mid$(User,2) & Left$(User,1)
  Next
End Function
0
 
roussoscCommented:
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
 
VallerianiAuthor 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.

Thanks for the reply!
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
sdstuberCommented:
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
 
VallerianiAuthor Commented:
Yep! thanks!
0
 
roussoscCommented:
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
 
sdstuberCommented:
try this...


Option Explicit
 
Private Sub Form_Load()
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
        Permutate.Add pString
    Else
        temp = pString
 
        For i = 1 To Len(temp)
            For Each s In Permutate(Mid$(temp, 2))
                Permutate.Add Left$(temp, 1) & s
            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
        ListSwaps.Add temp1
    Next
End Function

Open in new window

0
 
VallerianiAuthor Commented:
Perfect, thank you!
0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 3
  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now