Algoritmos Geneticos con 4 genes
Option Explicit
Public Event evSalir()
Private vSolucionEncontrada As Boolean 'Variable para uso de la propiedad prSolucionEncontrada
'Autor Rafael Angel Montero Fernández. (Angel Continium ADNX)
'Fecha viernes 16 de septiembre del 2016.
'Despues de muchos intentos este es el primer algoritmo genetico funcional al 100% que he diseñado basandome en la experiencia y conocimientos del tema y las practicas.
'El algoritmo si encuentra la solucion pero ahora la tarea que debo realizar es una funcion que lance la solucion encontrada la cual si llegará a nacer.
'Si sigo desarrollando y perfeccionando este algoritmo entonces, me permitirá crear una serie de programas muy interactivos y con la capacidad de aprender en forma interactiva similar a la de un bebe.
'Este algoritmo es totalmente funcional, se puede partir de aqui para crear nuevas variantes del algoritmo usando como estructura o base este mismo.
'Por ejemplo en la cimulacion de un veiculo autonomo que trancita por un camino sin chocar contra otros objetos o bordes, aprendizage interactivo con el usuario...
'Juegos de estrategia en la cual las unidades controladas por la computadora no realicen ataques suicidas sino que su comportamiento sea similar al de un ser humano.
'Busquedas no lineales de informacion sino, que en paralelo, por ejemplo divicion cilavica.
Private mPoblacion(1 To 100) As Long 'El genoma contenido aleatoriamente por cada habitante. O mediante reconbinaciones similares a las que suceden en la naturaleza del mundo real.
Private mGenoma(1 To 4) As String 'Genoma con el que se creará una determinada poblacion de habitantes hasta que nasca uno con la respuesta deseada o elegida por el usuario; en este modo experimental entonces, el programador.
Private mPuntuacion(1 To 100) As Long 'Puntuacion generada por cada habitante, su valor esta determinado por la cercania a la respuesta deseada la cual, consta de 4 genes, igual que el genoma pero, con una configuracion elegida por el usuario.
Private mCriterioDeSeleccion(1 To 4) As String 'El criterio de seleccion es la respuesta elegida por el usuario o programador, como se esta en modo diseño o experimental, por el momento se trabajará eligiendo la mejor respuesta manualmente; sin embargo, se espera que el algoritmo por si solo encuentré la mejor combinacion basandose en el ambiente.
Private mMejores(1 To 4) As Long 'Los 4 mejores habitantes de la poblacion, aunque, despues de cruzarse con la poblacion, los 4 mejores realizan un torneo en el cual solo quedará 1. No necesariamente es la unica forma de optimizar a los mejores.
Private mMejores_puntuacion(1 To 4) As Long 'Puntuacion que corresponderá con el Id de cada uno de los mejores.
Private Sub cmdAdd_Click()
sAddGenomaDecodificado txtAdd: txtAdd = ""
End Sub
Private Sub CMDEnd_Click()
RaiseEvent evSalir
End Sub
Public Function Aleatorios(ByVal Max As Long, Optional ByVal Min As Long = -1)
'Modificado por Rafael Angel Montero Fernández el dia viernes 9 de septiembre del 2016.
Dim vMi_valor_ya As Long
Static vMi_valor_antes As Long
Randomize ' Inicializa el generador de números aleatorios.
Do
If Min = -1 Then 'Devuelve el Max con el que se trabajará en las diferentes tareas.
vMi_valor_ya = Int((Max * Rnd) + 1) ' Genera valores aleatorios entre 1 y Max.
Else 'Devuelve un intervalo entre el Min y el Max con el que se trabajará en este proyecto.
vMi_valor_ya = Int((Max - Min + 1) * Rnd + Min)
Select Case vMi_valor_ya
Case Is < Min
vMi_valor_ya = 1
Case Is > Max
vMi_valor_ya = Max
End Select
End If
If vMi_valor_antes <> vMi_valor_ya Then
Aleatorios = vMi_valor_ya
End If
Loop Until vMi_valor_antes <> vMi_valor_ya 'Esto garantiza que de verdad se devuelva como respuesta un numero aleatorio diferente a la ultima llamada.
vMi_valor_antes = vMi_valor_ya 'Se guarda el valor de la llamada actual para luego compararlo con el valor de la siguiente llamada a esta funcion.
End Function
Private Function fDecodificar(Id As Long) As String
'lstGenoma
'Dim i As Long, vFenotipo As Variant, mLocal As String
fDecodificar = lstGenoma.List(Id - 1)
End Function
Private Function fDesempeño() As String
Dim i As Long, mADN As String ', v_Id_ADN As Long, vAciertos As Long
lstRendimiento.AddItem "Desempeño"
For i = LBound(mPoblacion) To UBound(mPoblacion)
DoEvents
' For v_Id_ADN = LBound(mGenoma) To UBound(mGenoma)
' DoEvents
'
' If fDecodificar(Mid(mPoblacion(i), v_Id_ADN, 1)) = mCriterioDeSeleccion(v_Id_ADN) Then
' vAciertos = vAciertos + 1
' End If
'
' Next v_Id_ADN
mPuntuacion(i) = fFitness(mPoblacion(i)) ' vAciertos 'Carga los puntos para el Habitante Id...
lstRendimiento.AddItem "Habitante"
lstRendimiento.AddItem mPoblacion(i)
lstRendimiento.AddItem "Puntuacion " & mPuntuacion(i)
If vAciertos = UBound(mGenoma) Then 'Los aciertos son del tamaño del genoma pero de acuerdo a la solucion elegida por mi.
MsgBox "Solucion encontrada." & RTC & "Habitante con genoma: " & mPoblacion(i) & RTC & "Id=" & i & RTC & "Puntuacion (Fitness)=" & vAciertos & RTC & RTC & fFenotipo(mPoblacion(i), True)
txtAdd.Text = mPoblacion(i)
prSolucionEncontrada = True
Exit For
End If
'vAciertos = 0
Next i
End Function
Private Function fEvaluar() As Long
Dim i As Long, vId_G As Long, vMejorPuntuacion As Long
For i = LBound(mPoblacion) To UBound(mPoblacion)
DoEvents
For vId_G = LBound(mPoblacion) To UBound(mPoblacion)
DoEvents
Select Case mPuntuacion(i)
Case Is < mPuntuacion(vId_G)
mPuntuacion(i) = mPuntuacion(vId_G)
mPoblacion(i) = mPoblacion(vId_G)
Case Is > mPuntuacion(vId_G)
vMejorPuntuacion = mPuntuacion(i)
Case Is = mPuntuacion(vId_G)
vMejorPuntuacion = mPuntuacion(i)
End Select
Next vId_G
Next i
fEvaluar = vMejorPuntuacion
'fEvaluar = fEvaluar
''________________________
''No borrar ya que es la formula original.
'Dim vEvaluado As String
'vEvaluado = prAptitudMaxima - (prValorDeCastigo * prAptitudMinima) 'No borrar esta formula ya que es la original para evaluar a la poblacion.
'fEvaluar = vEvaluado
End Function
Private Function fMutasion(Optional Cantidad_de_mutaciones As Long = 2) As Variant
If prSolucionEncontrada = True Then Exit Function
Dim i As Long, vMutante As Long, vId_del_genoma As Long
Dim vParticion As Long
lstMutacion.AddItem "Mutacion"
For i = LBound(mPoblacion) To Cantidad_de_mutaciones
DoEvents
For vId_del_genoma = LBound(mGenoma) To UBound(mGenoma) / 2
DoEvents
vParticion = Aleatorios(UBound(mGenoma), 1)
If vMutante = 0 Then
vMutante = Mid(mPoblacion(i), vParticion, 1) & mGenoma(vParticion) ' & Mid(mPoblacion(i), vParticion, 1) & mGenoma(vParticion) '& Mid(mPoblacion(i), vParticion, 1) & Mid(mPoblacion(i), vParticion, 1)
Else
vMutante = vMutante & Mid(mPoblacion(i), vParticion, 1) & mGenoma(vParticion) ' & Mid(mPoblacion(i), vParticion, 1) & mGenoma(vParticion) '& Mid(mPoblacion(i), vParticion, 1) & Mid(mPoblacion(i), vParticion, 1)
End If
Next vId_del_genoma
lstMutacion.AddItem vMutante
mPoblacion(i) = vMutante
vMutante = 0
Next i
End Function
Private Function fReemplazoDeIndividuos() As String
If prSolucionEncontrada = True Then Exit Function
Dim i As Long, vMutante As Long
Dim vParticion As Long, vReemplazante As Long
lstReemplazo.AddItem "Reemplazando"
For i = LBound(mPoblacion) To UBound(mPoblacion)
DoEvents
If mPuntuacion(i) < fEvaluar Then
vReemplazante = mMejores(Aleatorios(UBound(mGenoma), 1))
If vReemplazante <= 0 Then
vReemplazante = mMejores(Aleatorios(UBound(mGenoma), 1))
End If
If vReemplazante <> 0 Then
mPoblacion(i) = vReemplazante
End If
End If
lstReemplazo.AddItem mPoblacion(i)
Next i
End Function
Private Function fSeleccionDeIndividuos() As String
If prSolucionEncontrada = True Then Exit Function
Dim i As Long, vMutante As Long
Dim vParticion As Long
lstMejores.AddItem "Mejores habitantes"
For i = LBound(mMejores) To UBound(mMejores)
DoEvents
If mPuntuacion(i) >= fEvaluar Then
mMejores(i) = mPoblacion(i)
mMejores_puntuacion(i) = mPuntuacion(i)
lstMejores.AddItem mMejores(i)
lstMejores.AddItem "Puntuacion " & mMejores_puntuacion(i)
End If
Next i
sReproduccionMejoresVsPoblacion
End Function
Private Property Let prAptitudMaxima(RHS As String)
'
End Property
Private Property Get prAptitudMaxima() As String
prAptitudMaxima = UBound(mGenoma)
End Property
Private Property Let prAptitudMinima(RHS As String)
'
End Property
Private Property Get prAptitudMinima() As String
prAptitudMinima = 2
End Property
Private Property Let prCriterioDeSeleccion(Nuevos_datos As String)
Dim mLocal() As String, i As Long
mLocal = Split(Nuevos_datos, RTC)
For i = LBound(mCriterioDeSeleccion) To UBound(mCriterioDeSeleccion)
DoEvents
mCriterioDeSeleccion(i) = mLocal(i)
Next i
End Property
Private Property Get prCriterioDeSeleccion() As String
prCriterioDeSeleccion = Join(mCriterioDeSeleccion, RTC)
End Property
Private Property Let prGeneracionesCantidad(RHS As Long)
'
End Property
Private Property Get prGeneracionesCantidad() As Long
prGeneracionesCantidad = 50
End Property
Private Property Let prTamañoDeLaPoblacion(RHS As Long)
'
End Property
Private Property Get prTamañoDeLaPoblacion() As Long
prTamañoDeLaPoblacion = UBound(mPoblacion)
End Property
Private Property Let prTamañoDelGenoma(RHS As Long)
'
End Property
Private Property Get prTamañoDelGenoma() As Long
prTamañoDelGenoma = UBound(mGenoma)
End Property
Private Property Let prValorDeCastigo(RHS As String)
'
End Property
Private Property Get prValorDeCastigo() As String
prValorDeCastigo = UBound(mPoblacion) / 2
End Property
Private Sub sAddGenomaDecodificado(Datos_que_desea_que_contenga_cada_genoma As Variant)
Static vContandoGenes As Long
Dim i As Long
vContandoGenes = vContandoGenes + 1
If vContandoGenes > UBound(mGenoma) Then
MsgBox "Ya se han llenado los genes."
Exit Sub
End If
lstGenoma.AddItem Datos_que_desea_que_contenga_cada_genoma
For i = 1 To lstGenoma.ListCount '- 1
mGenoma(i) = i
Next i
End Sub
Private Sub sEvolucionar()
sPoblar
Dim i As Long, vIteraciones_Do As Long
Do While prSolucionEncontrada = False
DoEvents
vIteraciones_Do = vIteraciones_Do + 1
If vIteraciones_Do = 50 Then
prSolucionEncontrada = True
Exit Do
End If
lstPoblacion.AddItem "vIteraciones_Do " & vIteraciones_Do
For i = 1 To 20
DoEvents
lstPoblacion.AddItem "Genracion " & i
sPoblar
fDesempeño
fMutasion 3
fSeleccionDeIndividuos
fReemplazoDeIndividuos
sRecombinasion 80
If prSolucionEncontrada = True Then
Exit For
End If
Next i
If prSolucionEncontrada = True Then
Exit Do
End If
Loop
'lstPoblacion.AddItem "Generacion extra"
'sPoblar
'fDesempeño
'fSeleccionDeIndividuos
End Sub
Private Function RTC()
'Crea un salto de linea.
RTC = Chr(13) + Chr(10)
End Function
Private Sub sPoblar()
sRecombinasion
End Sub
Private Sub sRecombinasion(Optional Numero_de_combinaciones As Long = 0)
If prSolucionEncontrada = True Then Exit Sub
Dim i As Long, vDesendiente As Long, vId_adn As Long
Dim vHabitante As Long
If Numero_de_combinaciones = 0 Then
For i = LBound(mPoblacion) To UBound(mPoblacion) 'Poblando toda la matriz.
DoEvents
For vId_adn = LBound(mGenoma) To UBound(mGenoma)
'Se toman aleatoriamente los genes del genoma original para crear la primera generacion.
DoEvents
If vHabitante = 0 Then
vHabitante = mGenoma(Aleatorios(UBound(mGenoma), 1)) '& mGenoma(Aleatorios(UBound(mGenoma), 1)) & mGenoma(Aleatorios(UBound(mGenoma), 1)) & mGenoma(Aleatorios(UBound(mGenoma), 1)) '& mGenoma(Aleatorios(UBound(mGenoma), 1)) & mGenoma(Aleatorios(UBound(mGenoma), 1))
Else
vHabitante = vHabitante & mGenoma(Aleatorios(UBound(mGenoma), 1)) '& mGenoma(Aleatorios(UBound(mGenoma), 1)) & mGenoma(Aleatorios(UBound(mGenoma), 1)) & mGenoma(Aleatorios(UBound(mGenoma), 1)) '& mGenoma(Aleatorios(UBound(mGenoma), 1)) & mGenoma(Aleatorios(UBound(mGenoma), 1))
End If
Next vId_adn
mPoblacion(i) = vHabitante
lstPoblacion.AddItem mPoblacion(i)
vHabitante = 0
Next i
Else 'Recombinacion.
If Numero_de_combinaciones > UBound(mPoblacion) Then Numero_de_combinaciones = UBound(mPoblacion)
Dim vPadre As Long, vMadre As Long
For i = LBound(mPoblacion) To Numero_de_combinaciones 'UBound(mPoblacion)
DoEvents
'En forma aleatoria se toman los genes de ambos progenitores.
vPadre = mPoblacion(Aleatorios(UBound(mPoblacion), 1))
vMadre = mPoblacion(Aleatorios(UBound(mPoblacion), 1))
vDesendiente = Mid(vPadre, 1, UBound(mGenoma) / 2) & Mid(vMadre, (UBound(mGenoma) / 2) + 1, UBound(mGenoma) / 2)
Dim vReverse As Long
vReverse = Aleatorios(UBound(mGenoma), 1) 'Decisiones de convinacion.
Select Case vReverse
Case 1
mPoblacion(i) = vDesendiente
Case 2
mPoblacion(i) = StrReverse(vDesendiente)
Case 3 'Revisar las siguientes lineas para optimizacion.
mPoblacion(i) = StrReverse(Mid(vDesendiente, (UBound(mPoblacion) / 2) + 1, 2)) & StrReverse(Mid(vDesendiente, 1, UBound(mPoblacion) / 2))
Case 4
mPoblacion(i) = Mid(vDesendiente, (UBound(mPoblacion) / 2) + 1, 2) & Mid(vDesendiente, 1, UBound(mPoblacion) / 2)
End Select
mPuntuacion(i) = fFitness(mPoblacion(i)) 'Aleatorios(Numero_de_combinaciones, 1)
Next i
End If
End Sub
Private Sub cmdEvolucionar_Click()
prSolucionEncontrada = False
sEvolucionar
End Sub
Private Sub lstGenoma_DblClick()
Static vCont As Long
vCont = vCont + 1
If vCont > UBound(mGenoma) Then
vCont = 1
lstFenotipoElegido.Clear
End If
mCriterioDeSeleccion(vCont) = lstGenoma.List(lstGenoma.ListIndex)
lstFenotipoElegido.AddItem mCriterioDeSeleccion(vCont)
End Sub
Private Sub lstMejores_Click()
fMostrarFenotipo lstMejores
End Sub
Private Sub lstMejores_DblClick()
sCruzamientoManual lstMejores
End Sub
Private Sub lstMutacion_Click()
fMostrarFenotipo lstMutacion
End Sub
Private Sub lstMutacion_DblClick()
sCruzamientoManual lstMutacion
End Sub
Private Sub lstPoblacion_Click()
fMostrarFenotipo lstPoblacion
End Sub
Private Sub lstPoblacion_DblClick()
sCruzamientoManual lstPoblacion
End Sub
Private Sub sReproduccionMejoresVsPoblacion(Optional Numero_de_combinaciones = 0) 'Se efectua la reproduccion de los mejores individuos con el resto de la poblacion.
'On Error GoTo AccionesCorrectivas
If Numero_de_combinaciones > UBound(mPoblacion) Or Numero_de_combinaciones = 0 Then Numero_de_combinaciones = UBound(mPoblacion)
Dim vPadre As Long, vMadre As Long, i As Long, vDesendiente As Long
Dim vId_Mejores_nivel_superior As Long, vId_superiores_nivel_anidado As Long, vInterruptor As Boolean
For vId_Mejores_nivel_superior = LBound(mMejores) To UBound(mMejores) 'UBound(mPoblacion)
DoEvents
For vId_superiores_nivel_anidado = LBound(mMejores) To UBound(mMejores) 'UBound(mPoblacion)
DoEvents
If mMejores_puntuacion(vId_Mejores_nivel_superior) > mMejores_puntuacion(vId_superiores_nivel_anidado) Then
Select Case vInterruptor
Case False
vPadre = mMejores(vId_Mejores_nivel_superior)
mMejores(vId_Mejores_nivel_superior) = 0 'Solo se borra el id del padre para evitar seleccionarlo por segunda vez.
vInterruptor = True 'El interruptor lo garantiza.
Case True
vMadre = mMejores(vId_Mejores_nivel_superior)
mMejores(vId_Mejores_nivel_superior) = 0 'Es probable que borre todos los Ids. Ya no es necesario conservarlos.
'vInterruptor = True
End Select
End If
Next vId_superiores_nivel_anidado
Next vId_Mejores_nivel_superior
For i = LBound(mPoblacion) To Numero_de_combinaciones 'UBound(mPoblacion)
DoEvents
'vPadre = mMejores(Aleatorios(4, 1))
'vMadre = mPoblacion(Aleatorios(20, 1))
vDesendiente = Mid(vPadre, 1, 2) & Mid(vMadre, UBound(mPoblacion), UBound(mPoblacion) / 2)
Dim vReverse As Long
vReverse = Aleatorios(UBound(mPoblacion), 1)
Select Case vReverse
Case 1
mPoblacion(i) = vDesendiente
Case 2
mPoblacion(i) = StrReverse(vDesendiente)
Case 3
mPoblacion(i) = StrReverse(Mid(vDesendiente, (UBound(mPoblacion) / 2) + 1, UBound(mPoblacion) / 2)) & StrReverse(Mid(vDesendiente, 1, UBound(mPoblacion) / 2))
Case 4
mPoblacion(i) = Mid(vDesendiente, (UBound(mPoblacion) / 2) + 1, 2) & Mid(vDesendiente, 1, UBound(mPoblacion) / 2)
End Select
mPuntuacion(i) = Aleatorios(Numero_de_combinaciones, 1)
Next i
'Finalmente despues de esto los desendientes de los mejores se mezclan con el resto de la poblacion.
Exit Sub
'AccionesCorrectivas:
MsgBox "Tengo problemas con sReproduccionMejoresVsPoblacion"
End Sub
Public Function fMostrarFenotipo(Control As Object) As Variant 'Decodifica el genoma entero del individuo y muestra su fenotipo o informacion para el usuario.
'On Error Resume Next
Dim i As Long, vFenotipo As String
Select Case TypeName(Control)
Case "ListBox"
txtFenotipo.Text = fFenotipo(Control.List(Control.ListIndex))
Case "TextBox"
txtFenotipo.Text = fFenotipo(Control.Text)
End Select
fMostrarFenotipo = txtFenotipo.Text
Exit Function
'AccionesCorrectivas:
'MsgBox "Tengo problemas con fMostrarFenotipo"
End Function
Private Sub lstReemplazo_Click()
fMostrarFenotipo lstReemplazo
End Sub
Private Sub lstReemplazo_DblClick()
sCruzamientoManual lstReemplazo
End Sub
Private Sub lstRendimiento_Click()
fMostrarFenotipo lstRendimiento
End Sub
Private Sub lstRendimiento_DblClick()
sCruzamientoManual lstRendimiento
End Sub
Private Sub txtAdd_DblClick()
fMostrarFenotipo txtAdd
End Sub
Public Property Get prSolucionEncontrada() As Boolean 'True si la solucion ha sido encontrada.
On Error GoTo AccionesCorrectivas
prSolucionEncontrada = vSolucionEncontrada
Exit Property
AccionesCorrectivas:
MsgBox "Tengo problemas con prSolucionEncontrada"
End Property
Public Property Let prSolucionEncontrada(vNuevosDatos As Boolean) 'True si la solucion ha sido encontrada.
On Error GoTo AccionesCorrectivas
vSolucionEncontrada = vNuevosDatos
Exit Property
AccionesCorrectivas:
MsgBox "Tengo problemas con prSolucionEncontrada"
End Property
Public Sub sCruzamientoManual(ListBox_control As Object) 'Es cuando el usuario elige algunos habitantes de las listas para cruzarlos entre si.
On Error GoTo AccionesCorrectivas
Static vSumatoria As Long
If IsNumeric(ListBox_control.List(ListBox_control.ListIndex)) = True Then
vSumatoria = vSumatoria + 1
If vSumatoria > 20 Then vSumatoria = 1
mPoblacion(vSumatoria) = ListBox_control.List(ListBox_control.ListIndex)
End If 'IsNumeric
Exit Sub
AccionesCorrectivas:
MsgBox "Tengo problemas con sCruzamientoManual"
End Sub
Public Function fFenotipo(ByVal Genoma As Variant, Optional Ceparado_con_espacios As Boolean = False) As Variant 'Decodifica el genoma para mostrarlo.
'On Error GoTo AccionesCorrectivas
Dim i As Long, vFenotipo As String
If IsNumeric(Genoma) = True Then
For i = LBound(mGenoma) To UBound(mGenoma)
DoEvents
If Ceparado_con_espacios = False Then 'Se muestra la respuesta ceparada con saltos de linea.
vFenotipo = vFenotipo & fDecodificar(Val(Mid(Genoma, i, 1))) & RTC
Else 'Se muestra la respuesta ceparada con espacios.
vFenotipo = vFenotipo & fDecodificar(Val(Mid(Genoma, i, 1))) & " "
End If
Next i
i = 0
fFenotipo = vFenotipo
vFenotipo = ""
End If
Exit Function
'AccionesCorrectivas:
MsgBox "Tengo problemas con fFenotipo"
End Function
Public Function fFitness(ByVal Habitante As Long)
Dim v_Id_ADN As Long, vAciertos As Long
For v_Id_ADN = LBound(mGenoma) To UBound(mGenoma)
DoEvents
If fDecodificar(Mid(Habitante, v_Id_ADN, 1)) = mCriterioDeSeleccion(v_Id_ADN) Then
vAciertos = vAciertos + 1
End If
Next v_Id_ADN
fFitness = vAciertos
End Function
Crear cuenta
Comentarios sobre la versión: 1.0 (4)
Te comento que tu código esta excelente pero que la pasión de programar no nos haga olvidar la ortografía amigo mío asñi es como se escribe en realidad la palabra biológica no viologica que pasa?
Felicitaciones
aquí mismo.
es mi segunda publicación.