Attribute VB_Name = "NeoMutations" Option Explicit '1-(perbot+1)^(1/DNALength) = per unit '1-(1-perunit)^DNALength = perbot Public Const PointUP As Integer = 0 'expressed as 1 chance in X per kilocycle per bp Public Const MinorDeletionUP As Integer = 1 Public Const ReversalUP As Integer = 2 Public Const InsertionUP As Integer = 3 Public Const AmplificationUP As Integer = 4 Public Const MajorDeletionUP As Integer = 5 Public Const CopyErrorUP As Integer = 6 Public Const DeltaUP As Integer = 7 Public Const TranslocationUP As Integer = 8 Public Const P2UP As Integer = 9 'Botsareus 12/10/2013 new mutation rates Public Const CE2UP As Integer = 10 Private overtime As Long 'Botsareus 6/11/2014 Causes the loop to stop at some point Private Function MutationType(thing As Integer) As String MutationType = "" Select Case thing Case 0 MutationType = "Point Mutation" Case 1 MutationType = "Minor Deletion" Case 2 MutationType = "Reversal" Case 3 MutationType = "Insertion" Case 4 MutationType = "Amplification" Case 5 MutationType = "Major Deletion" Case 6 MutationType = "Copy Error" Case 7 MutationType = "Delta Mutation" End Select End Function 'NEVER allow anything after end, which must be = DNALen 'ALWAYS assume that DNA is sized right 'ALWAYS size DNA correctly when mutating Private Function EraseUnit(ByRef unit As block) unit.tipo = -1 unit.value = -1 End Function Public Function MakeSpace(ByRef DNA() As block, ByVal beginning As Long, ByVal Length As Long, Optional DNALength As Integer = -1) As Boolean 'add length elements after beginning. Beginning doesn't move places 'returns true if the space was created, 'false otherwise Dim t As Integer If DNALength < 0 Then DNALength = DnaLen(DNA) If Length < 1 Or beginning < 0 Or beginning > DNALength - 1 Or (DNALength + Length > 32000) Then MakeSpace = False GoTo getout End If MakeSpace = True ReDim Preserve DNA(DNALength + Length) For t = DNALength To beginning + 1 Step -1 DNA(t + Length) = DNA(t) EraseUnit DNA(t) overtime = overtime - 1 Next t getout: End Function Public Sub Delete(ByRef DNA() As block, ByRef beginning As Long, ByRef elements As Long, Optional DNALength As Integer = -1) 'delete elements starting at beginning Dim t As Integer If DNALength < 0 Then DNALength = DnaLen(DNA) If elements < 1 Or beginning < 1 Or beginning > DNALength - 1 Then GoTo getout ' If elements + beginning > DNALength - 1 Then elements = DNALength - 1 - beginning For t = beginning + elements To DNALength On Error GoTo step2 'small error mod DNA(t - elements) = DNA(t) Next t step2: DNALength = DnaLen(DNA) ReDim Preserve DNA(DNALength) getout: End Sub Public Function NewSubSpecies(n As Integer) As Integer Dim i As Integer i = SpeciesFromBot(n) ' Get the index into the species array for this bot SimOpts.Specie(i).SubSpeciesCounter = SimOpts.Specie(i).SubSpeciesCounter + 1 ' increment the counter If SimOpts.Specie(i).SubSpeciesCounter > 32000 Then SimOpts.Specie(i).SubSpeciesCounter = -32000 'wrap the counter if necessary NewSubSpecies = SimOpts.Specie(i).SubSpeciesCounter End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub Mutate(ByVal robn As Integer, Optional reproducing As Boolean = False) 'Botsareus 12/17/2013 Dim Delta As Long With rob(robn) If Not .Mutables.Mutations Or SimOpts.DisableMutations Then GoTo getout Delta = CLng(.LastMut) ismutating = True 'Botsareus 2/2/2013 Tells the parseor to ignore debugint and debugbool while the robot is mutating If Not reproducing Then overtime = UBound(rob(robn).DNA) ^ (1 / 3) * 3000 If .Mutables.mutarray(PointUP) > 0 Then PointMutation robn If .Mutables.mutarray(DeltaUP) > 0 And Not Delta2 Then DeltaMut robn If .Mutables.mutarray(P2UP) > 0 And sunbelt Then PointMutation2 robn 'special case update epigenetic reset If CLng(.LastMut) - Delta > 0 And epireset Then .MutEpiReset = .MutEpiReset + (CLng(.LastMut) - Delta) ^ epiresetemp 'Delta2 point mutation change If Delta2 And DeltaPM > 0 Then If .age Mod DeltaPM = 0 And .age > 0 Then Dim MratesMax As Long MratesMax = IIf(NormMut, CLng(.DnaLen) * CLng(valMaxNormMut), 2000000000) Dim t As Byte For t = 0 To 9 Step 9 'Point and Point2 If .Mutables.mutarray(t) < 1 Then GoTo skip 'Botsareus 1/3/2014 if mutation off then skip it If Rnd < DeltaMainChance / 100 Then If DeltaMainExp <> 0 Then .Mutables.mutarray(t) = .Mutables.mutarray(t) * 10 ^ ((Rnd * 2 - 1) / DeltaMainExp) .Mutables.mutarray(t) = .Mutables.mutarray(t) + (Rnd * 2 - 1) * DeltaMainLn If .Mutables.mutarray(t) < 1 Then .Mutables.mutarray(t) = 1 If .Mutables.mutarray(t) > MratesMax Then .Mutables.mutarray(t) = MratesMax End If If Rnd < DeltaDevChance / 100 Then If DeltaDevExp <> 0 Then .Mutables.StdDev(t) = .Mutables.StdDev(t) * 10 ^ ((Rnd * 2 - 1) / DeltaDevExp) .Mutables.StdDev(t) = .Mutables.StdDev(t) + (Rnd * 2 - 1) * DeltaDevLn If DeltaDevExp <> 0 Then .Mutables.Mean(t) = .Mutables.Mean(t) * 10 ^ ((Rnd * 2 - 1) / DeltaDevExp) .Mutables.Mean(t) = .Mutables.Mean(t) + (Rnd * 2 - 1) * DeltaDevLn 'Max range is always 0 to 800 If .Mutables.StdDev(t) < 0 Then .Mutables.StdDev(t) = 0 If .Mutables.StdDev(t) > 200 Then .Mutables.StdDev(t) = 200 If .Mutables.Mean(t) < 1 Then .Mutables.Mean(t) = 1 If .Mutables.Mean(t) > 400 Then .Mutables.Mean(t) = 400 End If skip: Next .Mutables.PointWhatToChange = .Mutables.PointWhatToChange + (Rnd * 2 - 1) * DeltaWTC If .Mutables.PointWhatToChange < 0 Then .Mutables.PointWhatToChange = 0 If .Mutables.PointWhatToChange > 100 Then .Mutables.PointWhatToChange = 100 .Point2MutCycle = 0 .PointMutCycle = 0 End If End If Else overtime = UBound(rob(robn).DNA) ^ (1 / 3) * 3000 If .Mutables.mutarray(CopyErrorUP) > 0 Then CopyError robn If overtime < 0 Then Exit Sub If .Mutables.mutarray(CE2UP) > 0 And sunbelt Then CopyError2 robn If overtime < 0 Then Exit Sub If .Mutables.mutarray(InsertionUP) > 0 Then Insertion robn If overtime < 0 Then Exit Sub If .Mutables.mutarray(ReversalUP) > 0 Then Reversal robn If overtime < 0 Then Exit Sub If .Mutables.mutarray(TranslocationUP) > 0 And sunbelt Then Translocation robn 'Botsareus Translocation and Amplification still bugy, but I want them. If .Mutables.mutarray(AmplificationUP) > 0 And sunbelt Then Amplification robn overtime = UBound(rob(robn).DNA) ^ (1 / 3) * 3000 If .Mutables.mutarray(MajorDeletionUP) > 0 Then MajorDeletion robn overtime = UBound(rob(robn).DNA) ^ (1 / 3) * 3000 If .Mutables.mutarray(MinorDeletionUP) > 0 Then MinorDeletion robn End If ismutating = False 'Botsareus 2/2/2013 Tells the parseor to ignore debugint and debugbool while the robot is mutating Delta = CLng(.LastMut) - Delta 'Botsareus 9/4/2012 Moved delta check before overflow reset to fix an error where robot info is not being updated 'auto forking If SimOpts.EnableAutoSpeciation Then If CDbl(.Mutations) > CDbl(.DnaLen) * CDbl(SimOpts.SpeciationGeneticDistance / 100) Then Dim robname As String Dim splitname() As String 'generate new specie name SimOpts.SpeciationForkInterval = SimOpts.SpeciationForkInterval + 1 'remove old nick name splitname = Split(.FName, ")") 'if it is a nick name only If Left(splitname(0), 1) = "(" And IsNumeric(Right(splitname(0), Len(splitname(0)) - 1)) Then robname = splitname(1) Else robname = .FName End If robname = "(" & SimOpts.SpeciationForkInterval & ")" & .FName 'do we have room for new specie? If SimOpts.SpeciesNum < 49 Then .FName = robname .Mutations = 0 AddSpecie robn, False Else SimOpts.SpeciationForkInterval = SimOpts.SpeciationForkInterval - 1 End If End If End If If .Mutations > 32000 Then .Mutations = 32000 'Botsareus 5/31/2012 Prevents mutations overflow If .LastMut > 32000 Then .LastMut = 32000 If (Delta > 0) Then 'The bot has mutated. .GenMut = .GenMut - .LastMut If .GenMut < 0 Then .GenMut = 0 mutatecolors robn, Delta .SubSpecies = NewSubSpecies(robn) .genenum = CountGenes(rob(robn).DNA()) .DnaLen = DnaLen(rob(robn).DNA()) .mem(DnaLenSys) = .DnaLen .mem(GenesSys) = .genenum End If getout: End With End Sub Private Sub Amplification(robn As Integer) 'Botsareus 12/10/2013 On Error GoTo getout: '1. pick a spot (1 to .dnalen - 1) '2. Run a length, copied to a temporary location '3. Pick a new spot (1 to .dnalen - 1) '4. Insert copied DNA overtime = UBound(rob(robn).DNA) ^ (1 / 3) * 3000 Dim t As Long Dim Length As Long With rob(robn) Dim tempDNA() As block Dim start As Long Dim second As Long Dim counter As Long t = 1 Do t = t + 1 overtime = overtime - 1 If Rnd < 1 / (.Mutables.mutarray(AmplificationUP) / SimOpts.MutCurrMult) Then Length = Gauss(.Mutables.StdDev(AmplificationUP), .Mutables.Mean(AmplificationUP)) Length = Length Mod UBound(.DNA) If Length < 1 Then Length = 1 Length = Length - 1 Length = Length \ 2 If t - Length < 1 Then GoTo skip If t + Length > .DnaLen - 1 Then GoTo skip If UBound(rob(robn).DNA) + CLng(Length) > 32000 Then GoTo skip If Length > 0 Then ReDim tempDNA(Length * 2) second = 0 For counter = t - Length To t + Length overtime = overtime - 1 tempDNA(second) = .DNA(counter) second = second + 1 Next counter 'we now have the appropriate length of DNA in the temporary array. 'open up a hole 'safe size If UBound(.DNA) > 5000 Then Exit Sub start = Random(1, UBound(.DNA) - 2) MakeSpace .DNA(), start, UBound(tempDNA) + 1 For counter = start + 1 To start + UBound(tempDNA) + 1 overtime = overtime - 1 .DNA(counter) = tempDNA(counter - start - 1) Next counter 'BOTSAREUSIFIED .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .LastMutDetail = "Amplification copied a series at" + Str(t) + Str(Length * 2 + 1) + "bps long to " + Str(start) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail If overtime < 0 Then Exit Sub End If End If skip: Loop Until t >= UBound(.DNA) - 1 'add "end" to end of the DNA .DNA(UBound(.DNA)).tipo = 10 .DNA(UBound(.DNA)).value = 1 End With getout: End Sub Private Sub Translocation(robn As Integer) 'Botsareus 12/10/2013 On Error GoTo getout: '1. pick a spot (1 to .dnalen - 1) '2. Run a length, copied to a temporary location '3. Pick a new spot (1 to .dnalen - 1) '4. Insert copied DNA Dim t As Long Dim Length As Long With rob(robn) Dim tempDNA() As block Dim start As Long Dim second As Long Dim counter As Long For t = 1 To UBound(.DNA) - 1 If Rnd < 1 / (.Mutables.mutarray(TranslocationUP) / SimOpts.MutCurrMult) Then Length = Gauss(.Mutables.StdDev(TranslocationUP), .Mutables.Mean(TranslocationUP)) Length = Length Mod UBound(.DNA) If Length < 1 Then Length = 1 Length = Length - 1 Length = Length \ 2 If t - Length < 1 Then GoTo skip If t + Length > UBound(.DNA) - 1 Then GoTo skip If Length > 0 Then ReDim tempDNA(Length * 2) second = 0 For counter = t - Length To t + Length tempDNA(second) = .DNA(counter) second = second + 1 Next counter 'we now have the appropriate length of DNA in the temporary array. 'delete fragment Delete .DNA, t - Length, Length * 2 'open up a hole start = Random(1, UBound(.DNA) - 2) MakeSpace .DNA(), start, UBound(tempDNA) For counter = start + 1 To start + UBound(tempDNA) + 1 .DNA(counter) = tempDNA(counter - start - 1) Next counter 'BOTSAREUSIFIED .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .LastMutDetail = "Translocation moved a series at" + Str(t) + Str(Length * 2 + 1) + "bps long to " + Str(start) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail End If End If skip: Next t 'add "end" to end of the DNA .DNA(UBound(.DNA)).tipo = 10 .DNA(UBound(.DNA)).value = 1 End With getout: End Sub Private Sub CopyError2(robn As Integer) 'Just like Copyerror but effects only special chars Dim DNASize As Integer Dim e As Integer 'counter Dim e2 As Integer 'update generator (our position) Dim randomsysvar As Integer Dim holddetail As String With rob(robn) DNASize = DnaLen(.DNA) - 1 'get aprox length Dim datahit() As Boolean 'operation repeat prevention ReDim datahit(DNASize) For e = 0 To DNASize If Rnd < (1 / (.Mutables.mutarray(CE2UP) / SimOpts.MutCurrMult * 28 / 300)) Then 'chance Do e2 = Int(Rnd * (DNASize + 1)) Loop Until datahit(e2) = False datahit(e2) = True Do randomsysvar = Int(Rnd * 1000) Loop Until sysvar(randomsysvar).Name <> "" .DNA(e2).tipo = 1 If .DNA(e2 + 1).tipo = 7 Then .DNA(e2).tipo = 0 'if store , inc , or dec then type 0 holddetail = "CopyError2 changed dna location " & e2 & " to sysvar " & IIf(.DNA(e2).tipo = 1, "*.", ".") & sysvar(randomsysvar).Name .DNA(e2).value = sysvar(randomsysvar).value 'transfears value, not adress 'special cases If e2 < DNASize - 2 Then 'for .shoot store If .DNA(e2 + 1).tipo = 0 And .DNA(e2 + 1).value = shoot _ And .DNA(e2 + 2).tipo = 7 And .DNA(e2 + 2).value = 1 Then .DNA(e2).value = -Int(Rnd * 9) - 1 If .DNA(e2).value = -9 Then .DNA(e2).value = sysvar(randomsysvar).value .DNA(e2).tipo = 0 holddetail = "CopyError2 changed dna location " & e2 & " to " & .DNA(e2).value End If 'for .focuseye store If .DNA(e2 + 1).tipo = 0 And .DNA(e2 + 1).value = FOCUSEYE _ And .DNA(e2 + 2).tipo = 7 And .DNA(e2 + 2).value = 1 Then .DNA(e2).value = Int(Rnd * 9) - 4 .DNA(e2).tipo = 0 holddetail = "CopyError2 changed dna location " & e2 & " to " & .DNA(e2).value End If End If .LastMutDetail = holddetail & " during cycle" & Str(SimOpts.TotRunCycle) & vbCrLf & .LastMutDetail .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 End If Next End With End Sub Private Sub PointMutation2(robn As Integer) 'Botsareus 12/10/2013 'assume the bot has a positive (>0) mutarray value for this Dim randomsysvar As Integer Dim randompos As Integer 'update generator Dim DNASize As Integer Dim holddetail As String With rob(robn) If .age = 0 Or .Point2MutCycle < .age Then Point2MutWhen Rnd, robn 'Do it again in case we get two point mutations in a single cycle While .age = .Point2MutCycle And .age > 0 And .DnaLen > 1 ' Avoid endless loop when .age = 0 and/or .DNALen = 1 'sysvar mutation DNASize = DnaLen(.DNA) - 1 'get aprox length randompos = Int(Rnd * (DNASize + 1)) Do randomsysvar = Int(Rnd * 1000) Loop Until sysvar(randomsysvar).Name <> "" If .DNA(randompos).tipo = 1 And Int(Rnd * 2) = 0 Then 'sometimes we need to introduce more stores .DNA(randompos).tipo = 7 .DNA(randompos).value = 1 holddetail = "PointMutation2 changed dna location " & randompos & " to store" Else .DNA(randompos).tipo = 1 If .DNA(randompos + 1).tipo = 7 Then .DNA(randompos).tipo = 0 'if store , inc , or dec then type 0 .DNA(randompos).value = sysvar(randomsysvar).value 'transfears value, not adress holddetail = "PointMutation2 changed dna location " & randompos & " to sysvar " & IIf(.DNA(randompos).tipo = 1, "*.", ".") & sysvar(randomsysvar).Name End If 'special case for .shoot store If randompos < DNASize - 2 Then If .DNA(randompos + 1).tipo = 0 And .DNA(randompos + 1).value = shoot _ And .DNA(randompos + 2).tipo = 7 And .DNA(randompos + 2).value = 1 Then .DNA(randompos).value = -Int(Rnd * 9) - 1 If .DNA(randompos).value = -9 Then .DNA(randompos).value = sysvar(randomsysvar).value .DNA(randompos).tipo = 0 holddetail = "PointMutation2 changed dna location " & randompos & " to " & .DNA(randompos).value End If 'for .focuseye store If .DNA(randompos + 1).tipo = 0 And .DNA(randompos + 1).value = FOCUSEYE _ And .DNA(randompos + 2).tipo = 7 And .DNA(randompos + 2).value = 1 Then .DNA(randompos).value = Int(Rnd * 9) - 4 .DNA(randompos).tipo = 0 holddetail = "PointMutation2 changed dna location " & randompos & " to " & .DNA(randompos).value End If End If .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .LastMutDetail = holddetail & " during cycle" & Str(SimOpts.TotRunCycle) & vbCrLf & .LastMutDetail Point2MutWhen Rnd, robn Wend End With End Sub Private Sub PointMutation(robn As Integer) 'assume the bot has a positive (>0) mutarray value for this Dim temp As Single Dim temp2 As Long With rob(robn) If .age = 0 Or .PointMutCycle < .age Then PointMutWhereAndWhen Rnd, robn, .PointMutBP 'Do it again in case we get two point mutations in a single cycle While .age = .PointMutCycle And .age > 0 And .DnaLen > 1 ' Avoid endless loop when .age = 0 and/or .DNALen = 1 temp = Gauss(.Mutables.StdDev(PointUP), .Mutables.Mean(PointUP)) temp2 = Int(temp) Mod 32000 '<- Overflow was here when huge single is assigned to a Long ChangeDNA robn, .PointMutBP, temp2, .Mutables.PointWhatToChange PointMutWhereAndWhen Rnd, robn, .PointMutBP Wend End With End Sub Private Sub Point2MutWhen(randval As Single, robn As Integer) Dim result As Single Dim mutation_rate As Single 'If randval = 0 Then randval = 0.0001 With rob(robn) If .DnaLen = 1 Then GoTo getout ' avoid divide by 0 below mutation_rate = .Mutables.mutarray(P2UP) / SimOpts.MutCurrMult 'keeps Point2 lengths the same as Point Botsareus 1/14/2014 Checking to make sure value is >= 1 Dim calc_gauss As Double calc_gauss = Gauss(.Mutables.StdDev(PointUP), .Mutables.Mean(PointUP)) If calc_gauss < 1 Then calc_gauss = 1 mutation_rate = mutation_rate / calc_gauss 'Here we test to make sure the probability of a point mutation isn't crazy high. 'A value of 1 is the probability of mutating every base pair every 1000 cycles 'Lets not let it get lower than 1 shall we? If mutation_rate < 1 And mutation_rate > 0 Then mutation_rate = 1 End If 'result = offset + Fix(Log(randval) / Log(1 - 1 / (1000 * .Mutables.mutarray(PointUP)))) result = Log(1 - randval) / Log(1 - 1 / (1000 * mutation_rate)) While result > 1800000000: result = result - 1800000000: Wend 'Botsareus 3/15/2013 overflow fix .Point2MutCycle = .age + result / (.DnaLen - 1) getout: End With End Sub Private Sub PointMutWhereAndWhen(randval As Single, robn As Integer, Optional offset As Long = 0) Dim result As Single Dim mutation_rate As Single 'If randval = 0 Then randval = 0.0001 With rob(robn) If .DnaLen = 1 Then GoTo getout ' avoid divide by 0 below mutation_rate = .Mutables.mutarray(PointUP) / SimOpts.MutCurrMult 'Here we test to make sure the probability of a point mutation isn't crazy high. 'A value of 1 is the probability of mutating every base pair every 1000 cycles 'Lets not let it get lower than 1 shall we? If mutation_rate < 1 And mutation_rate > 0 Then mutation_rate = 1 End If 'result = offset + Fix(Log(randval) / Log(1 - 1 / (1000 * .Mutables.mutarray(PointUP)))) result = Log(1 - randval) / Log(1 - 1 / (1000 * mutation_rate)) While result > 1800000000: result = result - 1800000000: Wend 'Botsareus 3/15/2013 overflow fix .PointMutBP = (result Mod (.DnaLen - 1)) + 1 'note that DNA(DNALen) = end. 'We don't mutate end. Also note that DNA does NOT start at 0th element .PointMutCycle = .age + result / (.DnaLen - 1) getout: End With End Sub Private Sub DeltaMut(robn As Integer) Dim temp As Integer Dim newval As Single ' EricL Made newval Single instead of Long. With rob(robn) If Rnd > 1 - 1 / (100 * .Mutables.mutarray(DeltaUP) / SimOpts.MutCurrMult) Then If .Mutables.StdDev(DeltaUP) = 0 Then .Mutables.Mean(DeltaUP) = 50 If .Mutables.Mean(DeltaUP) = 0 Then .Mutables.Mean(DeltaUP) = 25 'temp = Random(0, 20) Do temp = Random(0, 10) 'Botsareus 12/14/2013 Added new mutations Loop While .Mutables.mutarray(temp) <= 0 Do newval = Gauss(.Mutables.Mean(DeltaUP), .Mutables.mutarray(temp)) Loop While .Mutables.mutarray(temp) = newval Or newval <= 0 .LastMutDetail = "Delta mutations changed " + MutationType(temp) + " from 1 in" + Str(.Mutables.mutarray(temp)) + _ " to 1 in" + Str(newval) + vbCrLf + .LastMutDetail .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .Mutables.mutarray(temp) = newval End If End With End Sub Private Sub CopyError(robn As Integer) Dim t As Long Dim accum As Long Dim Length As Long With rob(robn) For t = 1 To (.DnaLen - 1) 'note that DNA(.dnalen) = end, and we DON'T mutate that. If Rnd < 1 / (rob(robn).Mutables.mutarray(CopyErrorUP) / SimOpts.MutCurrMult) Then Length = Gauss(rob(robn).Mutables.StdDev(CopyErrorUP), _ rob(robn).Mutables.Mean(CopyErrorUP)) 'length accum = accum + Length ChangeDNA robn, t, Length, rob(robn).Mutables.CopyErrorWhatToChange, _ CopyErrorUP End If Next t End With End Sub 'Private Sub ChangeDNA(ByRef DNA() As block, nth As Long, Optional length As Long = 1) Private Sub ChangeDNA(robn As Integer, ByVal nth As Long, Optional ByVal Length As Long = 1, Optional ByVal PointWhatToChange As Integer = 50, Optional Mtype As Integer = PointUP) 'we need to rework .lastmutdetail Dim Max As Long Dim temp As String Dim bp As block Dim tempbp As block Dim Name As String Dim oldname As String Dim t As Long Dim old As Long With rob(robn) For t = nth To (nth + Length - 1) 'if length is 1, it's only one bp we're mutating, remember? If t >= .DnaLen Then GoTo getout 'don't mutate end either If .DNA(t).tipo = 10 Then GoTo getout 'mutations can't cross control barriers If Random(0, 99) < PointWhatToChange Then ''''''''''''''''''''''''''''''''''''''''' 'Mutate VALUE ''''''''''''''''''''''''''''''''''''''''' If .DNA(t).value And Mtype = InsertionUP Then 'Insertion mutations should get a good range for value. 'Don't worry, this will get "mod"ed for non number commands. 'This doesn't count as a mutation, since the whole: ' -- Add an element, set it's tipo and value to random stuff -- is a SINGLE mutation 'we'll increment mutation counters and .lastmutdetail later. .DNA(t).value = Gauss(500, 0) 'generates values roughly between -1000 and 1000 End If old = .DNA(t).value If .DNA(t).tipo = 0 Or .DNA(t).tipo = 1 Then '(number or *number) Do ' Dim a As Integer .DNA(t).value = Gauss(IIf(Abs(old) < 100, IIf(Sgn(old) = 0, Random(0, 1) * 2 - 1, Sgn(old)) * 10, old / 10), .DNA(t).value) Loop While .DNA(t).value = old .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 overtime = overtime - 1: If overtime < 0 And Mtype <> InsertionUP Then Exit Sub .LastMutDetail = MutationType(Mtype) + " changed " + TipoDetok(.DNA(t).tipo) + " from" + Str(old) + " to" + Str(.DNA(t).value) + " at position" + Str(t) + " during cycle" + Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail Else 'find max legit value 'this should really be done a better way bp.tipo = .DNA(t).tipo Max = 0 Do temp = "" Max = Max + 1 bp.value = Max Parse temp, bp Loop While temp <> "" Max = Max - 1 If Max <= 1 Then GoTo getout 'failsafe in case its an invalid type or there's no way to mutate it Do .DNA(t).value = Random(1, Max) Loop While .DNA(t).value = old bp.tipo = .DNA(t).tipo bp.value = old tempbp = .DNA(t) Name = "" oldname = "" Parse Name, tempbp ' Have to use a temp var because Parse() can change the arguments Parse oldname, bp .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 overtime = overtime - 1: If overtime < 0 And Mtype <> InsertionUP Then Exit Sub .LastMutDetail = MutationType(Mtype) + " changed value of " + TipoDetok(.DNA(t).tipo) + " from " + _ oldname + " to " + Name + " at position" + Str(t) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail End If Else bp.tipo = .DNA(t).tipo bp.value = .DNA(t).value Do .DNA(t).tipo = Random(0, 20) Loop While .DNA(t).tipo = bp.tipo Or TipoDetok(.DNA(t).tipo) = "" Max = 0 If .DNA(t).tipo >= 2 Then Do temp = "" Max = Max + 1 .DNA(t).value = Max Parse temp, .DNA(t) Loop While temp <> "" Max = Max - 1 If Max <= 1 Then GoTo getout 'failsafe in case its an invalid type or there's no way to mutate it .DNA(t).value = (bp.value Mod Max) 'put values in range If .DNA(t).value <= 0 Then .DNA(t).value = 1 End If Else 'we do nothing, it has to be in range End If tempbp = .DNA(t) Name = "" oldname = "" Parse Name, tempbp ' Have to use a temp var because Parse() can change the arguments Parse oldname, bp .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 overtime = overtime - 1: If overtime < 0 And Mtype <> InsertionUP Then Exit Sub .LastMutDetail = MutationType(Mtype) + " changed the " + TipoDetok(bp.tipo) + ": " + _ oldname + " to the " + TipoDetok(.DNA(t).tipo) + ": " + Name + " at position" + Str(t) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail End If Next t getout: End With End Sub Private Sub Insertion(robn As Integer) Dim location As Integer Dim Length As Integer Dim accum As Long Dim t As Long With rob(robn) For t = 1 To (.DnaLen - 1) If Rnd < 1 / (.Mutables.mutarray(InsertionUP) / SimOpts.MutCurrMult) Then If overtime < 0 Then Exit Sub If .Mutables.Mean(InsertionUP) = 0 Then .Mutables.Mean(InsertionUP) = 1 Do Length = Gauss(.Mutables.StdDev(InsertionUP), .Mutables.Mean(InsertionUP)) Loop While Length <= 0 If CLng(rob(robn).DnaLen) + CLng(Length) > 32000 Then Exit Sub MakeSpace .DNA(), t + accum, Length, .DnaLen rob(robn).DnaLen = rob(robn).DnaLen + Length ' accum = accum + length ' ChangeDNA robn, t + accum, length, 100, InsertionUP 'set a good value up ' ChangeDNA robn, t + accum, length, 0, InsertionUP 'change type ChangeDNA robn, t + 1, Length, 0, InsertionUP 'change the type first so that the mutated value is within the space of the new type ChangeDNA robn, t + 1, Length, 100, InsertionUP 'set a good value up End If Next t End With End Sub Private Sub Reversal(robn As Integer) 'reverses a length of DNA Dim Length As Long Dim counter As Long Dim location As Long Dim low As Long Dim high As Long Dim templong As Long Dim tempblock As block Dim t As Long Dim second As Long With rob(robn) For t = 1 To (.DnaLen - 1) If Rnd < 1 / (.Mutables.mutarray(ReversalUP) / SimOpts.MutCurrMult) Then If .Mutables.Mean(ReversalUP) < 2 Then .Mutables.Mean(ReversalUP) = 2 Do Length = Gauss(.Mutables.StdDev(ReversalUP), .Mutables.Mean(ReversalUP)) Loop While Length <= 0 Length = Length \ 2 'be sure we go an even amount to either side If t - Length < 1 Then Length = t - 1 If t + Length > .DnaLen - 1 Then Length = .DnaLen - 1 - t If Length > 0 Then second = 0 For counter = t - Length To t - 1 tempblock = .DNA(counter) .DNA(counter) = .DNA(t + Length - second) .DNA(t + Length - second) = tempblock second = second + 1 overtime = overtime - 1 'No changedna? no problem Next counter .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .LastMutDetail = "Reversal of" + Str(Length * 2 + 1) + "bps centered at " + Str(t) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail End If End If Next t End With End Sub Private Sub MinorDeletion(robn As Integer) Dim Length As Long, t As Long With rob(robn) If .Mutables.Mean(MinorDeletionUP) < 1 Then .Mutables.Mean(MinorDeletionUP) = 1 For t = 1 To (.DnaLen - 1) If Rnd < 1 / (.Mutables.mutarray(MinorDeletionUP) / SimOpts.MutCurrMult) Then Do Length = Gauss(.Mutables.StdDev(MinorDeletionUP), .Mutables.Mean(MinorDeletionUP)) Loop While Length <= 0 If t + Length > .DnaLen - 1 Then Length = .DnaLen - 1 - t Delete .DNA, t, Length, .DnaLen .DnaLen = DnaLen(.DNA()) .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .LastMutDetail = "Minor Deletion deleted a run of" + _ Str(Length) + " bps at position" + Str(t) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail overtime = overtime - 1: If overtime < 0 Then Exit Sub End If Next t End With End Sub Private Sub MajorDeletion(robn As Integer) Dim Length As Long, t As Long With rob(robn) If .Mutables.Mean(MajorDeletionUP) < 1 Then .Mutables.Mean(MajorDeletionUP) = 1 For t = 1 To (.DnaLen - 1) If Rnd < 1 / (.Mutables.mutarray(MajorDeletionUP) / SimOpts.MutCurrMult) Then Do Length = Gauss(.Mutables.StdDev(MajorDeletionUP), .Mutables.Mean(MajorDeletionUP)) Loop While Length <= 0 If t + Length > .DnaLen - 1 Then Length = .DnaLen - 1 - t Delete .DNA, t, Length, .DnaLen .DnaLen = DnaLen(.DNA()) .Mutations = .Mutations + 1 .LastMut = .LastMut + 1 .LastMutDetail = "Major Deletion deleted a run of" + _ Str(Length) + " bps at position" + Str(t) + " during cycle" + _ Str(SimOpts.TotRunCycle) + vbCrLf + .LastMutDetail overtime = overtime - 1: If overtime < 0 Then Exit Sub End If Next t End With End Sub ' mutates robot colour in robot n a times Private Sub mutatecolors(n As Integer, a As Long) Dim color As Long Dim r As Long, g As Long, b As Long Dim counter As Long color = rob(n).color b = color \ (65536) g = color \ 256 - b * 256 r = color - b * 65536 - g * 256 For counter = 1 To a Select Case (Random(1, 3)) Case 1 b = b + (Random(0, 1) * 2 - 1) * 20 Case 2 g = g + (Random(0, 1) * 2 - 1) * 20 Case 3 r = r + (Random(0, 1) * 2 - 1) * 20 End Select If r > 255 Then r = 255 If r < 0 Then r = 0 If g > 255 Then g = 255 If g < 0 Then g = 0 If b > 255 Then b = 255 If b < 0 Then b = 0 Next counter rob(n).color = b * 65536 + g * 256 + r End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function delgene(n As Integer, g As Integer) As Boolean Dim k As Integer, t As Integer k = rob(n).genenum If g > 0 And g <= k Then DeleteSpecificGene rob(n).DNA, g delgene = True rob(n).DnaLen = DnaLen(rob(n).DNA) rob(n).genenum = CountGenes(rob(n).DNA) rob(n).mem(DnaLenSys) = rob(n).DnaLen rob(n).mem(GenesSys) = rob(n).genenum makeoccurrlist n 'Botsareus 3/14/2014 Disqualify If (SimOpts.F1 Or x_restartmode = 1) And Disqualify = 2 Then dreason rob(n).FName, rob(n).tag, "deleting a gene" If Not SimOpts.F1 And rob(n).dq = 1 And Disqualify = 2 Then rob(n).Dead = True 'safe kill robot End If End Function Public Sub DeleteSpecificGene(ByRef DNA() As block, k As Integer) Dim i As Long, f As Long i = genepos(DNA, k) If i < 0 Then GoTo getout f = GeneEnd(DNA, i) Delete DNA, i, f - i + 1 ' EricL Added +1 getout: End Sub Public Sub SetDefaultMutationRates(ByRef changeme As mutationprobs, Optional skipNorm As Boolean = False) 'Botsareus 12/17/2013 Figure out dna length Dim Length As Integer Dim path As String If NormMut And Not skipNorm Then If optionsform.CurrSpec = 50 Or optionsform.CurrSpec = -1 Then 'only if current spec is selected Length = rob(robfocus).DnaLen Else 'load dna length If MaxRobs = 0 Then ReDim rob(0) path = TmpOpts.Specie(optionsform.CurrSpec).path & "\" & TmpOpts.Specie(optionsform.CurrSpec).Name path = Replace(path, "&#", MDIForm1.MainDir) If dir(path) = "" Then path = MDIForm1.MainDir & "\Robots\" & TmpOpts.Specie(optionsform.CurrSpec).Name If LoadDNA(path, 0) Then Length = DnaLen(rob(0).DNA) End If End If End If Dim a As Long With (changeme) For a = 0 To 20 .mutarray(a) = IIf(NormMut And Not skipNorm, Length * CLng(valNormMut), 5000) .Mean(a) = 1 .StdDev(a) = 0 Next a If skipNorm Then .mutarray(P2UP) = 0 'Botsareus 2/21/2014 Might as well disable p2 mutations if loading from the net .Mean(PointUP) = 3 .StdDev(PointUP) = 1 .Mean(DeltaUP) = 500 .StdDev(DeltaUP) = 150 .Mean(MinorDeletionUP) = 1 .StdDev(MinorDeletionUP) = 0 .Mean(InsertionUP) = 1 .StdDev(InsertionUP) = 0 .Mean(CopyErrorUP) = 1 .StdDev(CopyErrorUP) = 0 .Mean(MajorDeletionUP) = 3 .StdDev(MajorDeletionUP) = 1 .Mean(ReversalUP) = 3 .StdDev(ReversalUP) = 1 .CopyErrorWhatToChange = 80 .PointWhatToChange = 80 .Mean(AmplificationUP) = 250 .StdDev(AmplificationUP) = 75 .Mean(TranslocationUP) = 250 .StdDev(TranslocationUP) = 75 End With End Sub