Дано: есть три уравнения кривых. Найти: пересечения кривых на заданном отрезке с помощью генетического алгоритма.
Код
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
В прикреплённом примере находится пользовательская функция для перевода из(в) различных систем счисления. Штатными функциями Excel достаточно просто переводить числа из десятичной, двоичной, восьмеричной и шестнадцатеричной систем. Для перевода, например, из 17-ричной в 23-ричную можно воспользоваться этой функцией. (Не спрашивайте меня "зачем?"
Код может работать с "условно" бесконечными системами. Сейчас в коде максимальная система с основанием 35. Для увеличения основания, дополните массив c = Array("0", ... значениями требуемой системы.
Код
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
Выкладываю пример с моделированием движения точки, находящейся между двух стенок: при постоянном ускорении по вертикали, при равномерной скорости по горизонтали.
Нашёл решение. Решил поделится. Может кому-то пригодится.
Проблема: При открытии книги возникает запрос на обновление связей. Хотя связей в книге нет (якобы). Не помогает "Разорвать связи" и не помогает удаление имён через "Диспетчер имён".
Возможная причина: Наличие связей в "Проверке данных".
Решение: "Данные" - "Работа с данными" - "Проверка данных" - "Проверка данных" - "Параметры" -"Тип данных" - установить "Любое значение". Ячейки, на которые установлена проверка данных, можно найти методом проб и ошибок - создать копию файла, удалять листы(ячейки) и проверять исчезли ли связи.