.
Cita de: BlackZeroX▓▓▒▒░░ en 27 Mayo 2011, 04:55 AM
@Psyke1
Mas que una matriz quedaría precioso en una clase... al rato lo traslado a una clase para aumentar la velocidad de procesamiento, ya que de este modo se le aumenta el peformance ( en relación procesador/tiempo, pero no memoria ) con una clase.
Este código es una mera actualización directa de este otro, se puede decir que es la version 2.0
[source] Números Aleatorio desde X a Y con excepciones. (http://foro.elhacker.net/programacion_visual_basic/source_numeros_aleatorio_desde_x_a_y_con_excepciones-t328566.0.html)
Vaya solo le falta una opción a mi punto de vista y es meterle una lista de números antes de generar alguno tal cual se le hace en la función solo que ahora seria una propiedad, y podría modificarse en cualquier instante, pero eso se los dejo a ustedes, yo ya hice mi labor.
* El ordenamiento QuickSort se sustituyo por una heuristica mas eficiente.
En un modulo de clase:
cRndNumbersNR.cls
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' ////////////////////////////////////////////////////////////////
Option Explicit
Private Declare Function VarPtrA Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Sub lCopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Type stRangos
lValIni As Long
lValEnd As Long
End Type
Private lcvalmax As Long
Private lcvalmin As Long
Private lvcsplit() As stRangos
Private lacexcep() As Long
Private bChange As Long
Private Sub Swapnumbers(ByRef lvalone As Long, ByRef lvaltwo As Long)
' // Intercambia el contenido de las variables.
Dim lvaltmp As Long
lvaltmp = lvalone
lvalone = lvaltwo
lvaltwo = lvaltmp
End Sub
Private Function Fixnumbers(ByRef lvalmin As Long, lvalmax As Long) As Boolean
' // Corrige los valores dados.
If lvalmax < lvalmin Then
Call Swapnumbers(lvalmin, lvalmax)
Fixnumbers = True
End If
End Function
Private Function NumRandom(lvalmin As Long, lvalmax As Long) As Long
' // Genera un Numero aleatorio de acuerdo a un rango dado.
Call Fixnumbers(lvalmin, lvalmax)
Call Randomize
NumRandom = (lvalmin - lvalmax) * Rnd + lvalmax
End Function
Public Sub Reset()
' // Reinicia y permite nuevamente generar los números aleatorios desde el principio, si no aplica este al generar todos los numeros, entonces no generara mas números y devolverá únicamente 0..
Erase lvcsplit()
Erase lacexcep()
ReDim lvcsplit(0 To 0)
lvcsplit(0).lValIni = lcvalmin
lvcsplit(0).lValEnd = lcvalmax
bChange = False
End Sub
Public Property Get GetMore() As Boolean
' // Hay mas ocurrencias? cuando ya no hay se elimina el array de ocurrencias.
GetMore = Itsarrayini(VarPtrA(lvcsplit)) Or bChange = True
End Property
Private Function Itsarrayini(ByVal lpszv As Long, Optional llen As Long = 4) As Boolean
' // Obtiene el limite superior de los numeros a generar de manera aleatoria sin repetir.
Dim lpsz As Long
If lpszv <> 0 And llen > 0 Then
Call lCopyMemory(ByVal VarPtr(lpsz), ByVal lpszv, llen)
Itsarrayini = Not lpsz = 0
End If
End Function
Private Sub SeparateRange(ByVal lDivVal As Long, ByVal lindex As Long, ByRef vArray() As stRangos)
' // Es un proceso para aplicar el dicho "Divide y Venceras", esto aumenta mucho la velocidad para no repetir numeros dentro de un rango dado y generados de manera aleatoria.
' // Repeti un poco de codigo lo siento xP...
Dim lu As Long
Dim lpsz As Long
If (vArray(lindex).lValIni <= lDivVal And lDivVal <= vArray(lindex).lValEnd) Then
lu = UBound(vArray)
lpsz = VarPtr(vArray(lindex))
If (vArray(lindex).lValIni = lDivVal) Then
vArray(lindex).lValIni = vArray(lindex).lValIni + 1
If (vArray(lindex).lValIni > vArray(lindex).lValEnd) Then
If (lu > 0) Then
lCopyMemory lpsz, lpsz + &H8, ((lu - lindex) * &H8)
lu = lu - 1
ReDim Preserve vArray(0 To lu)
Else
Erase vArray()
End If
End If
ElseIf (vArray(lindex).lValEnd = lDivVal) Then
vArray(lindex).lValEnd = vArray(lindex).lValEnd - 1
If (vArray(lindex).lValIni > vArray(lindex).lValEnd) Then
If (lu > 0) Then
lCopyMemory lpsz, lpsz + &H8, ((lu - lindex) * &H8)
lu = lu - 1
ReDim Preserve vArray(0 To lu)
Else
Erase vArray()
End If
End If
Else
lu = lu + 1
ReDim Preserve vArray(0 To lu)
lpsz = VarPtr(vArray(lindex))
lCopyMemory lpsz + &H10, (lpsz + &H8), (((lu - 1) - lindex) * &H8)
vArray(lindex + 1).lValEnd = vArray(lindex).lValEnd
vArray(lindex + 1).lValIni = (lDivVal + 1)
vArray(lindex).lValEnd = (lDivVal - 1)
End If
End If
End Sub
Public Property Get GetNumRandom() As Long
' // Genera un numero aleatorio sin repetir de acuerdo a un rango de valores dados.
Dim lindex As Long
Dim lu As Long
Dim lret As Long
If (bChange = True) Then
Call Fixnumbers(lcvalmin, lcvalmax)
Call Reset
End If
If (GetMore = True) Then
lindex = NumRandom(0, UBound(lvcsplit))
lret = NumRandom(lvcsplit(lindex).lValIni, lvcsplit(lindex).lValEnd)
SeparateRange lret, lindex, lvcsplit
If (Itsarrayini(VarPtrA(lacexcep)) = True) Then
lu = UBound(lacexcep) + 1
Else
lu = 0
End If
ReDim Preserve lacexcep(0 To lu)
lacexcep(lu) = lret
GetNumRandom = lret
End If
End Property
Public Property Let minval(ByVal ldata As Long)
' // Establece el limite inferior de los numeros a generar de manera aleatoria sin repetir.
lcvalmin = ldata
bChange = True
End Property
Public Property Get minval() As Long
' // Obtiene el limite inferior de los numeros a generar de manera aleatoria sin repetir.
minval = lcvalmin
End Property
Public Property Let maxval(ByVal ldata As Long)
' // Establece el limite superior de los numeros a generar de manera aleatoria sin repetir.
lcvalmax = ldata
bChange = True
End Property
Public Property Get maxval() As Long
' // Obtiene el limite superior de los numeros a generar de manera aleatoria sin repetir.
maxval = lcvalmax
End Property
Public Property Get GetNumbers() As Long()
' // Devueve una coleccion de los numeros generados.
GetNumbers() = lacexcep()
End Property
Public Function RegenerateThis(ByVal lVal As Long) As Boolean
Dim ii As Long
Dim lub As Long
If (lcvalmin <= lVal) And (lcvalmax >= lVal) Then
If (breglist = True) Then
If (Itsarrayini(VarPtrA(lacexcep)) = True) Then
For ii = 0 To UBound(lacexcep)
If (lacexcep(ii) = lVal) Then
RemoveInArrayLong ii, lacexcep()
Exit For
End If
Next ii
End If
End If
If (Itsarrayini(VarPtrA(lvcsplit)) = True) Then
lub = UBound(lvcsplit)
For ii = 0 To (lub - 1)
If (lvcsplit(ii).lValEnd > lVal) And (lvcsplit(ii + 1).lValIni < lVal) Then
If ((lvcsplit(ii).lValEnd + 1) = lVal) Then
lvcsplit(ii).lValEnd = lVal
ElseIf ((lvcsplit(ii + 1).lValIni) = lVal) Then
lvcsplit(ii + 1).lValIni = lVal
End If
Select Case (lvcsplit(ii).lValEnd = lvcsplit(ii + 1).lValIni)
Case 0, 1
lub = (lub - 1)
lvcsplit(ii).lValEnd = lvcsplit(ii + 1).lValEnd
ReDim Preserve lvcsplit(0 To lub)
Case Else
If Not ((lvcsplit(ii).lValEnd + 1) = lvcsplit(ii + 1).lValIni) Then
lub = (lub + 1)
ReDim Preserve lvcsplit(0 To lub)
SwapBlockMemoryInCicle VarPtr(lvcsplit(ii)), (VarPtr(lvcsplit(lub)) + LenB(lvcsplit(0))), LenB(lvcsplit(0))
lvcsplit(ii + 1).lValIni = lVal
lvcsplit(ii + 1).lValEnd = lVal
End If
End Select
RegenerateThis = True
Else
Exit For
End If
Next ii
Else
ReDim lvcsplit(0 To 0)
lvcsplit(0).lValIni = lVal
lvcsplit(0).lValEnd = lVal
End If
End If
End Function
Private Sub Class_Initialize()
' // Constructor de la clase, no tengo por que hacer lo siguiente pero como me estoy adaptando a un standart lo hare.
bChange = False
End Sub
uso simple:
Option Explicit
Private Sub Form_Load()
Dim cls As cRndNumber
Dim lc As Long
Set cls = New cRndNumber
With cls
' // Este simple codigo probara la velocidad, que de hecho ya es rapido a consideracion de otros que conozco.
.minval = 0
.maxval = 99999
Do While (.GetMore = True)
DoEvents
lc = .GetNumRandom
Loop
MsgBox "Se recorrieron todos los numeros sin repetir alguno xD"
' // Si se cambian los valores menor y mayor entonces es como si se le aplicara call .Reset
' // Este codigo hara un test de repeticion
.minval = 0
.maxval = 99
Do While (.GetMore = True)
DoEvents
Debug.Print .GetNumRandom
Loop
MsgBox "Se recorrieron todos los numeros sin repetir alguno xD"
End With
End Sub
Temibles Lunas!¡.
(http://t2.gstatic.com/images?q=tbn:ANd9GcR6a0ECDRIl41EhYGChGUyy7895UC4fqiw7vVhQhm7zdfes33w8IQ&t=1)
:laugh:
Wow, impresionante, y rapidísimo también. :D
La única cosa que hecho en falta es la posibilidad de excluir números. :)
Ya pensaré algo... :rolleyes:
PD: ¿Algún año de estos seguiremos con nuestro proyecto secreto? :silbar: :xD
DoEvents! :P
Cita de: Psyke1 en 28 Mayo 2011, 13:24 PM
La única cosa que hecho en falta es la posibilidad de excluir números. :)
Ya pensaré algo... :rolleyes:
PISTA:Debes buscar el indice del array donde se encuentre el valor a excluir y pasarlo por la función:
Private Sub SeparateRange(ByVal lDivVal As Long, ByVal lindex As Long, ByRef vArray() As stRangos)Reformando la funcion ItsInArray se puede hacer, no me gustaría ver un
For Next que recorra todos elementos del array ya que es algo muy feo y no entra en la relación
Tiempo-Procesador ya que alentaria mucho el proceso.
Dulces Lunas!¡.
.
mmmmmmmmmmmm
Ook, pensaré algo... :rolleyes:
DoEvents! :P
Quizás puedas ahorrarte los RedimPreserve() que gastan mucho tiempo y redimensionarlo cada 1024 elementos.
¿Y para devolverlos en la propiedad GetNumbers() sería más rápido copiando el array CopyMemory()? :huh:
DoEvents! :P
'
1024*4 = 4096 = 4kb's ---> Cache eso me estas sugiriendo?, aun así la probabilidad de que se ocupe la clase en un bucle tal cual lo hago es baja.
GetNumbers() se puede usar Set también no tengo idea si se aumenta la velocidad...
P.D.: Psyke1 -> Estoy saturado de tarea... lo bueno que ya entro para el ciclo vacacional en 5 días.
Dulces Lunas!¡.
Algo así, por ejemplo:
'...
Public Property Get GetNumRandom() As Long
' // Genera un numero aleatorio sin repetir de acuerdo a un rango de valores dados.
Dim lindex As Long
Dim lu As Long
Dim lret As Long
If (bChange = True) Then
Call Fixnumbers(lcvalmin, lcvalmax)
Call Reset
End If
If (GetMore = True) Then
lindex = NumRandom(0, UBound(lvcsplit))
lret = NumRandom(lvcsplit(lindex).lValIni, lvcsplit(lindex).lValEnd)
SeparateRange lret, lindex, lvcsplit
If (Itsarrayini(VarPtrA(lacexcep)) = True) Then
lu = UBound(lacexcep) + 1
If (lu Mod &H3FF) = 0 Then '# si la matriz tiene 1024 elementos (lo puedes hacer con And también)
ReDim Preserve lacexcep(0 to (lu + &H400)) '# le añadimos 1024 más...
End If
Else
lu = 0
Redim lacexcep(0)
End If
lacexcep(lu) = lret
GetNumRandom = lret
End If
End Property
'...
Private Sub Class_Initialize()
' // Constructor de la clase, no tengo por que hacer lo siguiente pero como me estoy adaptando a un standart lo hare.
ReDim lacexcep(&H3FF) '# iniciamos la matriz con 1024
bChange = False
End Sub
En cuanto a lo de copiar la matriz... :rolleyes:
Hice este test y... :o ¡sorpresa!
Gana RtlMoveMemory() ;-)
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)
Private Sub Form_Load()
Const Max& = 999990
Dim q&, a&(Max), b&(), t As New CTiming
Me.AutoRedraw = True
ReDim b&(Max)
For q = 0 To Max
a(q) = q
Next q
t.Reset
RtlMoveMemory VarPtr(b(0)), VarPtr(a(0)), (Max + Max + Max + Max + 4) '// Procuro evitar multiplicaciones...
Me.Print "RtlMoveMemory", t.sElapsed
ReDim b&(Max)
t.Reset
b = a
Me.Print "Igualación", , t.sElapsed
'// Con Set me tiraba error... xP
End Sub
Resultado:
(http://img202.imageshack.us/img202/6489/justinbieberko.jpg)
DoEvents! :P
.
OK, yo pensaba que decias por el array de stRangos (lvcsplit) .
No hagas el test de esa manera,:
estas aplicando la relación:
Variable -> a -> Variable
la debes aplicar
(Miembro de clase)Propiedad -> a -> Variable
La diferencia radica en que en una no hay PILA de datos y en otra si.
Dulces Lunas!¡.
Cita de: BlackZeroX▓▓▒▒░░ en 30 Mayo 2011, 01:40 AM
.
OK, yo pensaba que decias por el array de stRangos (lvcsplit) .
No hagas el test de esa manera,:
estas aplicando la relación:
Variable -> a -> Variable
la debes aplicar
(Miembro de clase)Propiedad -> a -> Variable
La diferencia radica en que en una no hay PILA de datos y en otra si.
Dulces Lunas!¡.
Sería genial que la técnica esa la emplearas también con
vArray(), puesto que las estructuras pesan
8 Bytes.
Es cierto lo que dices, en el test no conté con eso... :silbar:
Está bien como está. :)
Pd1:
Public Property Get maxval() As Long
' // Obtiene el limite superior de los numeros a generar de manera aleatoria sin repetir.
minval = lcvalmax '// Sería maxval
End PropertyPd2: Estaría genial que pusieras más ejemplos usando todas las propiedades para que a la gente le quedara más claro. :rolleyes:
Pd3:
CitarP.D.: Psyke1 -> Estoy saturado de tarea... lo bueno que ya entro para el ciclo vacacional en 5 días.
Ook, comienza la cuanta atrás... :xD
DoEvents! :P
Mi granito de arena; Una forma más rápida de hacer el Swapnumbers() sin usar variable temporal:
Private Sub Swapnumbers(ByRef l1 As Long, ByRef l2 As Long)
l1 = l1 Xor l2
l2 = l2 Xor l1
l1 = l1 Xor l2
End Sub
También acelerararias un poco si enlazases RtlMoveMemory() directamente desde NTDLL y no desde KERNEL32 ;)
HOLA!!!
Cita de: Karcrack en 30 Mayo 2011, 16:36 PM
Mi granito de arena; Una forma más rápida de hacer el Swapnumbers() sin usar variable temporal:
Private Sub Swapnumbers(ByRef l1 As Long, ByRef l2 As Long)
l1 = l1 Xor l2
l2 = l2 Xor l1
l1 = l1 Xor l2
End Sub
También acelerararias un poco si enlazases RtlMoveMemory() directamente desde NTDLL y no desde KERNEL32 ;)
Que buena idea!!!
Lo voy a tener en cuenta, puede servir mucho.
GRACIAS POR LEER!!!
Agregue un proceso en el 1er post para poder Regenerar un numero X.
Dulces Lunas!¡.