[RETO] Project Euler 3

[BlackZeroX]

.
El perico es verde en cualquier parte.

@Psyke1
¿Cual trampa? nadie dijo que NO se podía hacer lo que hice...

Dulces Lunas!¡.

[BlackZeroX]

Tal vez esta versión no sea rápida pero usa una generación de números primos que se deseaban...

Código (vb) [Seleccionar] Expandir


Option Explicit
Option Base 0

Dim ManagerPrime    As clsPrime

Private Sub Form_Load()
   Set ManagerPrime = New clsPrime

    Call ManagerPrime.Clear
    MsgBox ManagerPrime.ItsPrime(6857)
    MsgBox "Para calcular si fue primo se calcularon " & ManagerPrime.CountPrime() & " numeros primos."
    Call ManagerPrime.Clear
   
   ManagerPrime.BufferLimitIndex(7000) = &H7FFFFFFF
   MsgBox ProyectEuler3_ByBlack
   
   Set ManagerPrime = Nothing
End Sub

Public Function ProyectEuler3_ByBlack(Optional ByVal lNumber As Double = 600851475143#) As Double
'Dim ManagerPrime    As clsPrime
Dim auxn            As Double
Dim auxd            As Double
Dim i               As Long
   'Set ManagerPrime = New clsPrime
   While lNumber > 1
       DoEvents
       auxd = lNumber / ManagerPrime.Prime(i)
       auxn = Fix(auxd)
       If (auxd = auxn) Then
           lNumber = auxn
       Else
           i = (i + 1)
       End If
   Wend
   ProyectEuler3_ByBlack = ManagerPrime.Prime(i)
   'Set ManagerPrime = Nothing
End Function


clsPrime.cls

Código (vb) [Seleccionar] Expandir


Option Explicit
Option Base 0

Private m_N             As Long
Private m_Now           As Long
Private m_Arr()         As Long
Const MAX_LIMIT_VALUE   As Long = &H7FFFFFFF

Private Sub Class_Initialize()
   Clear
End Sub

Private Function Calculate(ByVal Start As Long, Optional ByVal MaxLimitValue As Long = MAX_LIMIT_VALUE) As Long
Dim j As Long
   
   For m_Now = Start To MaxLimitValue
   
       j = (m_Now - 1)
       
       Do While (m_Now Mod j <> 0)
           j = (j - 1)
       Loop
       
       If (j < 2) Then
           Calculate = m_Now
           Exit Function
       End If
   Next
   
   Calculate = &H80000000
   
End Function

Public Sub Clear()
   m_N = 0
   m_Now = 2
   ReDim m_Arr(m_N)
   m_Arr(m_N) = 2
End Sub

Public Property Let BufferLimitIndex(Optional ByVal MaxLimitValue As Long = MAX_LIMIT_VALUE, ByVal n As Long)
Dim lRes        As Long
Dim lNow        As Long
   
   Do While (m_N < n)
       lRes = Calculate(m_Now + 1, MaxLimitValue)
       If (lRes And &H80000000) Then
           Exit Do
       Else
           m_N = (m_N + 1)
           ReDim Preserve m_Arr(m_N)
           m_Arr(m_N) = lRes
       End If
   Loop
End Property

Public Property Get CountPrime() As Long
   CountPrime = (m_N + 1)
End Property

Public Property Get BufferLimitIndex(Optional ByVal MaxLimitValue As Long = MAX_LIMIT_VALUE) As Long
   BufferLimitIndex = m_N
End Property

Public Function Prime(ByVal Index As Long, Optional ByVal MaxLimitValue As Long = MAX_LIMIT_VALUE) As Long
Dim lRes        As Long
   Prime = &H80000000
   If Index > m_N Then
       BufferLimitIndex(MaxLimitValue) = Index
       If Not (Index = m_N) Then Exit Function
   End If
   Prime = m_Arr(Index)
End Function

Public Function ItsPrime(ByVal Value As Long) As Boolean
Dim i       As Long
Dim lRes    As Long

   ItsPrime = True
   
   If (m_Now < Value) Then

       Do
           lRes = Prime(m_N + 1, Value)
           If (lRes And &H80000000) Then Exit Do
       Loop While (m_Arr(m_N) < Value)
       
       If Not (m_Arr(m_N) = Value) Then ItsPrime = False
       
   Else
       For i = 0 To m_N
           If (m_Arr(i) = Value) Then Exit For
       Next
       
       ItsPrime = False
       
   End If
   
End Function

Private Sub Class_Terminate()
   Call Clear
End Sub


Dulces Lunas!¡.

[Psyke1]

Bueno he hecho unos test, aquí está el código:

Código [Seleccionar] Expandir


Option Explicit
Private ManagerPrime    As New clsPrime

Private Sub Form_Load()
Dim Q                   As Long
Dim t                   As New CTiming
Const LOOPS             As Long = 500

   If App.LogMode = 0 Then MsgBox "¡Compila!", vbCritical: End
   
   Me.AutoRedraw = True
   Me.Print "Con " & LOOPS & " vueltas"
   Me.Print
   
   t.Reset
   Call ManagerPrime.Clear
   ManagerPrime.BufferLimitIndex(7000) = &H7FFFFFFF
   
   For Q = 1 To LOOPS
       ProyectEuler3_ByBlack
   Next Q
   Me.Print "BlackZeroX -> ", t.sElapsed
   
   t.Reset
   For Q = 1 To LOOPS
       ProyectEuler3_ByDark
   Next Q
   Me.Print "DarkMatrix -> ", t.sElapsed
   
   t.Reset
   For Q = 1 To LOOPS
       PE3_DarkmodPsyke1
   Next Q
   Me.Print "DarkmodPsyke1 -> ", t.sElapsed
   
   t.Reset
   For Q = 1 To LOOPS
       PE3_Psyke1
   Next Q
   Me.Print "Psyke1 -> ", , t.sElapsed
   
   Set ManagerPrime = Nothing
End Sub

Public Function ProyectEuler3_ByBlack(Optional ByVal lNumber As Double = 600851475143#) As Double
'Dim ManagerPrime    As clsPrime
Dim auxn            As Double
Dim auxd            As Double
Dim i               As Long
   'Set ManagerPrime = New clsPrime
   While lNumber > 1
       'DoEvents
       auxd = lNumber / ManagerPrime.Prime(i)
       auxn = Fix(auxd)
       If (auxd = auxn) Then
           lNumber = auxn
       Else
           i = (i + 1)
       End If
   Wend
   ProyectEuler3_ByBlack = ManagerPrime.Prime(i)
   'Set ManagerPrime = Nothing
End Function



Public Function ProyectEuler3_ByDark(Optional ByVal lNumber As Double = 600851475143#) As Double

   Dim n As Double
   Dim A As Double
   Dim B As Double

   Do

       n = n + 1

       A = lNumber / n
       B = Fix(lNumber / n)

       If A - B = 0 Then

           lNumber = B
           ProyectEuler3_ByDark = n
           n = 1

       End If

   Loop Until lNumber = 1

End Function

Public Static Function PE3_DarkmodPsyke1(Optional ByVal dNumber As Double = 600851475143#) As Double
Dim lCount                              As Long
Dim dDiv                                As Double

   Do While dNumber > 1
       lCount = lCount + &H1
       dDiv = dNumber / lCount

       If dDiv = Fix(dDiv) Then
           dNumber = dDiv
           PE3_DarkmodPsyke1 = lCount
           lCount = &H1
       End If
   Loop
End Function

Public Static Function PE3_Psyke1(Optional ByVal dNumber As Double = 600851475143#) As Double
Dim lCount                              As Long
Dim dDiv                                As Double

   dDiv = dNumber / 2

   If dDiv = Fix(dDiv) Then
       dNumber = dDiv
   End If

   lCount = &H1

   Do
       lCount = lCount + &H2
       dDiv = dNumber / lCount

       If dDiv = Fix(dDiv) Then
           dNumber = dDiv
           dDiv = dNumber / 2

           If dDiv = Fix(dDiv) Then
               dNumber = dDiv
           End If

           PE3_Psyke1 = lCount
           lCount = &H1
       End If
   Loop Until dNumber = 1
End Function

Y aquí unos resultados:







Obviamente a la larga gana la función de BlackZeroX puesto que no tiene que calcular casi nada...
Yo personalmente me quedaría con la mía.

Voy posteando el siguiente.

DoEvents!

[imoen]

Y para que dais tantas vueltas?¿ jeje

Esta clar si no tiene que calcular nada , pq ya esta precargado pues poco tiene que hacer


bs imoen