Zurück zur Homepage

Buchstabenkombinationen #2

 

Unter Punkt 95 wurde eine Mappe vorgestellt, die alle möglichen Kombinationen einer Buchstabenfolge berechnet und ausgibt. Es hat sich aber in der Praxis herausgestellt, dass es eben nicht sehr praxisnah ist, lediglich die Kombinationen auszugeben.

Besser ist es natürlich, wenn schon beim Bilden der Kombinationen nachgeschaut wird, ob die generierte Kombination ein sinnvolles Wort ergibt, und nur dieses sollte auch ausgegeben werden.

Also habe ich mich auf die Suche nach Textdateien gemacht, die als Wörterbuch fungieren können. Nach längerer Suche bin ich auf openoffice gestoßen, die solche Wörterbücher in allen möglichen Sprachen zum Download anbieten.
http://de.openoffice.org/spellcheck/about-spellcheck-detail.html
Man sollte aber die Urheberrechte und die Nutzungsbedingungen beachten, deshalb biete ich diese Dateien auch nicht auf meiner Site zum Download an.

Da ich fälchlicherweise davon ausging, dass für solch ein Unterfangen VBA zu langsam ist, habe ich mit vb.net versucht, das zu realisieren. Bei Wörterbuchdateien mit Größen von bis zu 2 MB hat das auch recht gut geklappt, bei solchen mit knapp 10 MB war das aber zu langsam.

Also habe ich weiter optimiert und beispielsweise eine zweite rekursive Suche mit der gleichen vorherigen Kombination verhindert, was bei doppelt vorkommenden Buchstaben im Wort der Fall ist. Außerdem wurde schon bei einer Kombination von vier Buchstaben nachgeschaut, ob diese bereits im Wörterbuch enthalten ist. Ist dies nicht der Fall, macht auch eine weitere Suche in diesem Zweig keinen Sinn mehr.

Aber auch das war nicht besonders schnell, Multithreading war nun ein weiterer Versuch.
Das hat mich persönlich zwar etwas weitergebracht, die Geschwindigkeit war bei X parallel laufenden Threads aber nicht X-mal so schnell, wie man vielleicht erwarten könnte. Schließlich habe ich es doch noch einmal mit Excel-VBA versucht und siehe, der Code war schneller als die VB.Net Exe. Beide Codes sind nachfolgend zu finden

Hier der vb.net Code Beispielprojekt Multi.zip (122 KB):

 

Imports System.Threading

'++++++++++++++++++++++++++++++++++++++++++++++++
'++ Oberfläche zur Suche von sinnvollen Worten ++
'++ aus einer Buchstabenfolge                  ++
'++ Michael Schwimmer, April 2006              ++
'++++++++++++++++++++++++++++++++++++++++++++++++
'++ 1 Label mit Namen       : lblVergleiche    ++
'++ 1 Label mit Namen       : lblGesamt        ++
'++ 1 Progressbar mit Namen : prbFortschritt   ++
'++ 1 Listbox mit Namen     : lsbErgebnis      ++
'++ 1 Button mit Namen      : cmdDic           ++
'++ 1 Button mit Namen      : cmdSearch        ++
'++ 1 Button mit Namen      : cmdStop          ++
'++ 1 OpenFileDialog        : dlgFileOpen      ++
'++++++++++++++++++++++++++++++++++++++++++++++++

Public Class frmKombi

    
' Update Listbox vom fremden Thread aus über die
    
' Prozedur Listbox_Update möglich machen
    
Private UpdateListbox As New MethodInvoker(AddressOf Listbox_Update)

    
' Update Label vom fremden Thread aus über die
    
' Prozedur Label_Update möglich machen
    
Private UpdateLabel As New MethodInvoker(AddressOf Label_Update)

    
' ThreadArray
    
Private mthThread(0) As Threading.Thread

    
'Array Klasse clsMulti
    
Private mclsThread(0) As clsMulti

    
Private mcolErgebnis As Collection
    
Private mlngVergleiche As Long
    
Private mlngGesamt As Long
    
Private mstrGefunden As String
    
Private mstrDic As String
    
Private mstrWort As String
    
Private mdteBeginn As Date
    
Private mdteEnde As Date


    
Private Sub cmdDic_Click( _
        
ByVal sender As System.Object, ByVal As System.EventArgs _
        ) 
Handles cmdDic.Click
        
' Dictionary auswählen und in die Variable mstrDic laden.
        
' Vorher noch in Kleinschreibung umwandeln.

        
' Gute Wörterbücher beispielsweise unter 
        
