Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0748: String-Permutationen, alle Permutationen eines Arrays oder Zeichen eines Strings ausgeben

 von 

Beschreibung 

Wenn man alle verschiedenen Kombinationen, bzw. Permutationen von Zeichen eines Strings oder eines Arrays von Strings finden muß, oder wenn man zu einer bestimmmten Nummer eine Kombination ausgeben will, dann kann dieser Tipp vielleicht weiterhelfen. Es wurde eine C#-Klasse aus der MSDN nach VB6 portiert.
StringPermutations

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

keine

Download:

Download des Beispielprojektes [5,81 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "BtnStart"
' Steuerelement: Textfeld "Text1"
Option Explicit
Private mConsoleStrBuffer As String
Private mCharLen As Long

Private Sub BtnStart_Click()
    Dim atoms() As String
    Dim Order As Long
    Dim j As Long
    Dim p As StringPerm
    Dim i As Long
    
    Call Console_WriteLine(vbCrLf & "Begin string permutations demo" & vbCrLf)
    atoms = New_StringArr("Ant", "Bat", "Cow", "Dog", "Elk", "Fox")
    Call Console_WriteLine("The initial strings (atoms) are: ")
    
    For j = 0 To UBound(atoms)
        Call Console_WriteLine(atoms(j) & " ")
    Next
    
    Order = UBound(atoms) + 1
    Call Console_WriteLine(vbCrLf & "The order is " & CStr(Order))
    Call Console_WriteLine("There will be " & CStr(Order) & "! = " & _
                           ModStringPerm.FactorialLookup(Order) & _
                           " pemutation elements")
      
    If Not ModStringPerm.IsValid(atoms) Then _
        MsgBox "Invalid initial array"
    
    Set p = New_StringPerm(atoms)
  
    
    Call Console_WriteLine("In lexicographical order, all permutations are: " & vbCrLf)
    
    Do While Not p Is Nothing
        Call Console_WriteLine("[" & CStr(i) & IIf(i < 10, " ", "") & "] " & p.ToString)
        Set p = p.Successor
        i = i + 1
    Loop
    
    Call Console_WriteLine(vbCrLf & "Just element [142] computed directly is:")
    Set p = New_StringPerm(atoms, 142)
    
    Call Console_WriteLine("     " & p.ToString())
  
    Call Console_WriteLine(vbCrLf & "End demo")
End Sub

Private Sub Console_WriteLine(ByVal aText As String)
  Text1.Visible = False
  aText = aText & vbCrLf
  If Len(mConsoleStrBuffer) = 0 Then
      mConsoleStrBuffer = String$(30000, vbNullChar)
      Text1.Text = mConsoleStrBuffer
  End If
  
  If mCharLen < Len(mConsoleStrBuffer) Then
    Mid$(mConsoleStrBuffer, mCharLen + 1) = aText
    
    mCharLen = mCharLen + Len(aText)
  End If
  
  Text1.Text = mConsoleStrBuffer
  Text1.Visible = True
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'----- Anfang Klasse "StringPerm" alias StringPerm.cls  -----
Option Explicit
Private mElement() As String
Private mOrder As Long

'create a StringPerm object which is the 0th (identity) element
'Optional k: create a StringPerm object which is the kth element
Public Sub NewC(atoms() As String, Optional ByVal k As Long = -1)
  mElement = atoms
  mOrder = UBound(mElement) - LBound(atoms) + 1
  
  If k >= 0 Then
    ReDim factoradic(mOrder - 1) As Long
    Dim i As Long, j As Long
    
    ' Step #1 - Find factoradic of k
    For j = 1 To mOrder
        factoradic(mOrder - j) = k Mod j
        k = k / j
    Next

    ' Step #2 - Convert factoradic() to numeric permuatation in perm()
    ReDim temp(mOrder - 1) As Long
    ReDim perm(mOrder - 1) As Long

    For i = 0 To mOrder - 1
        temp(i) = factoradic(i) + 1
    Next

    perm(mOrder - 1) = 1 ' right-most value is set to 1.

    For i = mOrder - 2 To 0 Step -1
        perm(i) = temp(i)
        For j = i + 1 To mOrder - 1
            If (perm(j) >= perm(i)) Then perm(j) = perm(j) + 1
        Next
    Next

    For i = 0 To mOrder - 1 ' put in 0-based form
        perm(i) = perm(i) - 1
    Next
    ' Step #3 - map numeric permutation to string permutation
    For i = 0 To mOrder - 1
        mElement(i) = atoms(perm(i))
    Next
  End If
End Sub

Public Property Get Element(Index As Long) As String
  Element = mElement(Index)
End Property

Public Property Let Element(Index As Long, RHS As String)
  mElement(Index) = RHS
End Property

Public Property Get Order() As Long
  Order = mOrder
End Property

Public Property Let Order(RHS As Long)
  mOrder = RHS
End Property

Public Function ToString() As String
    Dim result As String: result = "{ "
    Dim i As Long
    
    For i = 0 To mOrder - 1
        result = result & mElement(i) & " "
    Next
    
    result = result & "}"
    ToString = result
End Function

Public Function Successor() As StringPerm ' assumes no duplicate atoms
    Dim result As StringPerm: Set result = New_StringPerm(mElement)
    Dim left As Long, right As Long
    Dim temp As String
    Dim i As Long
    Dim j As Long

    left = result.Order - 2 ' Step #1 - Find left value
    Do While (StrComp(result.Element(left), result.Element(left + 1)) > 0) And (left > 0)
        left = left - 1
    Loop
    
    If (left = 0) And (StrComp(mElement(left), mElement(left + 1)) > 0) Then
        Exit Function
    End If
    
    right = result.Order - 1 ' Step #2 - find right; first value > left
    Do While (StrComp(result.Element(left), result.Element(right)) > 0)
        right = right - 1
    Loop

    temp = result.Element(left) ' Step #3 - swap (left) and (right)
    result.Element(left) = result.Element(right)
    result.Element(right) = temp

    i = left + 1 ' Step #4 - reverse order the tail
    j = result.Order - 1

    Do While (i < j)
        temp = result.Element(i)
        result.Element(i) = result.Element(j)
        i = i + 1
        result.Element(j) = temp
        j = j - 1
    Loop

    Set Successor = result
End Function

'------ Ende Klasse "StringPerm" alias StringPerm.cls  ------
'--- Anfang Modul "Modconstructors" alias ModConstructors.bas ---
Option Explicit

Public Function New_StringArr(ParamArray strval()) As String()
  Dim c As Long
  If IsArray(strval) Then c = UBound(strval)
  ReDim s(c) As String
  
  For c = 0 To UBound(s)
    s(c) = strval(c)
  Next
  
  New_StringArr = s
End Function


Public Function New_StringPerm(atoms() As String, _
                               Optional ByVal k As Long = -1) As StringPerm
  Set New_StringPerm = New StringPerm
  Call New_StringPerm.NewC(atoms, k)
End Function
'--- Ende Modul "Modconstructors" alias ModConstructors.bas ---
'--- Anfang Modul "ModStringPerm" alias ModStringPerm.bas ---
Option Explicit

'hier die Static-Prozeduren von StringPerm
Public Function FactorialCompute(n As Long) As Variant
    Dim answer As Variant: answer = CDec(1)
    Dim i As Long
    For i = 1 To n - 1
        answer = Checked(answer * CDec(i))
    Next
    FactorialCompute = answer
End Function

Public Function FactorialLookup(n As Long) As Variant
    If (n < 0 Or n > 20) Then _
        MsgBox "Input argument must be between 0 and 20"
    
    Static answers() As Variant
    answers = Array(1, 1, 2, 6, 24, 120, 720, 5040, 40320, _
                   362880, 3628800, 39916800, 479001600, _
                   6227020800#, 87178291200#, 1307674368000#, _
                   20922789888000#, 355687428096000#, 6.402373705728E+15, _
                   1.21645100408832E+17, 2.43290200817664E+18)

    FactorialLookup = answers(n)
End Function

Public Function FactorialRecursive(n As Long) As Variant

    If (n = 0 Or n = 1) Then
        FactorialRecursive = 1: Exit Function
    Else
        FactorialRecursive = n * FactorialRecursive(n - 1)
    End If

End Function

Public Property Get IsValid(e() As String) As Boolean
    Dim i As Long
    
    If UBound(e) = 0 Then
        IsValid = False: Exit Function
    End If
    
    If UBound(e) < 2 Then
        IsValid = False: Exit Function
    End If
    
    For i = 0 To UBound(e) - 1
        If StrComp(e(i), e(i + 1)) >= 0 Then ' >= means no dups allowed
            IsValid = False: Exit Function
        End If
    Next
    
    IsValid = True
End Property
'---- Ende Modul "ModStringPerm" alias ModStringPerm.bas ----
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.