Option Explicit
'
Const N = 10
Const MAX_ITERATION = 200
Const NO_CHANGE_MAX_ITERATION = 100
'
'type TT = array[1..10] of longint;
'     DD = array[1..10] of real;
'     BB = array[0..16] of byte;
'
Private arr As Variant
Private flag As Boolean
Private i_iteration As Integer
Private no_change_iteration As Integer
Private write_file As Byte
Private write_screen As Byte
Private cur_maxF As Double
Private prev_maxF As Double
Private max_F As Double
Private max_x As Double
Private max_n As Long


Function F(x As Double) As Double
    F = x * Sin(x + 5) * Cos(x - 6) * Sin(x + 7) * Cos(x - 8) * Sin(x / 3)
End Function

Function X_to_N(x As Double) As Long
    X_to_N = Round((2 ^ 14) * x, 0)
End Function
'
Function N_to_X(x As Long) As Double
    N_to_X = x / (2 ^ 14)
End Function

Function Fn(ByVal N As Long) As Double
    Fn = F(N_to_X(N))
End Function


Sub My_write_screen(arr As Variant)
    Dim ii As Long
    Dim brr As Variant
    ReDim brr(1 To UBound(arr), 1 To 3)
    For ii = 1 To UBound(brr, 1)
        brr(ii, 1) = arr(ii)
        brr(ii, 2) = arr(ii) / (2 ^ 14)
        brr(ii, 3) = Fn(arr(ii))
    Next
    ThisWorkbook.Sheets(1).Cells(1, 5).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

Sub My_write_file(arr As Variant)

End Sub

Sub InitArray(arr As Variant)
    Dim ii As Long
    ReDim arr(1 To N)
    For ii = 1 To N
        arr(ii) = (ii - 1) * 65536 \ N + CLng(Rnd() * 65536 / N)
        If arr(ii) > 65536 Then arr(ii) = 65536
    Next
End Sub

Function Get_max_F(arr As Variant, max_n As Long) As Double ' {максимальное значение функции на массиве из 10 точек}
    Dim ii As Integer
    Dim m As Double
    m = Fn(arr(1))
    max_n = arr(1)
    For ii = 2 To N
        If m < Fn(arr(ii)) Then
            m = Fn(arr(ii))
            max_n = arr(ii)
        End If
    Next
    Get_max_F = m
End Function


Sub mySort(drr As Variant, arr As Variant)   ' {сортировка популяции по возрастанию значений функции}
    Dim ii As Integer
    Dim jj As Integer
    Dim k As Double
    Dim p As Long
    For ii = N To 2 Step -1
        For jj = 1 To ii - 1
            If drr(jj) > drr(jj + 1) Then
                k = drr(jj)
                drr(jj) = drr(jj + 1)
                drr(jj + 1) = k
                p = arr(jj)
                arr(jj) = arr(jj + 1)
                arr(jj + 1) = p
            End If
        Next
    Next
End Sub

Sub Fill_drr(drr As Variant, arr As Variant) ' {массив значений функции}
    ReDim drr(LBound(arr) To UBound(arr))
    Dim ii As Integer
    For ii = 1 To N
        drr(ii) = Fn(arr(ii))
    Next
End Sub

Function dec_to_bin(dec As Long) As Variant ' {перевод в двоичку}
    Dim bin As Long
    Dim rank As Long
    Dim modulo As Long
    Dim irank As Long
    Dim arr As Variant
    ReDim arr(0 To 16)
    
    For bin = 0 To 16
        arr(bin) = 0
    Next

    bin = 0
    rank = 1
    irank = 0
    
    While dec > 0
        modulo = dec Mod 2
        dec = dec \ 2
        'bin = bin + modulo * rank
        arr(irank) = modulo
        'rank = rank * 10
        irank = irank + 1
    Wend
    
    dec_to_bin = arr
End Function

Sub mySelection(arr As Variant) ' {отбор усечением}
    Dim drr As Variant
    Dim ii As Integer
    Fill_drr drr, arr
    mySort drr, arr ' {сортировка популяции по возрастанию значений функции}
    For ii = 1 To 5
        arr(ii) = arr(N - ii + 1)
    Next