' http://de.openoffice.org/spellcheck/about-spellcheck-detail.html
        
' Benutzungshinweise und Rechte der Urheber bitte beachten!

        dlgFileOpen.ShowDialog()
        
If dlgFileOpen.FileName <> "" Then
            txtDic.Text = dlgFileOpen.FileName
            mstrDic = System.IO.File.OpenText(txtDic.Text).ReadToEnd.ToLower
        
Else
            mstrDic = 
""
            txtDic.Text = 
""
        
End If

    
End Sub

    
Private Sub cmdSearch_Click( _
        
ByVal sender As System.Object, ByVal As System.EventArgs _
        ) 
Handles cmdSearch.Click
        
' Suche nach Wort starten

        
Dim As Integer
        
Dim intLänge As Integer

        
If mstrDic.Length = 0 Then Exit Sub

        
' Buchstabenfolge in Variable als Kleinschreibung
        mstrWort = txtWort.Text.ToLower
        intLänge = mstrWort.Length
        
If intLänge = 0 Then Exit Sub

        
' Zeitpunkt des Beginns der Suche
        mdteBeginn = Now()

        
' Variablen zurücksetzen
        mcolErgebnis = 
New Collection
        mlngVergleiche = 0
        mlngGesamt = Fakultät(intLänge)

        
' Sichtbare Steuerelemente zurücksetzen
        lsbErgebnis.Items.Clear()
        lblVergleiche.Text = 
""
        prbFortschritt.Maximum = 
CInt(mlngGesamt)
        lblGesamt.Text = mlngGesamt.ToString

        
' Arrays an die Wortlänge anpassen
        
ReDim mthThread(intLänge - 1)
        
ReDim mclsThread(intLänge - 1)

        
For i = 0 To mthThread.GetUpperBound(0)
            
' Für jeden Buchstaben eine Klasse anlegen
            
' und Startwerte übergeben
            mclsThread(i) = 
New clsMulti
            mclsThread(i).mintThread = i
            mclsThread(i).mstrWort = mstrWort
            mclsThread(i).mstrDic = mstrDic
            mclsThread(i).mcolErg = mcolErgebnis

            
' Ereignisse der Klasse bekannt machen
            
AddHandler mclsThread(i).Gefunden, AddressOf WortGefunden
            
AddHandler mclsThread(i).Vergleiche, AddressOf Vergleiche

            
' Für jeden Buchstaben einen Thread anlegen
            
' und Starten
            mthThread(i) = 
New Threading.Thread(AddressOf mclsThread(i).Kombiniere)
            mthThread(i).Start()
        
Next

    
End Sub

    
Private Sub cmdStop_Click( _
        
ByVal sender As System.Object, ByVal As System.EventArgs _
        ) 
Handles cmdStop.Click
        
' Suche stoppen

        Stoppen()
    
End Sub

    
Private Sub WortGefunden(ByVal sender As ObjectByVal As String)
        
' Ereignis Wort gefunden. Wort wird als e übergeben

        
' Listbox für die Dauer der Aktualisierung sperren
        SyncLock lsbErgebnis
            mstrGefunden = e
            
' Über Threadgrenzen gehen
            lsbErgebnis.Invoke(UpdateListbox)
        
End SyncLock

    
End Sub
    
Private Sub Listbox_Update()
        lsbErgebnis.Items.Add(mstrGefunden)
    
End Sub

    
Private Sub Vergleiche(ByVal sender As ObjectByVal As Long)
        
' Ereignis Vergleichszähler erhöhen. Wert wird als e übergeben

        mlngVergleiche += e

        
' Label für die Dauer der Aktualisierung sperren
        SyncLock lblVergleiche
            
' Über Threadgrenzen gehen
            lblVergleiche.Invoke(UpdateLabel)
        
End SyncLock

    
End Sub
    
Private Sub Label_Update()

        
' Fortschritt ausgeben
        lblVergleiche.Text = mlngVergleiche.ToString
        prbFortschritt.Value = 
CInt(mlngVergleiche)
        
If mlngGesamt = mlngVergleiche Then
            Stoppen()
        
End If

        
' Bisherige Zeitdauer ausgeben
        mdteEnde = Now()
        lblZeit.Text = Format(Date.FromOADate(mdteEnde.ToOADate - mdteBeginn.ToOADate), 
"T")

        
' Ereignisse abarbeiten und Oberfläche aktualisieren
        Application.DoEvents()

    
End Sub
    
