Algoritmo genetico binario

INSTITUTO TECNOLÓGICO DE CHIHUAHUA II

Inteligencia artificial 2

Nombre: David Humberto Orquiz Ruelas

Número de Control: 07550466

Carrera: ISC

Tema: Algoritmo Genético Binario

Se implementara un algoritmo genético para obtener el valor mínimo de la siguiente función:

f(x,y)=4x2 +7(y −4)2 −4x +3y Las restricciones serán las siguientes:

0≤x≤150≤y≤15Nipop = 32Reproducción= RankWeightingCruce LibreConvergencia LibreSin mutación

El algoritmo será realizado en Microsoft office Excel 2007.

En la hoja numero 1 se generaran los números aleatorios para generar los cromosomas utilizados en el algoritmo. Con la formula “=ALEATORIO.ENTRE (0,1)” se llenaran las columnas necesarias para generar un numero binario con las restricciones antes mencionadas, y así será para generar los 32 que serán los valores de x en el cromosoma, así mismo se realizara el procedimiento para generar los números binarios para y.

Se insertaran dos botones los cuales copiaran los números binarios de 4 digitos generados y los pegara en la hoja siguiente, ( este procedimiento se realiza dado

a que los números aleatorios se recalculan cada vez que se realiza una acción y hay que hacer un pegado especial para que esto no ocurra)

El código de los botones será el siguiente:

Sub Botón1_Haga_clic_en ()

'copiar números aleatorios para formar los cromosomas de la primer variable.

Range ("g2", "g33" & fila).Copy

Sheets ("hoja3").Select

Range ("c4").PasteSpecial Paste:=xlValues

Application.CutCopyMode = True


End Sub

Sub Botón6_Haga_clic_en ()

'copiar números aleatorios para formar los cromosomas de la segunda variable.

Range ("g36", "g67" & fila).Copy


Range ("d4").PasteSpecial Paste:=xlValues


End Sub

Se creara una tabla en la siguiente hoja para calcular los valores en decimal y sacar el costo con la función dada en las restricciones para el algoritmo.

Para sacar el valor decimal de x y de y se usara la siguiente fórmula:

“ =BIN.A.DEC (C4)” y ” =(4*E4^2)+(7*((F4-4)^2))-4*E4+3*F4” para calcular el costo.

El código para los botones mostrados en la imagen es el siguiente:

Sub Hoja3_Botón2_Haga_clic_en()

'copiar tabla.

Range("b4", "g35").Copy

'ActiveSheet.Next.Select

Sheets("hoja4").Select

Range("b17").PasteSpecial

End Sub

Sub Botón3_Haga_clic_en()

‘Npop.

Range("r1").Copy

Range("t1").PasteSpecial Paste:=xlValues


Range("c4").Select

Dim a As String

Dim b As String

a = Range("g17").Value

b = Range("u1").Value


Range("g17", b & fila).Copy

Range("h17").PasteSpecial Paste:=xlValues


'Range("c1").Select

End Sub


'Ngood.

Range("v1").Copy

Range("x1").PasteSpecial Paste:=xlValues


Range("c4").Select

Dim a As String

Dim b As String

a = Range("h17").Value

b = Range("y1").Value


Range("h17", b & fila).Copy

Range("i17").PasteSpecial Paste:=xlValues


'Range("c1").Select

End Sub

En el botón ejecutar se encuentra el siguiente código en el cual se encuentran los procedimientos anteriores para que se ejecuten con solo presionarlo y no tener que hacerlo botón por botón.

En la hoja siguiente se tendrán botones con el siguiente código que al igual que los anteriores van a ejecutarse también en el botón ejecutar.


Dim iRow As Integer

Dim i As Integer

Dim j As Integer

Dim k As Integer

b = 1

a = 1

k = 1

iRow = Range("l6").Value

For b = 1 To iRow

If Cells(a + 16, 14).Value >= Cells(b + 16, 15).Value Then

