Permutation Algorithm

[mark609]

I'm stuck. I need help with either an algorithm or sample code for a permutation routine. Basically, what I want to be able to do is this: Allow the user to enter between 2 and 6 alphanumeric characters. What I need to display in return is each of the possible combinations. So, for instance, if the user enters 6 characters, then there will be 6! or 720 possible combinations of those fixed characters (I don't care if the user enters two of the same thing). I really don't care if it's a recursive routine or not. Any assistance would be GREATLY appreciated. Thank you

 

[TimLarkin]

I used this with a form that had a listbox that diplays all the permutations. This code does not remove dupes. (string "ABA" will return "ABA" twice) Code is not case sensitive.
this is in a bas module:
Option Explicit
Type Letters
Letter As String * 1
InUse As Boolean
End Type
Private aryLetters() As Letters
Private aryWord() As Integer
Public flgStop As Boolean
Private intLowReturn As Integer
Private intHighReturn As Integer
Private intCurrentWordSize As Integer
Private lstOutPut As ListBox

Public Sub GetWords(ByVal strWord As String, intReturnSize As Integer, ByRef lstYourList As ListBox)
Dim ctrWordSize As Integer
Dim ctrFill As Integer

Set lstOutPut = lstYourList
strWord = UCase(strWord)
ReDim aryLetters(1 To Len(strWord))
'fill letter array
For ctrFill = 1 To Len(strWord)
aryLetters(ctrFill).InUse = False
aryLetters(ctrFill).Letter = Mid(strWord, ctrFill, 1)
Next

ReDim aryWord(1 To Len(strWord))

If intReturnSize = 0 Then
intLowReturn = 1
intHighReturn = Len(strWord)
Else
intLowReturn = intReturnSize
intHighReturn = intReturnSize
End If
For ctrWordSize = intLowReturn To intHighReturn
intCurrentWordSize = ctrWordSize
MakeWords 1, Len(strWord)
Next
End Sub

Private Sub MakeWords(intIteration As Integer, intLenWord As Integer)
Dim ctrCurLetter As Integer
Dim ctrSpellWord As Integer
Dim strTemp As String

For ctrCurLetter = 1 To intLenWord
'get letter
If aryLetters(ctrCurLetter).InUse = False Then
aryLetters(ctrCurLetter).InUse = True
aryWord(intIteration) = ctrCurLetter
'see if done
If intIteration = intCurrentWordSize Then
strTemp = ""
'create word
For ctrSpellWord = 1 To intCurrentWordSize
strTemp = strTemp & aryLetters(aryWord(ctrSpellWord)).Letter
Next
'add word to list
lstOutPut.AddItem strTemp
Else
'if not go to next iteration
MakeWords intIteration + 1, intLenWord
End If
'clear current letter
aryLetters(ctrCurLetter).InUse = False
End If

Next
End Sub


called on form:
GetWords txtWord.Text, vsWordSize.Value, Me.lstWord

txtWord.Text is the string to do the permutations on.

vsWordSize.Value is the permutation length returned. If you pass a string of 5 characters and a length of 3, it will return only 3 char long perms . If a length = 0 is passed, it will return all perm. lengths from 1 to len(string).

Me.lstWord is the name of the list box.

GL & Have fun!!
Tim Tim

Remember the KISS principle:
Keep It Simple, Stupid!

 

[chiuchimu]

Here is a simple Caveman method

Option Explicit
Private Dat() As Integer
Private Di() As Integer
Private Num As Integer
Private Index As Integer

Private Sub Form_Load()
Num = 0
End Sub

Private Sub Text_KeyPress(KeyAscii As Integer)
If Num < 6 Then
ReDim Preserve Dat(Num + 1)
Dat(Num) = KeyAscii
Num = Num + 1
End If
End Sub

Private Sub Button_Click()
Dim Rep As Long
Dim X As Long
Dim Y As Integer
ReDim Di(Num)
Index = 0
For X = 0 To Num - 1
Di(X) = 0
Next X
Rep = Num ^ Num
For X = 1 To Rep
Di(0) = Di(0) + 1
For Y = 0 To Num - 2
If Di(Y) = Num Then
Di(Y) = 0
Di(Y + 1) = Di(Y + 1) + 1
End If
Next Y
PrintIfGood
Next X
End Sub

Private Sub PrintIfGood()
Dim i%
Dim j%
Dim Fg%
Dim tempstr As String
Fg = 0
For i = 0 To Num - 2
For j = i + 1 To Num - 1
If Di(i) = Di(j) Or Di(i) = Num Or Di(j) = Num Then Fg = 1
Next j
Next i
If Fg = 0 Then
For i = 0 To Num - 1
tempstr = tempstr & Chr$(Dat(Di(i)))
Next i
List.List(Index) = tempstr
Index = Index + 1
Text1 = Index
End If
End Sub

Things that aren't handled are
1) Reseting variables for next use
2) Checking for printable characters

Have fun!

 

[Parke]

An example with VBScript using brute force, all that I've access to at the moment. If you need to remove duplicates, throw the results into a dictionary and let it do the filtering.

myString = &quot;a,b,c,d,e,f&quot;
'myString = &quot;a,b,c,d,e&quot;
'myString = &quot;a,b,c,d&quot;
'myString = &quot;a,b,c&quot;
myArray = Split(myString,&quot;,&quot
arraySize = UBound(myArray)

newString = Join(myArray,&quot;&quot

UB = UBound(myArray)
count = 0

For m = 1 to 6
For n = 1 to 5
For k = 1 to 4
For i = 1 to 3
For j = 1 to 2
Swap myArray(UB-j), myArray(UB)
newString = Join(myArray, &quot;&quot
s = s & newString & i & j & vbcrlf
count = count + 1
Next
Next
If UB > 2 Then
' first swap does a nicer job of grouping the permatations
' to visually verify that things look okay
Swap myArray(UB-k+1), myArray(UB-j)
'Swap myArray(0),myArray(UB-(i-1))
Else
Exit For
End If
Next
If UB > 3 Then
Swap myArray(0),myArray(UB-(n-1))
Else
Exit For
End If
Next
If UB > 4 Then
Swap myArray(0),myArray(UB-(m-1))
Else
Exit For
End If
Next

msgbox s
msgbox &quot;number is &quot; & count


Sub Swap(x,y)
temp = x
x = y
y = temp
End Sub

Enjoy.