Die Community zu .NET und Classic VB.

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

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

 von Oliver Meyer

Schwierigkeitsgrad:

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 --------------