Private Function Fakultät(ByVal As LongAs Long
        
' Berechnung der Fakultät

        
Dim As Long
        
Dim As Long = 1

        
For i = 1 To n
            k = k * i
        
Next
        
Return k

    
End Function

    
Private Sub Stoppen()
        
' Prozesse stoppen, Klassen entladen

        
Dim As Integer
        
For i = 0 To mthThread.GetUpperBound(0)
            mthThread(i).Abort()
            mclsThread(i) = 
Nothing
        
Next

    
End Sub
End Class

 

 


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ Klasse zur Suche von sinnvollen                         ++
'++ Worten aus einer Buchstabenfolge                        ++
'++ Michael Schwimmer, April 2006                           ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++       Öffentliche Variablen als Eigenschaften           ++
'++                                                         ++
'++ mcolErg, Collection. :Doppelte Ergebnisse verhindern    ++
'++ mstrDic, String      :Text der Wörterbuchs              ++
'++ mintThread, Integer  :Threadnr. (Nummer des 1. Buchst.) ++
'++ mstrWort, String     :Ausgangsbuchstabenfolge           ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++                 Öffentliche Methoden                    ++
'++                                                         ++
'++ Kombiniere  : Einsprungspunkt neuer Thread              ++
'++ New         : Initialisierung der Klasse                ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++                Öffentliche Ereignisse                   ++
'++                                                         ++
'++ Gefunden    : Gibt das gefundene Wort zurück            ++
'++ Vergleiche  : Gibt probierte Kombinationen  zurück      ++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'


Public Class clsMulti

    
' Öffentliche Eigenschaften der Klasse
    
Public mcolErg As Collection
    
Public mstrDic As String
    
Public mintThread As Integer
    
Public mstrWort As String


    
Private mlngZähler As Long
    
Private malngFakultät(12) As Long

    
' Ein Ereignis, dass über die Anzahl gefundener Worte informiert.
    
Public Event Gefunden(ByVal sender As ObjectByVal As String)

    
' Ein Ereignis, dass über die Anzahl bisheriger Vergleiche informiert.
    
Public Event Vergleiche(ByVal sender As ObjectByVal As Long)

    
Public Sub Kombiniere()
        
' Arbeitstier, um alle möglichen Kombinationen
        
' durchzuprobieren

        
Dim strWort As String

        strWort = mstrWort.Substring(mintThread, 1)

        
' Überprüfen, ob gleicher Anfangsbuchstabe schon
        
' einmal benutzt wurde, wenn ja, beenden
        
If InStr(mstrWort, strWort) < mintThread Then

            
' Eingesparte Kombinationen berechnen und ausgeben
            mlngZähler = malngFakultät(mstrWort.Length - 1)
            
RaiseEvent Vergleiche(Me, mlngZähler)

            
' Thread verlassen
            
Exit Sub

        
End If

        
' Buchstaben nach Threadnummer auswählen und an den Anfang stellen
        
If strWort.Length > 0 Then
            strWort = strWort & mstrWort.Substring(0, mintThread)
        
End If
        
If mintThread < strWort.Length Then
            strWort = strWort & mstrWort.Substring(mintThread + 1)
        
End If

        
' Alle Kombinationen mit dem ausgewählten Anfangsbuchstaben
        
' überprüfen
        Kombi(strWort, 1)

        
' Restliche Anzahl abgearbeiteter Kombinationen ausgeben
        
RaiseEvent Vergleiche(Me, mlngZähler)
    
End Sub
    
Private Function Kombi(ByVal strText As StringByVal intPos As IntegerAs Boolean
        
Dim strDummy As String
        
Dim strAct As String
        
Dim strLeft As String
        
Dim strRight As String
        
Dim strRest As String
        
Dim strBefore As String
        
Dim As Integer
        
Dim As Integer
        
Dim As Integer
        
Dim As Collection
        
On Error Resume Next

        
' Wenn die letzte Rekursionsebene erreicht ist,
        
If intPos = strText.Length - 1 Then

            mlngZähler += 1 
' abgearbeitete Kombinationen

            
If (mlngZähler Mod 50) = 0 Then
                
' Ausgabe abgearbeiteter Kombinationen
                
RaiseEvent Vergleiche(Me, mlngZähler)
                mlngZähler = 0
            
End If

            
' überprüfen, ob das Wort in der Wortliste
            
' vorhanden ist            
            
If InStr(mstrDic, strText) > 0 Then

                Err.Clear() 
' Fehlerspeicher zurücksetzen 

                
' Doppelte Kombinationen vermeiden
                
' Kommt vor, wenn zwei gleiche Buchstaben
                
' vorkommen. Wort dazu zur Collection
                
' hinzufügen
                SyncLock mcolErg
                    mcolErg.Add(strText, strText)
                
End SyncLock

                
If Err.Number = 0 Then
                    
' Nur, wenn kein Fehler beim Hinzufügen zur
                    
' Collektion aufgetreten ist, ist der Wert
                    
' einmalig
                    
RaiseEvent Gefunden(Me, strText)
                
End If ' Err.Number

            
End If

            
Exit Function
        
Else
            
' Optimieren bei bestimmter Wortgröße
            
If intPos > 2 Then ' Wortlängentest

                
' Zeichenfolge extrahieren, die in der
                
' Wortliste gesucht wird
                strBefore = strText.Substring(0, intPos)

                
' Überprüfen, ob Zeichenfolge in Wortliste
                
If InStr(mstrDic, strBefore) = 0 Then ' In Wortliste

                    
' Zeichenfolge ist nicht in Wortliste
                    
' Zweig verlassen, da nachfolgende Buchstaben
                    
' keinen Treffer mehr ergeben können

                    
' Ausgabe eingesparter Kombinationen
                    mlngZähler += malngFakultät(strText.Length - strBefore.Length)
                    
RaiseEvent Vergleiche(Me, mlngZähler)
                    mlngZähler = 0

                    
Exit Function

                
End If ' In Wortliste

            
End If ' Wortlängentest

        
End If

        
' Zeichenfolge vom vorherigem Aufruf ermitteln
        strBefore = strText.Substring(0, intPos)

        
' restliche Buchstaben extrahieren
        strDummy = strText.Substring(intPos)

        x = 
New Collection
        k = strDummy.Length
        
For i = 0 To k - 1

            
' Die verbleibenden Buchstaben nacheinander
            
' an die erste Position der Verbleibenden setzen
            strLeft = 
"" : strRight = ""
            strAct = strDummy.Substring(i, 1)
            
If i > 0 Then strLeft = strDummy.Substring(0, i)
            
If i < k Then strRight = strDummy.Substring(i + 1)

            
' Zeichenkette neu zusammensetzen 
            strRest = strAct & strLeft & strRight

            
' Überprüfen, ob erster Buchstabe schon einmal
            
' abgearbeitet wurde
            Err.Clear()
            x.Add(strAct, strAct)

            
If Err.Number = 0 Then

                
' diese Funktion rekursiv aufrufen, vorher aber
                
' Positionszähler um 1 erhöhen
                Kombi(strBefore & strRest, intPos + 1)

            
Else

                
' Ausgabe eingesparter Kombinationen
                mlngZähler += malngFakultät(strRest.Length - 1)
                
RaiseEvent Vergleiche(Me, mlngZähler)
                mlngZähler = 0

            
End If


        
Next
    
End Function
    
Private Function Fakultät(ByVal As LongAs Long
        
' Berechnung der Fakultät

        
Dim As Long
        
Dim As Long = 1

        
For i = 1 To n
            k = k * i
        
Next
        
Return k

    
End Function

    
Public Sub New()
        
' Neue Klasse, Initialisierung

        
Dim As Integer

        
For i = 0 To malngFakultät.GetUpperBound(0)
            
' Array mit Fakultätwerten anlegen
            malngFakultät(i) = Fakultät(i)
        
Next

    
End Sub
End Class

 

Nachfolgend der Code einer Userform in Excel Beispieldatei Excel( Buchstabenkombi2.zip 15 kB)  

Option Explicit
Private mcolErg            As Collection
Private mstrDic            As String
Private mstrWort           As String
Private mlngZähler         As Long
Private mblnAbbrechen      As Boolean
Private malngFakultät(12)  As Long
Private mdteNow            As Date

Private Function Kombi(ByVal strText As StringByVal intPos As LongAs Boolean
Dim strDummy As String
Dim strAct As String
Dim strLeft As String
Dim strRight As String
Dim strRest As String
Dim strBefore As String
Dim As Long
Dim As Long
Dim As Long
Dim As Collection
On Error Resume Next

' Wenn die letzte Rekursionsebene erreicht ist,
If intPos = Len(strText) Then
   mlngZähler = mlngZähler + 1
   lblZeit.Caption = Format(Now - mdteNow, 
"hh:mm:ss")
   lblAct.Caption = mlngZähler
   DoEvents
   
   
If mblnAbbrechen = True Then
      Kombi = 
True
      
Exit Function
   
End If
   
   
' überprüfen, ob das Wort in der Wortliste
   
' vorhanden ist
   
If InStr(mstrDic, strText) > 0 Then

      Err.Clear 
' Fehlerspeicher zurücksetzen

      
' Doppelte Kombinationen vermeiden
      
' Kommt vor, wenn zwei gleiche Buchstaben
      
' vorkommen. Wort dazu zur Collection
      
' hinzufügen
       mcolErg.Add strText, strText

      
If Err.Number = 0 Then
         lsbErgebnis.AddItem strText
         DoEvents
      
End If

   
End If
   
Exit Function
Else
   
' Optimieren bei bestimmter Wortgröße
   
If intPos > 3 Then ' Wortlängentest

      
' Zeichenfolge extrahieren, die in der
      
' Wortliste gesucht wird
      strBefore = Left(strText, intPos)

      
' Überprüfen, ob Zeichenfolge in Wortliste
      
If InStr(mstrDic, strBefore) = 0 Then

         
' Zeichenfolge ist nicht in Wortliste
         
' Zweig verlassen, da nachfolgende Buchstaben
         
' keinen Treffer mehr ergeben können

         
' Ausgabe eingesparter Kombinationen
         mlngZähler = mlngZähler + malngFakultät(Len(strText) - Len(strBefore))
         lblAct.Caption = mlngZähler
         DoEvents
         
Exit Function

      
End If ' In Wortliste

   
End If ' Wortlängentest

End If

' Zeichenfolge vom vorherigem Aufruf ermitteln
strBefore = Left(strText, intPos)

' restliche Buchstaben extrahieren
strDummy = Mid(strText, intPos + 1)

Set x = New Collection
k = Len(strDummy)
For i = 1 To k

   
' Die verbleibenden Buchstaben nacheinander
   
' an die erste Position der Verbleibenden setzen
   strLeft = 
"": strRight = ""
   strAct = Mid(strDummy, i, 1)
   
If i > 1 Then strLeft = Left(strDummy, i - 1)
   
If i < k Then strRight = Mid(strDummy, i + 1)

   
' Zeichenkette neu zusammensetzen
   strRest = strAct & strLeft & strRight

   
' Überprüfen, ob erster Buchstabe schon einmal
   
' abgearbeitet wurde
   Err.Clear
   x.Add strAct, strAct

   
If Err.Number = 0 Then

      
' diese Funktion rekursiv aufrufen, vorher aber
      
' Positionszähler um 1 erhöhen
      
If Kombi(strBefore & strRest, intPos + 1) = True Then
         Kombi = 
True
         
Exit Function
      
End If

   
Else

      
' Zählen eingesparter Kombinationen
      mlngZähler = mlngZähler + malngFakultät(Len(strRest) - 1)
      lblAct.Caption = mlngZähler
      lblZeit.Caption = Format(Now - mdteNow, 
"hh:mm:ss")
      DoEvents
   
End If


Next ' i
End Function



Private Sub cmdDic_Click()
Dim varDic  As Variant
Dim ff      As Long
varDic = Application.GetOpenFilename(
"Text Files (*.txt;*.dic), *.txt;*.dic")
If varDic = False Then Exit Sub
ff = FreeFile
txtDic.Text = varDic
Open varDic For Binary As ff
  mstrDic = String(LOF(ff), 0)
  
Get ff, , mstrDic
  mstrDic = LCase(mstrDic)
Close
End Sub

Private Sub cmdStart_Click()
   mstrWort = LCase(txtWort.Text)
   
If Len(mstrDic) = 0 Then Exit Sub
   
If Len(mstrWort) = 0 Then Exit Sub
   lblVon.Caption = malngFakultät(Len(mstrWort))
   lblAct.Caption = 
"0"
   mlngZähler = 0
   mblnAbbrechen = 
False
   lsbErgebnis.Clear
   
Set mcolErg = New Collection
   mdteNow = Now
   lblZeit.Caption = 
"00:00:00"
   Kombi mstrWort, 0
   lblAct.Caption = mlngZähler
End Sub

Private Sub cmdStop_Click()
   mblnAbbrechen = 
True
End Sub

Private Sub UserForm_Initialize()
Dim As Long
   
For i = 1 To UBound(malngFakultät)
      
' Array mit Fakultätwerten anlegen
      malngFakultät(i) = Fakultät(i)
   
Next

End Sub
Private Function Fakultät(ByVal As LongAs Long
' Berechnung der Fakultät
Dim As Long
Dim As Long
   k = 1
   
For i = 1 To n
       k = k * i
   
Next
   Fakultät = k

End Function