Algún ejemplo de combinatoria

[Bazooka]

Hola necesito una rutina si alguien tiene que me permita extraer todas las combinaciones posibles de una cadena de numeros pasados como parametros :
yo encontre esta pero es si bien hace lo que quiero es ineficiente por que solo trabaja con  numeros chicos:

Código: (vb) [Seleccionar]

Option Explicit
Dim strRet() As String

Private Sub GetPermutation(ItemToPermeate As String, Optional RecursivePlaceHolder As String = "")
Dim i As Integer
Static intArr As Integer
Dim strWorkingChr As String
Dim strPlaceHolder As String
Dim strString As String

    If Len(ItemToPermeate) Then   'Loop while you have something to work with
   
        'work through each character in the string
        For i = 1 To Len(ItemToPermeate)
            strWorkingChr = Left(ItemToPermeate, i - 1)
            strPlaceHolder = Mid(ItemToPermeate, i, 1)
            strString = Mid(ItemToPermeate, i + 1)
           
            'Get all the permutations for the string
            Call GetPermutation(strWorkingChr & strString, RecursivePlaceHolder & strPlaceHolder)
        Next i
    Else
        ReDim Preserve strRet(intArr)
        strRet(intArr) = RecursivePlaceHolder
        intArr = intArr + 1
    End If

End Sub

Private Sub Command1_Click()
Dim i As Integer
   
    GetPermutation "12345"
   
    For i = 0 To UBound(strRet)
       Debug.Print strRet(i)
    Next i
    MsgBox "Numero de permutacion " & UBound(strRet) + 1
End Sub
Alguien tiene algo mejor o mas escalable?


ME acabo de dar cuenta que esta no me sirve por que por ejemplo me devuelve combinaciones ordenadas distintos pero con los mismos numeros  ej. 12345, 12354, 12543 y no es  lo que busco...

Gracias

[Psyke1]

Al menos así funcionará mejor, creo:

Código: (vb) [Seleccionar]

Option Explicit
Private strRet()        As String

Private Sub GetPermutation(ByRef strItem As String, Optional ByVal RecursivePlaceHolder As String)
Static lngArr                                                   As Long
Dim strWorkingChr                                               As String
Dim strPlaceHolder                                              As String
Dim strString                                                   As String
Dim lngLen                                                      As Long
Dim Q                                                           As Long
   
    lngLen = LenB(strItem) \ 2
    If lngLen Then
        For Q = 1 To lngLen
            strWorkingChr = Left$(strItem, Q - 1)
            strPlaceHolder = Mid$(strItem, Q, 1)
            strString = Mid$(strItem, Q + 1)
            GetPermutation (strWorkingChr & strString), (RecursivePlaceHolder & strPlaceHolder)
        Next Q
    Else
        ReDim Preserve strRet(lngArr)
        strRet(lngArr) = RecursivePlaceHolder
        lngArr = lngArr + 1
    End If
End Sub

Private Sub Command1_Click()
Dim Q               As Long
Dim lngLimit        As Long

    GetPermutation "12786987"

    lngLimit = UBound(strRet)
   
    Debug.Print String$(100, "=")
   
    For Q = 0 To lngLimit
       Debug.Print strRet(Q)
    Next
   
    MsgBox "Numero de permutacion " & CStr(lngLimit + 1)
End SubMañana hago una versión mía a ver si puedo ganar un poco de velocidad
Con redim preserve se gasta tieeeeeempo...

DoEvents!

[Psyke1]

Edit:No funciona, ahora no tengo tiempo, pero sería algo así:

Así más rápido:

Código: (vb) [Seleccionar]


Option Explicit
Private strRet()                                As Long

Private Function GetPermutation(ByVal strText As String, Optional ByRef RecursivePlaceHolder As String) As Boolean
Dim lngLen                                      As Long

    lngLen = LenB(strText) \ 2
    If lngLen > 0 Then
        ReDim strRet(CalcPossibilities(lngLen) - 1)
        GetPerm strText, RecursivePlaceHolder
        GetPermutation = True
    End If
End Function

Private Function CalcPossibilities(ByVal lngNumber As Long) As Long
Dim Q                                           As Long

    CalcPossibilities = lngNumber
    lngNumber = lngNumber - 1
   
    For Q = lngNumber To 2 Step -1
        CalcPossibilities = CalcPossibilities * Q
    Next
End Function

Private Sub GetPerm(ByRef strItem As String, Optional ByRef RecursivePlaceHolder As String)
Static lngPos                                   As Long
Dim strWorkingChr                               As String
Dim strPlaceHolder                              As String
Dim strString                                   As String
Dim lngLen                                      As Long
Dim Q                                           As Long
   
    lngLen = LenB(strItem) \ 2
    If lngLen Then
        For Q = 1 To lngLen
            strWorkingChr = Left$(strItem, Q - 1)
            strPlaceHolder = Mid$(strItem, Q, 1)
            strString = Mid$(strItem, Q + 1)
            GetPerm (strWorkingChr & strString), (RecursivePlaceHolder & strPlaceHolder)
        Next Q
    Else
        strRet(lngPos) = CStr(RecursivePlaceHolder)
        lngPos = lngPos + 1
    End If
