Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: obethermy en Marzo 03, 2017, 10:11:12 pm
-
Como hago para que la permuta sin repetir me funcione con mas de 5 y tambien aplicandole mid(x,1,3) se puedo obtener para 3 digitos.
en el formulario con un listbox (LB)
Dim x As Variant
Dim oPermuta As New permuta
oPermuta.Permutar ("1234")
For Each x In oPermuta.getCombinacion
lb.additem x
next
un modulo de clases llamado permuta
Option Explicit
Private oCol As Collection
Sub Permutar(s As String)
Dim i As Integer
Dim s2 As String
Dim sOut As String
Dox s, Len(s), sOut
End Sub
Function getCombinacion() As Collection
Set getCombinacion = oCol
End Function
Private Sub AgregarCombinacion(sNew As String)
' no agrega elementos duplicados
If Not Existe(sNew) Then
oCol.Add sNew, sNew
End If
End Sub
Private Function Existe(sNew As String) As Boolean
Dim x As Variant
Existe = False
For Each x In oCol
If x = sNew Then
Existe = True
Exit For
End If
Next
End Function
Private Sub Dox(ByRef s As String, m As Integer, ByRef sOut As String)
Dim s2 As String, x As Integer
s2 = s
If m > 2 Then
For x = 1 To m
Dox s2, m - 1, sOut
s2 = Desplazar(s2, m)
Next x
Else
AgregarCombinacion s
AgregarCombinacion Desplazar(s2, m)
End If
End Sub
Private Function Desplazar(ByRef s As String, m As Integer) As String
Dim sStg As String
If Len(s) > m Then
sStg = Left(s, Len(s) - m) & Right(s, m - 1) & Mid(s, IIf(m = 2, Len(s), m) - 1, 1)
Else
sStg = Right(s, m - 1) & Left(s, 1)
End If
Desplazar = sStg
End Function
Private Sub Class_Initialize()
Set oCol = New Collection
End Sub
Private Sub Class_Terminate()
Set oCol = Nothing
End Sub
-
Las permutaciones sin repetición se construyen de la siguiente forma:
Dado un alfabeto (ejemplo): "ABCDEF"
0 - Se van tomando los elementos uno a uno: A, B, C, D, E, F . Esto, es un bucle externo... y genera las variaciones monarias.
1 - Cada elemento así formado es un grupo (0-5). Y tras cada elemento, se añade el resto:
AB, AC, AD, AE, AF (es decir estos se añaden al grupo 0, luego serían 01, 02,03,04,05) y serían las variaciones binarias de la primera variación monaria.
2 - De nuevo a cada grupo así formado, se añade de nuevo otro elemento de los que aún no tienen, es decir nos centramos en el grupo 01+x
ABC, ABD, ABE, ABF,
3 - Un nuevo ciclo, añade otra de las letras restante, al grupo 012+x
ABCD, ABCE, ABCF
4 - De nuevo se añade otro ítem al primer grupo: 0123+x
ABCDE, ABCDF
5 - Finalmente cuando solo queda 1 ítem, acaba. Es decir cuando tenemos el tamaño del alfabeto, si es limitado a un tamaño, acaba en algún punto previo.
Añadidmos el elemento que resta: 01234+x (x en este caso solo puede ser 5).
ABCDEF.
Cada línea, si lo miras bien es un bucle, porque solo estamos cogiendo el primer item del grupo que se genera en la etapa anterior.
Para que sea efectivo y no limitado a un tamaño fijo o con un alfabeto concreto, lo acertado es usar recursión, así el código es totalmente válido e independiente y además es mucho más sencillo.
A una clase de permutación, deberías añadir siempre como mínimo, la siguiente funcionalidad:
A - Una propiedad (aunque solo sea de lectura), llamada Alfabeto, y que contempla la cadena de caracteres con la que se trabaja.
private p_Alfabeto() as byte ' fíjate que no lo dejo en una cadena de texto, si no como un array de bytes.
public property get Alfabeto as string
Alfabeto= Strconv(p_alfabeto, VBtounicode)
end property
B - Una propiedad de solo lectura llamada por ejemplo: Tamañoalfabeto/SizeAlfabeto...
private p_Sizealfabeto as byte
public property get SizeAlfabeto as byte
Sizealfabeto = p_sizealfabeto
end property
C - Una propiedad de solo lectura lllamada por ejemplo: NumPermutaciones, y que como su nombre indica entrega el número de permutaciones sin repetición que ofrece dicho alfabeto.
private p_NumPermutaciones as variant
public property get NumPermutaciones as variant
Numpermutaciones = p_NumPermutaciones
end property
D - Una función que precalcule la cantidad de permutaciones sin repetición: En el caso presente, es tan fácil como hacer un bucle:
private sub CalculaNumPermutas
dim x as byte
p_NumPermutas = cdec(p_NumPermutas) ' lo convertimos al tipo Decimal... que maneja números gigantes sin decimales....
p_NumPermutas=1
For x=2 to p_SizeAlfabeto
p_NumPermutas= (p_NumPermutas*x)
next
' ejemplo: ABCDE= 1*2*3*4*5= 120 permutaciones sin repetición
E - Una comprobación que examine el alfabeto y verifique que no hay caracteres repetidos.
Private funcion ValidarAlfabeto(byref Ab() as byte) as boolean
dim k as integer
dim By(0 to 255)
For k= 0 to p_SizeAlfabeto
if by(Ab(k))>0 then exit function
by(Ab(k))= 1
next
ValidarAlfabeto = true
end function
F - Una función que verifique que si el alfabeto es del mismo tamaño que el actual, no recalcule las permutaciones, que tan solo remplace valores. Esto es, si el alfabeto actual es: XYZ, y luego se recibe permutar el alfabeto ABC (o incluso el mismo en desorden ZYX). Es más rápido remplazar en todas las permutaciones X por A; Y por B y Z por C, que volver a calcular de nuevo todas las permutaciones. Esto sin embargo es relativo, como te anoto más adelante (no hay necesidad de almacenar todas las permutaciones posibles)...
Tanto A, como B, C, D, E, F se pueden establecer desde la función pública Permutar, justo antes de iniciar las permutaciones.
public function Permutar(byref Alfabeto as string....)
dim k as long
dim Ab() as byte
k = len(alfabeto)
If (k>0) then
ab= strconv(Alfabeto, vbfromUnicode)
if (ValidarAlfabeto(Ab)= false) then
msgbox "el alfabeto tiene al menos un carácter repetido. Todas sus caracteres deben ser únicos."
exit function
end if
'if (k= p_Sizealfabeto) then
' call RemplazarPermutaciones(Alfabeto)
'else
p_Alfabeto=ab
p_SizeAlfabeto = k
call CalcularNumPermutas
call PermutarAlfabeto
'end if
end if
end function
Otros consejos en el sigiuente apartado...
Inténtalo, a ver si te sale, si pasado unos días sigue sin salirte, coloca el código y te comento/corrijo...
-----------
Respecto de tu código actual, de un vistazo simple resulta muy ineficiente.
De entrada, usar una colección vale si la cantidad de permutaciones es muy limitada. Si no, no interesa almacenar las permutaciones (por ejemplo todas las permutaciones posibles para un alfabeto de 26 caracteres, con palabras de 5 letras tendría: 26^5 permutaciones distintas = 11.881.376, que (12 millones) no son muchas aún, pero si aumentamos las palabras a 8 caracteres por ejemplo, ya se nos va a : 208.827.064.576 (209mil millones), que ya es intolerable, porque además debes multiplicarlo por los bytes que ocupa cada permutación: es decir por 16, si se guardan en unicode (8 caracteres por permutación, por 2 bytes por carácter).
Entonces qué?.
No las guardes, es preferible calcularlas sobre la marcha. Ejemplo:
public enum EstadosDePermutar
ESTADO_PERMUTA_FINAL =-1 ' se llegó a la última secuencia.
ESTADO_PERMUTA_INACTIVO = 0 ' no se ha recibido un alfabeto correcto o está presente, pero no se ha reclamado permutar.
ESTADO_PERMUTA_SIGUIENTE=1 ' se reclama calcular la siguiente secuencia.
ESTADO_PERMUTA_CALCULAR_SECUENCIA =2 ' se reclama calcular la siguiente secuencia que sigue a la recibida.
ESTADO_PERMUTA_INICIO =3 ' se ha reclamado regresar a la primera secuencia (reset).
end enum
private p_Estado as estadosdePermutar
private p_Secuencia as string ' () as byte
public function Permutar(byref Alfabeto as string, optional [b]byref [/b]Estado as EstadosDePermutar) as string
static n as variant
dim p as variant
Select case Estado
case EstadosDePermutar.SIGUIENTE
' calcular la siguiente secuencia tras p_Secuencia.
Permutar= CalcularSiguiente
n= (n +1)
if (n= pNumPermutas) then p_Estado = FINAL
case EstadosDePermutar.FINAL
msgbox "Ya se alcanzó el final de las secuencias, reinicie las secuencias o cambie el alfabeto"
case EstadosDePermutar.CALCULAR_SECUENCIA
p = OrdenDeSecuencia(Alfabeto) ' si algún error devovler -1
if (p >=0) then
p_Secuencia =Alfabeto
Permutar= Permutar("", SIGUIENTE) ' se reinvoca a sí misma
n=(p+1)
else
raiseerror "La secuencia recibida no pertenece a este alfabeto" ' o msgbox...
exit function
end if
case else
if (IniciarAlfabeto(Alfabeto)= True) then ' calcularía la primera secuencia
p_Estado= SIGUIENTE
else
' error con el alfabeto, quizás no fue validado, o su longitud era 0 (una cadena vacía9.
p_Estado= INACTIVO
end if
n=0
end select
Estado = p_Estado
end function
El código está escrito sobre la marcha, así que necesita corrección y claridad...
Por la misma razón, una función de 'Existe' es más que innecesaria, inaceptable... de entrada porque no interesa almacenar las secuencias, luego porque puesto a almacenarlas, si la cantidad es discreta, es preferible usar una tabla hash, para localizarla y no tener que recorrer toda la colección para ver si existe. Más aún, ni siquiera es necesario una tabla hash, para saber si una secuencia dada 'existe' en ese alfabeto, basta verificar que todas las letras de dicha secuencia existen en el alfabeto y que ninguna se repite dos o más veces... si se cumplen esas dos condiciones existe... y por tanto es inecesario buscarla. Y por lo mismo, si insistes en ponerla deberías cambiarle el nombre a la función a: Contiene
Private p_Alfabeto() As Byte
Private p_SizeAlfabeto As Byte
Public Function Contiene(ByRef Secuencia As String) As Boolean
Dim k As Integer
Dim by() As Integer, Sec() As Byte
If (Len(Secuencia) = p_SizeAlfabeto) Then
ReDim by(0 To 255)
Sec = StrConv(Secuencia, vbFromUnicode)
' Asignar la secuencia a una tabla de cuenta.
For k = 0 To p_SizeAlfabeto - 1
by(Sec(k)) = by(Sec(k)) + 1
Next
' verificar que no hay 2 letras repetidas
For k = 0 To 255
If by(k) > 1 Then Exit Function ' si tiene más de 1, implica que está repetido, se concluye que dicha secuencia no está contenida.
Next
' invertir la tabla de cuenta, ahora descontamos.
For k = 0 To p_SizeAlfabeto - 1
by(p_Alfabeto(k)) = by(p_Alfabeto(k)) - 1
Next
' verificar que todas las letras forman parte del alfabeto
For k = 0 To 255
If by(k) <> 0 Then Exit Function ' Si no quedó a 0, implica que un carácter en alfabeto no se encontró en la secuencia.
Next
' si todas las letras de alfabeto actual, pusieron a 0 las de la tabla de cuenta, implica que cad a letra en el alfabeto se corresponde una a una con las de la secuencia. Está contenida...
Contiene = True
End If
End Function
' Probando la función previa....
Private Sub Form_Load()
p_Alfabeto = StrConv("ABCD", vbFromUnicode)
p_SizeAlfabeto = 4
MsgBox Contiene("CDBAZ") ' false ' tiene más letras que lo que señala el alfabeto
MsgBox Contiene("CD") ' false tiene menos letras que lo que señala el alfabeto (si se exige tamaño de palabra=al alfabeto).
MsgBox Contiene("CDDA") ' false hay un carácter repetido, no están todos.
MsgBox Contiene("XDBA") ' false hay un carácter no presente en el alfabeto.
MsgBox Contiene("CDBA") ' true OK: aparecen todos una sola vez y ningún caracter más.
End Sub
Este código es enormemente más eficaz que tu función 'Existe' que reclama recorrer toda una colección para encontrar si existe o no dicha secuencia. En esta función a lo sumo se recorre en un array 256*2 + Sizealfabeto * 2, (poco más que 550 iteraciones de un array , que siempre es más rápido el acceso que a una colección), garantizas si existe o no... de hecho esas iteraciones ( 256*2 + Sizealfabeto * 2) son las necesaria si existe, si no existe serán menos.
Muy lejos de tener que revisar miles, cientos de miles, millones o miles de millones de secuencias almacenadas en una colección, que además siendo texto, la comparación es mucho más lenta. En esta función se opera con un array de integers y 2 arrays de bytes.
Siempre que trates con cadenas de forma intensiva, es preferible usar bytes (un array), ya que será enormemente más veloz.
Y por último, si aún decides usar cadenas (para uso no muy intensivo de cadenas), recuerda que Mid$, no sólo devuelve una subcadena, también existe una función del mismo nombre ara asignar una subcadena dentro de otra; ejemplo:
Dim dia1 As String, dia2 As String
dia1 = "Miercoles"
dia2 = "Domingo"
Mid$(dia2, 3, 5) = Mid$(dia1, 5, 5)
MsgBox dia2
' ojo: si en dia2 el punto de inserción + cantidad a pegar spera el tamaño se corta el pegado allí donde acaba. Ejemplo:
dia1 = "Miercoles"
dia2 = "Domingo"
Mid$(dia2, 5, 5) = Mid$(dia1, 4, 6) ' no cabe "rcoles" a partir de "go" (de "dominGO"), luego solo se insrtan los caracteres que caben esto es 2, y el resultado será: domi+rco
MsgBox dia2
No está documentada esta funcionalidad, así no es extraño que la gente no la use porque lo desconoce...
Es más rápido que crear nuevas variables temporales para reasginar valores que luego se vuelven a reasignar... además ahorra declarar variables.
-
Acabo de ver tu mensaje sobre como mostrar y ocultar un label con un timer, de forma intermitente...
Deduzco pués que tu nivel es más bien de principiante y quizás te haya 'exigido demasiado', en mi mensaje previo...
Así que te pongo un código que te funcione perfectamente, en la línea de lo que tienes... pero eso sí, al menos sin la colección, basta un array (al menos son más rápidos). Te valdrá para pequeñas cantidades de permutaciones. Pero si te acercas o superas las 500.000-1.000.000 de permutaciones será muy lento.
Más arriba, te proponía apuntar a métodos que calculan 5-15 millones (según la potencia de tu equipo) en una décima de segundo, naturalmente sin almacenarlas, pero te hace falta más dominio...
Aún así, para lo que puedas necesitarlo te valdrá perfectamente el siguiente código. Todavía hay zonas que puedes optimizar, yo he dejado el código sencillo, para que te sea fácilmente entendible... (si lo ejecutas paso a paso (tecla F8) viendo como cambian las variables, podrías llegar a entenderlo perfectamente)
...observa al menos, como es el bucle externo el que a cada ciclo, va construyendo todas las secuencias de 2, 3, 4,5 6,... caracteres. La función te permite no sólo generar todas las permutaciones de tamaño del alfabeto, si no también de un tamaño menor.
Dado que usas cadenas (en vez de arrays de bytes), todo el proyecto, lo he dejado igual, con arrays de cadenas. La lista monaria, se genera antes del bucle, con un simple split, de ahí que el alfabeto, requiera un separador entre caracteres...
Tu ya, modifica a tu gusto...
Enlace de descarga:
http://workupload.com/file/Ze3cy9M - 4'18Kb.
p.d.: Nota también que he modificado ligeramente la función "CalculaNumPermutas", que te poníamás arriba, para permitir calcular el número de permutaciones, para secuencias de un tamaño menor que el alfabeto. Es decir aunque el alfabeto tenga 8 caracteres, tu podrías querer solo secuencias de 5 caracteres. La modificación hecha a la función ahora lo permite, para adaptarse al algoritmo que también lo permite así.
-
Lee las reglas de foro.
Esos que coloco es de mi baul de recuerdos.
-
Perdona, pero no te entiendo...
Lo primero que hice cuando me registré en el foro, fue leer las normas... soy de los que lee siempre la letra pequeña y los EULa de cabo a rabo...
Y bueno, he vuelto a leerlas por tu recomendación, por si había olvidado algo, y...no, no creo saltarme ninguna norma. Ya me dirás tú cual...