以下為基因演算法程式僅供參考,如有錯誤請自行Debug
Imports System.Collections.GenericPublic Class GeneticAlgorithm Private Shared Sub Main(args As String()) run(New SqrtChromosome(), 100, 100) End Sub Public Shared Sub run(prototype As Chromosome, size As Integer, maxGen As Integer) Dim pop As New Population() pop.initialize(prototype, size) For genIdx As Integer = 0 To maxGen - 1 pop = pop.reproduction() Console.WriteLine("================Population {0}================", genIdx) pop.print() Next End SubEnd ClassPublic Class Population Inherits List(Of Chromosome) Shared random As New Random(7) Private mutationRate As Double = 0.0 Public Sub initialize(prototype As Chromosome, popSize As Integer) Me.Clear() For i As Integer = 0 To popSize - 1 Dim newChrom As Chromosome = prototype.randomInstance() newChrom.calcFitness() Me.Add(newChrom) Next End Sub Public Function selection() As Chromosome Dim shoot As Integer = random.[Next]((Count * Count) \ 2) Dim [select] As Integer = CInt(Math.Truncate(Math.Floor(Math.Sqrt(shoot * 2)))) Return DirectCast(Me([select]), Chromosome) End Function Private Shared Function compare(a As Chromosome, b As Chromosome) As Integer If a.fitness > b.fitness Then Return 1 ElseIf a.fitness < b.fitness Then Return -1 Else Return 0 End If End Function Public Function reproduction() As Population Me.Sort(AddressOf compare) Dim newPop As New Population() For i As Integer = 0 To Count - 1 Dim parent1 As Chromosome = selection() Dim parent2 As Chromosome = selection() Dim child As Chromosome = parent1.crossover(parent2) Dim prob As Double = random.NextDouble() If prob < mutationRate Then child.mutate() End If child.calcFitness() newPop.Add(child) Next newPop.Sort(AddressOf compare) Return newPop End Function Public Sub print() Dim i As Integer = 1 For Each c As Chromosome In Me Console.WriteLine("{0:##} : {1}", i, c.ToString()) i += 1 Next End SubEnd ClassPublic MustInherit Class Chromosome Public fitness As Double Public MustOverride Function calcFitness() As Double Public MustOverride Function crossover(spouse As Chromosome) As Chromosome Public MustOverride Sub mutate() Public MustOverride Function randomInstance() As ChromosomeEnd ClassPublic Class SqrtChromosome Inherits Chromosome Public Shared random As New Random(7) Public value As String Public k As Double = 2 Public Overrides Function calcFitness() As Double Dim x As Double = Double.Parse(value) fitness = -1 * Math.Abs(x * x - k) Return fitness End Function Public Overrides Function crossover(spouse As Chromosome) As Chromosome Dim ss As SqrtChromosome = TryCast(spouse, SqrtChromosome) Dim cutIdx As Integer = random.[Next](value.Length) Dim head As [String] = value.Substring(0, cutIdx) Dim tail As [String] = ss.value.Substring(cutIdx) Dim child As New SqrtChromosome() child.value = head & tail Return child End Function Public Overrides Sub mutate() Dim v As Double = Double.Parse(value) v += random.NextDouble() - 0.5 value = [String].Format("{0:00.0000}", v) End Sub Public Overrides Function randomInstance() As Chromosome Dim chrom As New SqrtChromosome() Dim v As Double = random.NextDouble() * 10 chrom.value = [String].Format("{0:00.0000}", v) Return chrom End Function Public Overrides Function ToString() As String Return [String].Format("chromosome={0} fitness={1:F4}", value, fitness) End FunctionEnd Class--------------------------------------------------------------我是分隔線--------------------------------------------------------
Public Class GeneticAlgorithm(Of T)#Region "Properties" Public ReadOnly Property PopulationSize As Integer Get Return _size End Get End Property Public Property CrossoverProbability As Single Public Property MutationProbability As Single Public ReadOnly Property Generations As Integer Get Return _Generations End Get End Property Public ReadOnly Property Running As Boolean Get Return _Running End Get End Property#End Region#Region "Private Declarations" Private Ops As Operators(Of T) Private _size As Integer Private Chromosomes As ChromosomeCollection(Of T) Private _Generations As Integer Private Context As Threading.SynchronizationContext Private WorkerThread As Threading.Thread Private _Running As Boolean#End Region#Region "Constructors" Private Sub New() End Sub Public Sub New(ByVal Ops As Operators(Of T), Optional ByVal PopulationSize As Integer = 30, Optional ByVal CrossoverProbability As Single = 60.0!, Optional ByVal MutationProbability As Single = 1.0!) _size = PopulationSize Me.CrossoverProbability = CrossoverProbability Me.MutationProbability = MutationProbability Me.Ops = Ops Me.Chromosomes = New ChromosomeCollection(Of T) Context = Threading.SynchronizationContext.Current If PopulationSize Mod 2 = 1 Then Throw New ArgumentException("Must be a multiple of 2", "PopulationSize") End If End Sub#End Region#Region "Methods" Public Sub StartFinding() WorkerThread = New Threading.Thread(New Threading.ThreadStart(AddressOf FindSolution)) WorkerThread.Start() _Running = True End Sub Public Sub StopFinding() _Running = False End Sub Private Sub FindSolution() Chromosomes.Clear() For I = 0 To PopulationSize - 1 Chromosomes.Add(Me.Ops.CreateChromosome) Next Dim SolutionFound As Boolean = False While Not SolutionFound And _Running For Each I As Chromosome(Of T) In Me.Chromosomes I.Fitness = Me.Ops.CalculateFitness(I) Next Dim Result = (From Y In Me.Chromosomes _ Where Y.Fitness = _ (From X In Me.Chromosomes _ Select X.Fitness).Max _ ).FirstOrDefault If Not Me.Ops.ConditionSatisfied(Result) Then Me.Chromosomes = GetGeneration() Else SolutionFound = True Context.Post(New Threading.SendOrPostCallback(Sub(i) RaiseEvent SolutionFound(Me, DirectCast(i, SolutionFoundEventArgs(Of T))) End Sub), New SolutionFoundEventArgs(Of T)(Result.Encoding)) End If System.Threading.Thread.Sleep(10) End While End Sub Private Function GetGeneration() As ChromosomeCollection(Of T) Dim Chromos As New ChromosomeCollection(Of T) Chromos.AddRange(Me.Ops.SelectEliet(Me.Chromosomes)) Dim R As New Random _Generations += 1 If Chromos.Count Mod 2 = 1 Then 'just to Make it even agian. Chromos.Add(Me.Ops.CreateChromosome) End If While Chromos.Count < Me.Chromosomes.Count Dim Crossover As Single = CSng(R.NextDouble * 100) Dim Parents As Tuple(Of Chromosome(Of T), Chromosome(Of T)) = Ops.SelectParents(Me.Chromosomes) Dim C1 As Chromosome(Of T) = Parents.Item1 Dim C2 As Chromosome(Of T) = Parents.Item2 If Crossover <= Me.CrossoverProbability Then Dim T As Tuple(Of Chromosome(Of T), Chromosome(Of T)) = Me.Ops.Crossover(C1, C2) C1 = T.Item1 C2 = T.Item2 Dim Mutate As Single = CSng(R.NextDouble() * 100) If Mutate <= MutationProbability Then Dim T2 As Tuple(Of Chromosome(Of T), Chromosome(Of T)) = Me.Ops.Mutate(C1, C2) C1 = T2.Item1 C2 = T2.Item2 End If Chromos.Add(C1) Chromos.Add(C2) Else Chromos.Add(C1) Chromos.Add(C2) End If End While Context.Post(New Threading.SendOrPostCallback(Sub(i) RaiseEvent NewGeneration(Me, DirectCast(i, NewGenerationEventArgs(Of T))) End Sub), New NewGenerationEventArgs(Of T)(Chromos.ToArray)) Return Chromos End Function#End Region#Region "Events" Public Event SolutionFound As EventHandler(Of SolutionFoundEventArgs(Of T)) Public Event NewGeneration As EventHandler(Of NewGenerationEventArgs(Of T))#End RegionEnd ClassPublic Class WeightedRandom(Of T) Inherits List(Of Pair(Of T)) Private R As Random Sub New() R = New Random() End Sub Sub New(ByVal Seed As Integer) R = New Random(Seed) End Sub Public Function [Next]() As T Dim Total As Integer = Aggregate x In Me Into Sum(x.Weight) Dim Rnd As Integer = R.Next(0, Total) For I = 0 To Me.Count - 1 If Rnd < Me(I).Weight Then Return Me(I).Item End If Rnd -= Me(I).Weight Next End FunctionEnd ClassPublic Class Pair(Of T) Public Property Weight As Integer Public Property Item As T Sub New(ByVal Item As T, ByVal Weight As Integer) Me.Weight = Weight Me.Item = Item End SubEnd ClassPublic Class SolutionFoundEventArgs(Of T) Inherits System.EventArgs Private _Solution As T Public ReadOnly Property Solution As T Get Return _Solution End Get End Property Sub New(ByVal nSolution As T) _Solution = nSolution End SubEnd ClassPublic Class Chromosome(Of T) Public Property Encoding As T Public Property Fitness As Double Public Sub New(ByVal Encoding As T, ByVal Fitness As Double) Me.Encoding = Encoding Me.Fitness = Fitness End SubEnd ClassPublic Interface Operators(Of T) Function CalculateFitness(ByVal C As Chromosome(Of T)) As Double Function Crossover(ByVal C1 As Chromosome(Of T), ByVal c2 As Chromosome(Of T)) As Tuple(Of Chromosome(Of T), Chromosome(Of T)) Function Mutate(ByVal C1 As Chromosome(Of T), ByVal C2 As Chromosome(Of T)) As Tuple(Of Chromosome(Of T), Chromosome(Of T)) Function SelectParents(ByVal Chromosomes As ChromosomeCollection(Of T)) As Tuple(Of Chromosome(Of T), Chromosome(Of T)) Function CreateChromosome() As Chromosome(Of T) Function SelectEliet(ByVal Chromosomes As ChromosomeCollection(Of T)) As ChromosomeCollection(Of T) Function ConditionSatisfied(ByVal C As Chromosome(Of T)) As BooleanEnd InterfacePublic Class ChromosomeCollection(Of T) Inherits List(Of Chromosome(Of T))End ClassPublic Class NewGenerationEventArgs(Of T) Inherits System.EventArgs Private _Solution() As Chromosome(Of T) Public ReadOnly Property Generation As Chromosome(Of T)() Get Return _Solution End Get End Property Sub New(ByVal nSolution As Chromosome(Of T)()) _Solution = nSolution End SubEnd Class