End Sub

Private Sub Command1_Click()
Dim Q                                           As Long
Dim lngLimit                                    As Long

    If GetPermutation("1274") Then
        Debug.Print String$(100, "=")

        lngLimit = UBound(strRet)
        For Q = 0 To lngLimit
           Debug.Print strRet(Q)
        Next
       
        MsgBox "Numero de permutacion " & CStr(lngLimit + 1)
    End If
End Sub
[code]

DoEvents! :P

[raul338]

Creo que hacer anagramas no te sirve (porque te da todas las combinaciones posibles al mas estilo BruteForce)  que creo que es lo que hace la primera conbinacion.

Creo que deberias dar mas ejemplos, o al menos ciertas "reglas" para hacer las combinaciones

Código: (vb) [Seleccionar]

Option Explicit
Private Function CalcPossibilities(ByVal lngNumber As Long) As Long
Dim Q                                           As Long

    CalcPossibilities = lngNumber
    lngNumber = lngNumber - 1
   
    For Q = lngNumber To 2 Step -1
        CalcPossibilities = CalcPossibilities * Q
    Next
End Function


Lo que haces ahi es calcular el factorial, y funciona solo para números chicos (si no me equivoco no puedes llegar a 20 sin explotar ._.)

[Bazooka]

Si Raul tenes razon los probe con 123456789 y se quedo procesando un monton de tiempo y me genero algo asi como 320.880 combinaciones.

Perdon pero no entiendo lo de anagramas!

[Psyke1]

No creo que te salga MIKE. Vas a tener muuuuchas posibilidades por abarcar y seguramente no te compense el premio con todos los cartones que quieres comprar.
Suerte!

DoEvents!

[Bazooka]

Te agradezco tu gentileza en colaborar con mi pedido . Pero no me parece que me entendiste mal!
Solo compre un carton y ni pienso comprar más!! Lo otro es solo que estoy emperrado en dilucidar como es el sistema de clave perfecta que utilizan esos bingos.

Ssluditos!!

[cococh]

mira mike la clave que usa san vicente se llaman claves perfectas y son computadas, de la unica manera que exciste un ganador es que la computadora pare el sorteo cuando hay un ganador, ademas esas calves se elige al azar x cantidad de numero y con esos se juegan, yo la llamaria secuencia de numeros, es mas fijate que en tu carton te faltan decenas, no juegan las 99 bolillas aunque esten en el bolillero, y ademas es muy fasil para el fraude, como sabes vos si es real que el ganador que ellos dicen es el verdadero, si te muestran una hoja que sacan en el monento de la pc.

[BlackZeroX]

.
espero no llegar tarde con lo de las permutaciones

Código: (Vb) [Seleccionar]


Option Explicit

Private Sub Priv_GetPermutaciones(ByRef vData As String, ByRef ArrOuput() As String, ByRef lng_pos As Double, Optional ByRef strFixed As String)
Dim int_t        As Integer
    If Len(vData) <> 1 Then
        For int_t = 1 To Len(vData)
            Priv_GetPermutaciones Left$(vData, int_t - 1) & Mid$(vData, int_t + 1), ArrOuput(), lng_pos, strFixed & Mid$(vData, int_t, 1)
        Next int_t
    Else
        ArrOuput(lng_pos) = strFixed & vData
        lng_pos = lng_pos + 1
    End If
End Sub

Public Function GetPermutaciones(ByRef vData As String, ByRef ArrOuput() As String) As Long
Dim lng_i           As Long
Dim lng_buff        As Double
    lng_buff = 1
    For lng_i = 1 To Len(vData)
        lng_buff = lng_buff * lng_i
    Next lng_i
    ReDim ArrOuput(0 To lng_buff - 1)
    Call Priv_GetPermutaciones(vData, ArrOuput(), 0)
    GetPermutaciones = lng_buff
End Function

Private Sub Form_Load()
Dim str_Arr()   As String
Dim lng_i       As Long
    For lng_i = 0 To GetPermutaciones("BlackZeroX", str_Arr()) - 1
        Debug.Print str_Arr(lng_i)
    Next lng_i
End Sub


Temibles Lunas!¡.

[fernandos85al@hotmail.com]

Hola felicitaciones y gracias por compartir  en el foro BlackZeroX !! Me he tomado el atrevimiento de modificar un poco, y pude hacer un programita para conseguir las claves de redes wifi, wep, wpa personal, etc..


es uno de los tantos usos que le di..


saludos

[wolf_kof]

Ala gra...... Pasate el proyecto  Serviria de mucho.... Se te agradeceria....

[ssccaann43]

Podrias compartir Fernando

[YAcosta]

Hola felicitaciones y gracias por compartir  en el foro BlackZeroX !! Me he tomado el atrevimiento de modificar un poco, y pude hacer un programita para conseguir las claves de redes wifi, wep, wpa personal, etc..


es uno de los tantos usos que le di..

saludos

Te vas a volver grande!!! solo tienes que pasar el codigo jejeje.

[Bazooka]

Creo que este tema rumbeó para otro lado!!!

Saluditos!!

[YAcosta]

Creo que este tema rumbeó para otro lado!!!

Saluditos!!

jajajjaja cierto!