Chercheur de permutations

Télécharger le projet
Commenter

Description

Ce code cherche les permutations d'une chaîne.
Il recherche en fait toutes les chaines que l'on peut paire a partir d'une chaine (je ne suis pas sûr d'être clair, regardez l'exemple ;) )
Ex.: "pour "abc", il retourne "abc", "acb", "bac", "bca", "cab", "cba"

J'ai mis le code de la classe qui fait ca, et dans le zip y a le prog de démo...

Source / Exemple : 


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' clsPermutaion
'' Written by : Christophe POLLET
''
'' Modifications :
''  - 25. jun. 2002 by Christophe POLLET : Starting developpement
''
'' Description :
'' Searches for the permutations of some letters
''
'' Copyright : Christophe POLLET
''
'' Contact :
''  - Christophe POLLET : <seyev@infomaniak.ch>
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLICS DATAS

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PRIVATES DATAS
Private gcLetters As New Collection         ' The letters
Private gsWords() As String                 ' The words
Private gsTempWords() As String             '
Private gsSeparator As String               ' The separator
Private gdNumberOfPermutations As Double    '
Private gcListBox As ListBox                '
Private gcTextBox As TextBox                '
Private gbUseListBox As Boolean             '
Private gbUseTextBox As Boolean             '
Private gbFound As Boolean                  '

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLICS EVENTS
Public Event NewPermutation(dCurrentNumber As Double)
Public Event NewPrint(dCurrentNumber As Double)
Public Event SearchDone()
Public Event PrintDone()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLIC PROPERTIES
Public Property Let Letters(ByVal sLetters As String)
    Dim sLettersArray() As String
    Dim N As Integer
    
    sLettersArray = Split(sLetters, gsSeparator, -1, vbTextCompare)
    
    For N = gcLetters.Count To 1 Step -1
        gcLetters.Remove (N)
    Next N
    For N = 0 To UBound(sLettersArray)
        Call gcLetters.Add(sLettersArray(N))
    Next N
    gdNumberOfPermutations = GetNumberOfPermutations(gcLetters.Count)
    gbFound = False
End Property

Public Property Get Letters() As String
    Dim sLettersArray() As String
    Dim N As Integer
    
    ReDim sLettersArray(gcLetters.Count - 1)
    
    For N = 1 To gcLetters.Count
        sLettersArray(N - 1) = gcLetters.Item(N)
    Next N
    Letters = Join(sLettersArray, gsSeparator)
End Property

Public Property Let Separator(ByVal sSeparator As String)
    If sSeparator <> "" Then
        gsSeparator = sSeparator
    Else
        MsgBox ("clsPermutaion::Separator : cannot use null separator")
    End If
End Property

Public Property Get Separator() As String
    Separator = gsSeparator
End Property

Public Property Let UseListBox(ByRef cListBox As ListBox)
    Set gcListBox = cListBox
    gbUseListBox = True
End Property

Public Property Let UseTextBox(ByRef cTextBox As TextBox)
    Set gcTextBox = cTextBox
    gbUseTextBox = True
End Property

Public Property Get NumberOfLetters() As Long
    NumberOfLetters = gcLetters.Count
End Property

Public Property Get NumberOfPermutations() As Double
    NumberOfPermutations = gdNumberOfPermutations
End Property

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PRIVATES METHODS
Private Sub Class_Initialize()
    gsSeparator = " "
    gbUseListBox = False
    gbUseTextBox = False
    gbFound = False
End Sub

Private Function GetNumberOfPermutations(ByVal lNumberOfLetters As Long) As Double
    Dim Result As Double
    Dim N As Long
        
    If (lNumberOfLetters < 0) Or (lNumberOfLetters > 170) Then
        Call MsgBox("Number too high : " & CStr(lNumberOfLetters), vbCritical + vbOKOnly, "clsPermutation")
        Exit Function
    End If

    Result = 1
    For N = 1 To lNumberOfLetters
        Result = Result * N
    Next
    
    GetNumberOfPermutations = Result
End Function

Private Sub GetPermutations(cLetters As Collection)
    Dim N As Long
    Dim cTempLetters As New Collection
    Dim lCurrent As Long
    
    DoEvents
    
    lCurrent = UBound(gsTempWords)
    
    For N = 1 To cLetters.Count
        Call CopyCollection(cLetters, cTempLetters)
        
        gsTempWords(lCurrent) = gsTempWords(lCurrent - 1) & cTempLetters(N)
        
        cTempLetters.Remove (N)
        If cTempLetters.Count = 0 Then
            gsWords(UBound(gsWords)) = gsTempWords(lCurrent)
            ReDim Preserve gsWords(UBound(gsWords) + 1)
            ReDim Preserve gsTempWords(lCurrent - 1)
            RaiseEvent NewPermutation(CDbl(UBound(gsWords)))
            Exit Sub
        End If
        ReDim Preserve gsTempWords(lCurrent + 1)
        Call GetPermutations(cTempLetters)
    Next N
End Sub

Private Sub CopyCollection(cFrom As Collection, cTo As Collection)
    Dim N As Long
    
    For N = cTo.Count To 1 Step -1
        cTo.Remove (N)
    Next N
    For N = 1 To cFrom.Count
        Call cTo.Add(cFrom.Item(N))
    Next N
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' PUBLICS METHODS
Public Sub printPermutations(ByVal bUseDefaut, _
                            Optional ByVal bUseListBox As Boolean = False, _
                            Optional bUseTextBox As Boolean = False)
    Dim N As Long
    
    If Not gbFound Then
        Call MsgBox("Permutations must be found before calling Permutation::printPermutation", vbOKOnly + vbCritical, "clsPermtuation")
        Exit Sub
    End If
    
    For N = 0 To UBound(gsWords)
        RaiseEvent NewPrint(CDbl(N))
        DoEvents
        If bUseDefaut Then
            If gbUseListBox Then gcListBox.AddItem (gsWords(N))
            If gbUseTextBox Then gcTextBox.Text = gcTextBox.Text & vbCrLf & gsWords(N)
        Else
            If bUseListBox And gbUseListBox Then gcListBox.AddItem (gsWords(N))
            If bUseTextBox And gbUseListBox Then gcTextBox.Text = gcTextBox.Text & vbCrLf & gsWords(N)
        End If
    Next N
    RaiseEvent NewPrint(CDbl(N))
    RaiseEvent PrintDone
End Sub

Public Sub searchPermutations()
    ReDim gsTempWords(1)
    ReDim gsWords(0)
    
    Call GetPermutations(gcLetters)
    
    ReDim Preserve gsWords(UBound(gsWords) - 1)
    ReDim gsTempWords(0)
    
    gbFound = True
    RaiseEvent SearchDone
End Sub

Conclusion :


Voila... Si vous faites des modifs, merci de me tenir au courant à seyev@infomaniak.ch

Encore quelque chose : pour une chaine contenant deux fois la même lettre, le programme renvoie des doublons (pas de contrôles de doublons)

Pour ls prochaines versions : contrôle de doublons
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_seyev)