It's evolution, baby

[Мельхеор]

Сегодня вспоминал детство и Вижуал Базик
Написал программку симулирующую эволюцию символьных строк/

Желающие могут записать ее себе в Эксель и посмотреть как Brown Fox превращается в Lazy Dog всего за 100 итераций

Sub Evolve()

ActiveWorkbook.Sheets("Sheet1").Activate


Dim chance As Single
Dim tmp As Integer
Dim letter As String
Set Population = Range("A1:M40")
Dim PopSize As Integer
Dim Fitness() As Integer
Dim i As Integer
Dim Time As Integer
Dim response

Dim EmptySpace As Integer
Dim Strongest As Integer
Dim Weakest As Integer

Dim CurrentCell As String
Dim CurrentDad As Range
Dim CurrantMom As Range
Dim DadFitness As Integer
Dim CurrentKid As String
Dim Coefficient As Single
Dim TempCell As Range

Dim Strng As String

Initial = "BROWN FOX"
Final = "LAZY DOG"
MinDeathChance = 0.1
MaxDeathChance = 0.9
Mutation_Chance = 0.1


For Each Cell In Population
Cell.Value = Initial
Next Cell


'Initial population set. Start evolving.

For Time = 1 To 200

PopSize = Population.Cells.Count
ReDim Fitness(PopSize)
i = -1

'First, mutate

For Each Cell In Population
i = i + 1
chance = Rnd()
If (chance < Mutation_Chance) Then
tmp = Int(Rnd() * (Len(Cell.Value)))
Select Case chance
Case -1 To 0.033 'insertion
letter = Chr(65 + Int(Rnd() * 26))
If tmp > 0 Then
Cell.Value = Left(Cell.Value, tmp) & letter & Right(Cell.Value, Len(Cell.Value) - tmp)
Else
Cell.Value = letter & Cell.Value
End If
Case 0.034 To 0.066 'deletion
Cell.Value = Left(Cell.Value, tmp) & Right(Cell.Value, Len(Cell.Value) - tmp - 1)
Case 0.066 To 0.1 'substitution
letter = Chr(65 + Int(Rnd() * 26))
If tmp > 0 Then
Cell.Value = Left(Cell.Value, tmp) & letter & Right(Cell.Value, Len(Cell.Value) - tmp - 1)
Else
Cell.Value = letter & Right(Cell.Value, Len(Cell.Value) - 1)
End If
End Select
End If
Fitness(i) = Levenshtein(Cell, Final)
Next Cell


'Then Cull

Weakest = WorksheetFunction.Min(Fitness)
Strongest = WorksheetFunction.Max(Fitness)

For i = 0 To 519
Fitness(i) = Strongest - Fitness(i) + 1
Next

Weakest = WorksheetFunction.Min(Fitness)
Strongest = WorksheetFunction.Max(Fitness)
Delta = Strongest - Weakest
Coefficient = (MaxDeathChance - MinDeathChance) / Delta

i = -1
EmptySpace = 0

For Each Cell In Population
i = i + 1
chance = Rnd()
If Fitness(i) * Coefficient < chance Then
Cell.ClearContents
EmptySpace = EmptySpace + 1
Fitness(i) = 0
End If
Next

Coefficient = EmptySpace / WorksheetFunction.Sum(Fitness)
i = 0
DadFitness = 0

Do Until i > Population.Cells.Count
CurrentCell = Chr(65 + i Mod Population.Columns.Count) & CStr(i \ Population.Columns.Count + 1)
If Fitness(i) > 0 Then
If DadFitness > 0 And DadFitness <> Empty Then
Set CurrentMom = Range(CurrentCell)
CurrentKid = Left(CurrentDad.Value, Len(CurrentDad.Value) / 2) & Right(CurrentMom.Value, Len(CurrentMom.Value) / 2)
ProgenyNum = Round((Fitness(i) + DadFitness) * Coefficient, 0)
For j = 0 To Population.Cells.Count
Set TempCell = Range(Chr(65 + j Mod Population.Columns.Count) & CStr(j \ Population.Columns.Count + 1))
If TempCell.Value = "" And ProgenyNum > 0 Then
TempCell.Value = CurrentKid
ProgenyNum = ProgenyNum - 1
End If
Next j
Set CurrentDad = Nothing
DadFitness = 0
Else
Set CurrentDad = Range(CurrentCell)
DadFitness = Fitness(i)
End If
End If
i = i + 1
Loop

For Each Cell In Population
If Cell.Value = "" Then
Do Until TempCell.Value <> ""
j = Rnd() * 520
TempCell = Range(Chr(65 + j Mod Population.Columns.Count) & CStr(j \ Population.Columns.Count + 1))
Loop
Cell.Value = TempCell.Value
End If
Next


'If Time Mod 6 = 0 Then
' response = MsgBox(CStr(Time), vbYesNo)
' If response = vbNo Then
' Exit Sub
' End If
'End If

Next Time

End Sub

Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long

Dim i As Long, j As Long, bs1() As Byte, bs2() As Byte
Dim string1_length As Long
Dim string2_length As Long
Dim distance() As Long
Dim min1 As Long, min2 As Long, min3 As Long

string1_length = Len(string1)
string2_length = Len(string2)
ReDim distance(string1_length, string2_length)
bs1 = string1
bs2 = string2

For i = 0 To string1_length
distance(i, 0) = i
Next

For j = 0 To string2_length
distance(0, j) = j
Next

For i = 1 To string1_length
For j = 1 To string2_length
'slow way: If Mid$(string1, i, 1) = Mid$(string2, j, 1) Then
If bs1((i - 1) * 2) = bs2((j - 1) * 2) Then ' *2 because Unicode every 2nd byte is 0
distance(i, j) = distance(i - 1, j - 1)
Else
'distance(i, j) = Application.WorksheetFunction.Min _
(distance(i - 1, j) + 1, _
distance(i, j - 1) + 1, _
distance(i - 1, j - 1) + 1)
' spell it out, 50 times faster than worksheetfunction.min
min1 = distance(i - 1, j) + 1
min2 = distance(i, j - 1) + 1
min3 = distance(i - 1, j - 1) + 1
If min1 <= min2 And min1 <= min3 Then
distance(i, j) = min1
ElseIf min2 <= min1 And min2 <= min3 Then
distance(i, j) = min2
Else
distance(i, j) = min3
End If

End If
Next
Next

Levenshtein = distance(string1_length, string2_length)

End Function


Правда, Левинштейна писал я не сам а честно стырил. Без него впрочем можно обойтись например использовав как меру корень квадратный из суммы квадратов побуквенных дистанций.
Олсо, если кто-то из читающих сам программирует и имеет мысли как эту штуку сделать лучше - я открыт для предложений.