Cells(b + 16, 16).Value = Cells(a + 16, 18).Value

a = 1

Else

a = a + 1

b = b - 1

End If

Next

End Sub


Range("l17", "l48" & fila).Copy

Range("o17").PasteSpecial Paste:=xlValues

'aleatorio para cruce

Range("ab1").Copy

Range("ac1").PasteSpecial Paste:=xlValues

End Sub


'copiar tabla hijos.

Range("az17", "bd80").Copy


Range("be17").PasteSpecial Paste:=xlValues

End Sub


'ordenar.


Range("be17:bj80").Select

Selection.Sort Key1:=Range("bi17"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

End Sub

El siguiente botón contiene el código encargado de generar cada iteración en el algoritmo hasta encontrar el valor mínimo de la función.


Dim iter As Integer

For iter = 1 To 1000

Cells(iter + 16, 69).Value = Cells(17, 5).Value



'copiar tabla.

'

Sheets.Add

ActiveSheet.Next.Select

Range("a1", "bs81").Copy

ActiveSheet.Previous.Select

'ActiveSheet.Previous.Select

'Sheets("hoja4").Select

Range("a1").PasteSpecial

ActiveSheet.Next.Select

'Range("be17", "bj81").Copy

ActiveSheet.Previous.Select

'Range("c17").PasteSpecial

''''''''''

''''''''''''''''''''''

''''''''''''''''''''''

'''copiar tabla hijos.

a = Range("g17").Value

b = Range("u2").Value


Range("be17", "bj48").Copy

Range(b).PasteSpecial Paste:=xlValues


Range("b48", "b100").Clear

'''''

''''

Range("v17", "v48").Copy

Range("w17", "w48").PasteSpecial Paste:=xlValues


''''''''''''''''''''''

''''''''''''''''''''''

''''''''''''''''''''''

'ordenar nueva tabla

Range("b16:g48").Select

Selection.Sort Key1:=Range("g16"), Order1:=xlAscending, Header:=xlGuess, _



''''''''''''''''''''''

''''''''''''''''''''''

'copiar aleatorios

Range("r1").Copy

Range("t1").PasteSpecial Paste:=xlValues


''''''''''

'''''''''

'copiar aleatorios.

Range("v1").Copy

Range("x1").PasteSpecial Paste:=xlValues


''''''''''''''''''''''

'npop

Dim e As String

Dim f As String

Dim ff As String

e = Range("g17").Value

f = Range("u1").Value

ff = Range("u3").Value


Range("g17", f & fila).Copy

Range("h17").PasteSpecial Paste:=xlValues


Range(ff, "h50").ClearContents

'Range("c1").Select

'Ngood.

Dim c As String

Dim d As String

Dim dd As String

c = Range("h17").Value

d = Range("y1").Value

dd = Range("y2").Value


Range("h17", d & fila).Copy

Range("i17").PasteSpecial Paste:=xlValues


Range(dd, "i50").ClearContents

'Range("c1").Select

''''''''''''

'''''''''''''''

'''''''''''''''''''

Range("l17", "l48" & fila).Copy

Range("o17").PasteSpecial Paste:=xlValues

'aleatorio para cruce

Range("ab1").Copy

Range("ac1").PasteSpecial Paste:=xlValues

'metodo rank weighting

Dim iRow As Integer

Dim i As Integer

Dim j As Integer

Dim k As Integer

i = 1

j = 1

k = 1

iRow = Range("l6").Value

For i = 1 To iRow

If Cells(j + 16, 14).Value >= Cells(i + 16, 15).Value Then

Cells(i + 16, 16).Value = Cells(j + 16, 18).Value

j = 1

Else

j = j + 1

i = i - 1

End If

Next

Dim gg As String

gg = Range("n6").Value

Range(gg, "p50").ClearContents

''''''''''''''

'copiar tabla hijos.

Range("az17", "bd80").Copy

Range("be17").PasteSpecial Paste:=xlValues

''''''''''''

''''''''''''''''

'ordenar.

Range("be17:bj80").Select

Selection.Sort Key1:=Range("bi17"), Order1:=xlAscending, Header:=xlGuess, _



If Range("bn17") = Range("g17") Then

Range("bo17", "bs81").Copy

Sheets.Add

Range("a1").PasteSpecial

On Error Resume Next

'Ocultamos el procedimiento

Application.ScreenUpdating = False

'copiamos la hoja activa en un nuevo libro

ActiveSheet.Copy

'copiamos y pegamos los valores

Cells.Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPaste

'Nos quedamos con el nombre del

'fichero y la ruta donde está

fichero = ThisWorkbook.Name

ruta = ThisWorkbook.Path

'Quitamos la extenxión de excel

fichero = Replace(fichero, ".xlsx", "")

fichero = Replace(fichero, ".xls", "")

'seleccionamos la hoja activa

ActiveSheet.Select

'omitimos los mensajes de aviso

Application.DisplayAlerts = False

'guardamos el fichero de texto acomodado

'en el mismo directorio donde tenemos el

'fichero de excel normal

ActiveWorkbook.SaveAs Filename:=ruta & "\" & "salida" & ".txt", FileFormat:=xlText

'cerramos el fichero de texto

ActiveWorkbook.Close

'Mostramos el procedimiento

Application.ScreenUpdating = True

End If

If Range("bn17") = Range("g17") Then Exit For

Next

''''''''''

End Sub

Algunas de las celdas van a tener formulas para agilizar el trabajo del algoritmo, (hay columnas auxiliares). A continuación se enlistara la columna con la formula insertada en cada una de sus celdas.

Nbada. =SI(H17<>I17,H17)

Nbad =K.ESIMO.MENOR($J$17:$J$48,R17)

Ngood*al =ALEATORIO()

Pn formula =($L$6-R17+1)/SI(R17<=$L$6,((($L$6+1)/2)*$L$6))

PN acumulado =M17

Ngood =I:I

X =BUSCAR(S17,I:I,C:C)

Y =BUSCAR(S17,I:I,D:D)

Col v =ALEATORIO.ENTRE(2,7)

Col x =SI(R17*2<=$L$6,2*R17-1,FALSO)

Padre =BUSCAR(X17,R:R,P:P)

x =BUSCAR(Y17,R:R,T:T)

y =BUSCAR(Y17,R:R,U:U)

col AB =SI(R17*2<=$L$6,2*R17,FALSO)

Padre2 =BUSCAR(AB17,R:R,P:P)

X =BUSCAR(AC17,R:R,T:T)

Y =BUSCAR(AC17,R:R,U:U)

Padre1 =Z17&AA17

Padre2 =AD17&AE17

Padre1a =EXTRAE(AF17,1,W17-1)

Padre1b =EXTRAE(AF17,W17,8)

Padre2a =EXTRAE(AG17,1,W17-1)

Padre2b =EXTRAE(AG17,W17,8)

Hijo1 =AH17&AK17

Hijo2 =AJ17&AI17

Xhijo1 =EXTRAE(AM17,1,4)

Yhijo1 =EXTRAE(AM17,5,8)

Decimalx1 =BIN.A.DEC(AO17)

Decimaly2 =BIN.A.DEC(AP17)

Xhijo2 =EXTRAE(AN17,1,4)

Yhijo2 =EXTRAE(AN17,5,8)

Decimalx1 =BIN.A.DEC(AS17)

Decimaly2 =BIN.A.DEC(AT17)

Costo1 =(4*AQ17^2)+(7*((AR17-4)^2))-4*AQ17+3*AR17

Costo2 =(4*AU17^2)+(7*((AV17-4)^2))-4*AU17+3*AV17

Xhijo1 =AO17

Yhijo1 =AP17

Decimalx1 =AQ17

Decimaly2 =AR17

Costo1 =AW17

Col BJ =SI.ERROR(BI17,FALSO)

Número menor =K.ESIMO.MENOR(BJ17:BJ81,BK17)

Col BM =SI.ERROR(SI(G17=0,"",G17),"")

Promedio =PROMEDIO(BM:BM)

Col BO =SI(BQ17>0,DEC.A.BIN(BQ17,4),SI(BQ17=0,""))

Col BP =SI(BR17>0,DEC.A.BIN(BR17,4),SI(BR17=0,""))

Todos los métodos de los botones anteriores sirven para realizar paso por paso el algoritmo.

Para ejecutar el algoritmo desde que abrimos el documento y para que sean creados los archivos .txt se agregan en un botón que se muestra con un mensaje justo al activar los macros de Excel. El código del botón principal es el siguiente:

Sub auto_open()

Dim Mensaje, Estilo, Título, Ayuda, Ctxt, Respuesta, MiCadena

Mensaje = "¿Desea continuar?" ' Define el mensaje.

Estilo = vbYesNo + vbCritical + vbDefaultButton2 ' Define los botones.

Título = "Demostración de MsgBox" ' Define el título.

Ayuda = "DEMO.HLP" ' Define el archivo de ayuda.

Ctxt = 1000 ' Define el tema

' el contexto

' Muestra el mensaje.

Respuesta = MsgBox(Mensaje, Estilo, Título, Ayuda, Ctxt)

If Respuesta = vbYes Then

''''

'copiar numeros aleatorios para formar los cromosomas de la primer variable.

Range("g2", "g33" & fila).Copy


Range("c4").PasteSpecial Paste:=xlValues



'''

'copiar numeros aleatorios para formar los cromosomas de la segunda variable.

Range("g36", "g67" & fila).Copy


Range("d4").PasteSpecial Paste:=xlValues


'''

On Error Resume Next

'Ocultamos el procedimiento

Application.ScreenUpdating = False

'copiamos la hoja activa en un nuevo libro

ActiveSheet.Copy

'copiamos y pegamos los valores

Cells.Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPaste

'Nos quedamos con el nombre del

'fichero y la ruta donde está

fichero = ThisWorkbook.Name

ruta = ThisWorkbook.Path

'Quitamos la extenxión de excel

fichero = Replace(fichero, ".xlsx", "")

fichero = Replace(fichero, ".xls", "")

'seleccionamos la hoja activa

ActiveSheet.Select

'omitimos los mensajes de aviso

Application.DisplayAlerts = False

'guardamos el fichero de texto acomodado

'en el mismo directorio donde tenemos el

'fichero de excel normal

ActiveWorkbook.SaveAs Filename:=ruta & "\" & "poblacioninIcial" & ".txt", FileFormat:=xlText

'cerramos el fichero de texto

ActiveWorkbook.Close

'Mostramos el procedimiento

Application.ScreenUpdating = True

Application.OnTime Now + TimeValue("00:00:001"), "Hoja3_Botón2_Haga_clic_en"


Application.OnTime Now + TimeValue("00:00:003"), "Botón3_Haga_clic_en"








''''''''

Else

Range("A1").Select

End If

End Sub

Al terminar las iteraciones se generaran dos archivos de texto, el primero con el nombre” poblacionInicial”, en el se encontrara la tabla con los primeros cromosomas y sus costos que fueron creados con la unión de números aleatorios entre 0 y 1. El segundo archivo de texto se llamara “Salida” y en él se encontraran los cromosomas con el menor costo de cada iteración.

En conclusión se obtiene que al generar nuevos descendientes de una población aleatoria podemos encontrar el resultado que estemos buscando, ya sea el mínimo de una ecuación, el máximo de una ecuación u otros resultados que estemos buscando.

Algoritmo genetico binario

Documents

Transcript of Algoritmo genetico binario