End Sub
'
'
Function Get_Separation_Point(d1 As Variant, d2 As Variant) As Byte ' {выбирается одна точка для обмена частями между двумя числами}
    Dim ii As Integer
    Dim flag As Boolean
    
    flag = True
    ii = 16
    While flag
        If d1(ii) <> d2(ii) Then
            flag = False
        Else
            ii = ii - 1
            If ii = 0 Then flag = False
        End If
    Wend
    Get_Separation_Point = ii * Rnd
End Function

Function bin_to_dec(d3 As Variant) As Long
    Dim ii As Byte
    Dim res As Long
    Dim rank As Long
    res = 0
    rank = 1
    For ii = 0 To 16
        res = res + d3(ii) * rank
        rank = rank * 2
    Next
    bin_to_dec = res
End Function


Sub Mutation(d3 As Variant)
    Dim ii As Integer
    Dim jj As Integer
    Dim flag As Boolean
    If Rnd > 0.1 Then '{реверс битовой строки}
        flag = True
        ii = 16
        While flag '{ищем первую единицу с большего разряда}
            If d3(ii) = 1 Then
                flag = False
            Else
                ii = ii - 1
                If ii = 0 Then flag = False
            End If
        Wend
        ii = ii + 2
        If ii > 16 Then ii = 16

        jj = CInt(Rnd() * ii) ' {выбираем точку, до которой проводим реверс}
        d3(jj) = 1 - d3(jj) ' {реверс}
    Else  '{с какой то вероятностью проводим мутацию - изменение случайно выбранного бита}
        For ii = 0 To 16
            d3(ii) = CInt(Rnd())
        Next
    End If
End Sub

Sub Pair_Cross_Result(ByVal n1 As Long, ByVal n2 As Long, child1 As Long, child2 As Long) ' {результат скрещивания двух чисел}
    Dim d1 As Variant
    Dim d2 As Variant
    Dim d3 As Variant
    Dim d4 As Variant
    Dim separation_point As Byte
    Dim ii As Byte
    Dim k As Long
    
    d1 = dec_to_bin(n1) ' {родитель 1 в двоичном коде}
    d2 = dec_to_bin(n2) ' {родитель 2 в двоичном коде}

    ReDim d3(LBound(d1) To UBound(d1))
    ReDim d4(LBound(d1) To UBound(d1))

    separation_point = Get_Separation_Point(d1, d2)

'    {d3 результат скрещивания}
    For ii = 0 To separation_point
        d3(ii) = d2(ii)
        d4(ii) = d1(ii)
    Next

    For ii = separation_point + 1 To 16
        d3(ii) = d1(ii)
        d4(ii) = d2(ii)
    Next

    Mutation d3
    Mutation d4
    
    k = bin_to_dec(d3)
    If k > 65536 Then k = 65536
    child1 = k

    k = bin_to_dec(d4)
    If k > 65536 Then k = 65536
    child2 = k
End Sub
'
'
'
Sub Crossing(arr As Variant) ' {однородное скрещивание}
    Dim ii As Integer
    Dim jj As Integer
    Dim nstep As Long
    Dim brr As Variant
    Dim child1 As Long
    Dim child2 As Long
    Dim flag As Boolean

    ReDim brr(LBound(arr) To UBound(arr))
    For ii = 1 To 10
        brr(ii) = -1
    Next

    For ii = 1 To 10
        If brr(ii) = -1 Then
            flag = True
            nstep = 0
            While flag
                jj = (N - 1) * Rnd() + 1 ' {выберает второго родителя рандомно в массиве arr}
                If jj > N Then jj = N
                If (ii <> jj) And (brr(jj) = -1) Then flag = False
                nstep = nstep + 1
                If nstep = 20 Then flag = False
            Wend
            Pair_Cross_Result arr(ii), arr(jj), child1, child2
            brr(ii) = child1
            brr(jj) = child2
        End If
    Next

    For ii = 1 To 10
        If brr(ii) = -1 Then
            Pair_Cross_Result arr(ii), arr(ii), child1, child2 ' {скрещивание ничего не даст, но есть мутация}
            brr(ii) = child1
        End If
    Next
    
    arr = brr
