Código de Visual Basic - Algoritmo genetico artificial con 4 genes

Imágen de perfil
Val: 178
Ha disminuido 1 puesto en Visual Basic (en relación al último mes)
Gráfica de Visual Basic

Algoritmo genetico artificial con 4 genesgráfica de visualizaciones


Visual Basic

estrellaestrellaestrellaestrellaestrella(4)
Publicado el 22 de Septiembre del 2016 por Rafael Angel
3.592 visualizaciones desde el 22 de Septiembre del 2016
Código basado en la evolución biológica, búsqueda en paralelo, resolución de problemas en paralelo.
Código capaz de aprender por si solo a programar.

Requerimientos

vb6

1.0
estrellaestrellaestrellaestrellaestrella(4)

Publicado el 22 de Septiembre del 2016gráfica de visualizaciones de la versión: 1.0
3.593 visualizaciones desde el 22 de Septiembre del 2016
estrellaestrellaestrellaestrellaestrella
estrellaestrellaestrellaestrella
estrellaestrellaestrella
estrellaestrella
estrella

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
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



Comentarios sobre la versión: 1.0 (4)

Alexander Fernández Anderson
22 de Septiembre del 2016
estrellaestrellaestrellaestrellaestrella
Rafael Ángel mis saludos y mis respeto para ti amigo programador.
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
Responder
Imágen de perfil
25 de Septiembre del 2016
estrellaestrellaestrellaestrellaestrella
Estuve revisando esta vercion del codigo y logré optimizarla un poco más. Pero mejor publicaré el proyecto con un nuevo nombre.
Responder
Imágen de perfil
30 de Septiembre del 2016
estrellaestrellaestrellaestrellaestrella
OK Rafael, pero regálanos el link de donde lo publicas. Realmente en algún momento pense esta misma idea, solo que ya la estás desarrollando. Tremendo felicitaciones.
Responder
Imágen de perfil
11 de Octubre del 2016
estrellaestrellaestrellaestrellaestrella
http://www.lawebdelprogramador.com/codigo/Visual-Basic/3682-Algoritmo-genetico-con-6-genes.html

aquí mismo.
es mi segunda publicación.
Responder

Comentar la versión: 1.0

Nombre
Correo (no se visualiza en la web)
Valoración
Comentarios
Es necesario revisar y aceptar las políticas de privacidad

http://lwp-l.com/s3680