End Sub

Sub Main()

    Randomize

    write_screen = 1
    write_file = 0

    InitArray arr

    i_iteration = 0
    no_change_iteration = 0
    prev_maxF = Get_max_F(arr, max_n)
    flag = True
    While flag
        If i_iteration > MAX_ITERATION Then
            flag = False
        Else
            If no_change_iteration > NO_CHANGE_MAX_ITERATION Then
                flag = False
            Else
'                {оценка всей популяции}
                cur_maxF = Get_max_F(arr, max_n)
                If prev_maxF < cur_maxF Then
                    prev_maxF = cur_maxF
                    no_change_iteration = 0
                Else
                    no_change_iteration = no_change_iteration + 1
                    If prev_maxF > 0.412 Then
                        flag = False
                    Else
                    mySelection arr
                    Crossing arr
                    End If
                End If
            End If
            i_iteration = i_iteration + 1
        End If
       
        If write_screen = 1 Then My_write_screen arr
        If write_file = 1 Then My_write_file arr
    Wend

    max_F = Get_max_F(arr, max_n) ' { max_F - максимальное найденное значение функции; max_n - значение n при котором достигается max_F}
    max_x = N_to_X(max_n) ' {переводим max_n в x}
    
    With ThisWorkbook.Sheets(1).Range("J1")
        .Cells(1, 1).Value = max_x
        .Cells(2, 1).Value = max_F
        .Cells(3, 1).Value = i_iteration
    End With

End Sub

Option Explicit

Private Sub Lab_Refresh_Click()
    myRefresh
End Sub

Private Sub ListBox1_Click()
    If UserForm_EnableEvents = False Then Exit Sub
    On Error Resume Next
    Sheets(CStr(ListBox1.Value)).Select
End Sub

Private Sub UserForm_Initialize()
    'If UserForm_EnableEvents = False Then Exit Sub
    myRefresh
    
    flagPeriodicalShow = True
'    UserFormPeriodicalShow
End Sub

Private Sub UserForm_Terminate()
    flagPeriodicalShow = False
End Sub

Private Sub myRefresh()
    Dim ii As Long
    UserForm_EnableEvents = False
    
    With Me.ListBox1
        For ii = 1 To .ListCount
            .RemoveItem 0
        Next
    End With
    With ActiveWorkbook
        For ii = 1 To .Sheets.Count
            Me.ListBox1.AddItem .Sheets(ii).Name
            '.Sheets(ii).Name = "sss" & ii
            If .Sheets(ii).Index = ActiveSheet.Index Then
                Me.ListBox1.Selected(ii - 1) = True
            End If
        Next
    End With
    'ii = ii - 1
    If ii > 51 Then ii = 51
    Me.ListBox1.IntegralHeight = False
    Me.ListBox1.Height = 9.7 * ii
    Me.Height = 9.7 * ii + 35


    UserForm_EnableEvents = True
End Sub

Function СистемаСчисления(Число As String, Optional СистемаИз As Byte = 10, Optional СистемаВ As Byte = 10)
    Dim d As Double
    Dim i As Integer
    Dim s As String
    Dim c As Variant
    Dim z As Long
    Dim k As Byte
    
    c = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    
    If Число = "0" Then
       СистемаСчисления = "0"
    Else
        'преобразование цифры в число
        d = 0
        For i = 1 To Len(Число)
            s = Mid(UCase(Число), i, 1)
            
            k = 0
            Do
                If s = c(k) Then
                    d = d + k * СистемаИз ^ (Len(Число) - i)
                    Exit Do
                End If
                k = k + 1
                If k > UBound(c) Then Exit Do
            Loop
        Next
        
        'преобразование числа в цифру
        s = ""
        For i = Val(Log(d) / Log(СистемаВ)) To 0 Step -1
            z = СистемаВ ^ i
            k = Val(d / z)
            
            s = s & c(k)
            d = d - k * z
        Next
        
        СистемаСчисления = s
    End If
End Function