VB のたまご

作成日: 2016/12/02, 更新日: 2016/12/02


遺伝的アルゴリズムの基礎実装を学ぶ1

  •  この記事は、Visual Basic Advent Calendar 2016 の2日目のエントリーです。

  •  こんにちは。 遺伝的アルゴリズム(を組み込んだ動画)の面白さに触発され、特に必要もないのに、専門分野でもないのに、調べては理解できず(当たり前)凹んだりして、 ネットの海をさまよっていたのですが、aidiary さんの解説記事(遺伝的アルゴリズムの紹介)がとても分かりやすかったので、 この記事では、VB.NET を用いて具体的なプログラムに落とし込みたいと思います。よって、先にこちらの記事をご一読いただくか、行き来して見比べながら本記事を読まれることをお勧めします。 今回作成する種類は、コンソールアプリケーションです。

1つ目の問題(一番優秀な遺伝子を見つけ出す)

  •  これは”GAの簡単な例”という説明の部分です。 本プログラムでは、染色体は固定値ではなく、毎回ランダムで生成するように仕様を変更しています。 まず最初に、インターフェースを定義します。※以降では、説明用に部分ソースを載せていますが、最後の方で全体ソースを載せています。

  • IGAable.vb
    
    ' 遺伝的アルゴリズムのメンバー
    Public Interface IGAable
    
        ' 第一世代の生成
        Sub Generate1stGeneration()
    
        ' 評価(各染色体メンバーに対して、適応度点数を付ける)
        Sub Evaluation()
    
        ' 選択(適応度が高いメンバーの選別、と同時に低いメンバーの淘汰)
        Sub Selection()
    
        ' 交叉(両親の優秀な遺伝子を受け継ぐ、次世代メンバーの生成)
        Sub Crossover()
    
        ' 突然変異(一定確率で呼び出される、遺伝子操作)
        Sub Mutation()
    
        ' 現世代の状態を表示
        Sub ShowGeneration()
    
    End Interface
    

  •  記事にあります、遺伝的アルゴリズムの処理の流れフローチャート(”GAの手順”の部分)に合わせて、振る舞いを定義しました。 このうち、現世代の状態をコンソール表示する ShowGeneration メソッドは、本来無くてもいい処理ではありますが、 進化の過程を見る部分が無いと醍醐味が無いかなと思い、追加しています。

  •  次に、遺伝子を扱うデータの構成です。

  • イメージ
  •  もしこの相関関係が間違っていた場合ごめんなさいなんですが、その場合でもこのまま説明を進めていきます。 個体がいくつか集まり集団として扱うので、集団をリストで、個体をクラスで表現しています。 また、個体は、染色体(問題に対する答え候補)と適応度(この答えがどのくらい優秀かの評価値)を持っていた方が扱いやすいのかと思い、ひとまとめにしています。 集団に含まれる個体は 4 つ固定としていて、集団=1世代となります。集団に対して、クリアしたり登録したりして世代交代します。

第一世代の生成

  •  まずは、初期データ作成から始めます。作成した染色体を集団リストに登録する人と、染色体を作成する人に分けて実装しています。 実は、一回通しで作成して動かしてみて、良い感じじゃないところに微調整処理を後追加していまして、まずはここの部分に追加しました。

  •  Random クラスの Next メソッドを利用して、ランダムに 0 と 1 の遺伝子(と見立てて)を生成しては、5 つ組み合わせて染色体を作成しているのですが、 どうしても連続して同じ染色体が登録されてしまうことがありました。同じ染色体同士を交叉しても、生まれてくる子供は親と全く同じ染色体になり、 これでは進化が止まってしまいます。2体でも4体でも、第一世代で進化を止めてしまう原因、要因、可能性は避けたいので、重複除去処理を入れました。

  •  また、ランダム生成していると、天才も生まれてくることがあります。11111 とかね。 生まれてきた時はこんなに貧弱だったのに、立派に成長したのね~的な展開が見たいため、天才は排除処理を入れました。

  • ' 第一世代の生成
    Public Sub Generate1stGeneration() Implements IGAable.Generate1stGeneration
    
        Dim index = 0
        While True
    
            ' 4つ作成したら抜ける
            If index = 4 Then
                Exit While
            End If
    
            ' (調整)重複遺伝子は除外、最初から適応度が高い遺伝子も除外
            Dim chromosome = Me.GenerateChromosome()
            Dim b1 = Not Me.population.Exists(Function(x) x.Chromosome = chromosome)
            Dim b2 = Not chromosome.StartsWith("1111")
            If b1 AndAlso b2 Then
                Me.population.Add(New Indivisual With {.Chromosome = chromosome})
                index += 1
            End If
    
        End While
    
    End Sub
    
    Private Function GenerateChromosome() As String
    
        ' 高スペックすぎるパソコンでの動作対策、時間をずらしてランダムシードをずらす
        Thread.Sleep(1000)
    
        ' 01101 みたいな感じで、5 つ分の遺伝子の組み合わせを生成、返却
        Dim chromosome = String.Empty
        Dim rnd As New Random()
    
        For i As Integer = 0 To 4
            chromosome &= rnd.Next(2).ToString()
        Next
    
        Return chromosome
    
    End Function
    

評価(各染色体メンバーに対して、適応度点数を付ける)

  •  評価方法は、染色体(2進数5桁)を10進数の数字に変換して、数値の大小で判定します。 LINQ の ForEach を使って全部の個体それぞれに対して、計算結果を適用度プロパティにセットしています。

  • ' 評価(各染色体メンバーに対して、適応度点数を付ける)
    Public Sub Evaluation() Implements IGAable.Evaluation
    
        ' 染色体(10110等:String、2進数)を、10進数に変換して、適応度にセット
        Me.population.ForEach(Sub(x) x.Fitness = Convert.ToInt32(x.Chromosome, 2))
    
    End Sub
    

選択(適応度が高いメンバーの選別、と同時に低いメンバーの淘汰)

  •  選択方法はシンプルに、評価処理のところで計算した適応度を元に、適応度が高い染色体を成績順で選択します。 LINQ の OrderByDescending メソッドで適応度の降順にソートして、Take メソッドで4つの中から3つだけ取り出しています。 集団リストには、選択した染色体のみ入っている状態に入れ替えます。

  • ' 選択(適応度が高いメンバーの選別、と同時に低いメンバーの淘汰)
    Public Sub Selection() Implements IGAable.Selection
    
        ' 適応度の降順でソートして、上位 3 件分のみ取得
        Dim parents = Me.population.OrderByDescending(Function(x) x.Fitness).Take(3).ToList()
    
        ' 優秀なメンバーのみ残す
        Me.population.Clear()
        Me.population.AddRange(parents)
    
    End Sub
    

交叉(両親の優秀な遺伝子を受け継ぐ、次世代メンバーの生成)

  •  交叉をして次世代の染色体を作成します。具体的には、親1と親2の一部の遺伝子を入れ替えて、子供染色体を作成します。 親1の前半遺伝子2つと、親2の後半遺伝子3つを組み合わせて子供1を、親2の前半遺伝子2つと、親1の後半遺伝子3つを組み合わせて子供2を作成します。

  •  これにより、集団リストには次世代の染色体4つが入れ替わります。このタイミングでは適応度は未定のままにしておきます。 適応度計算は評価処理で、適応度判定は選択処理でおこないます。

  • ' 交叉(両親の優秀な遺伝子を受け継ぐ、次世代メンバーの生成)
    Public Sub Crossover() Implements IGAable.Crossover
    
        ' 現世代を前世代としてバックアップ
        Me.previousPopulation.Clear()
        Me.previousPopulation.AddRange(Me.population.ToList())
    
        ' メンバー数が 3 と固定されている前提なので、変数に分けて扱う
        Dim parent1 = Me.population(0).Chromosome
        Dim parent2 = Me.population(1).Chromosome
        Dim parent3 = Me.population(2).Chromosome
    
        ' 個体1と個体2、個体1と個体3を交叉
        Dim childA1 = parent1.Substring(0, 2) & parent2.Substring(2)
        Dim childA2 = parent2.Substring(0, 2) & parent1.Substring(2)
    
        Dim childB1 = parent1.Substring(0, 2) & parent3.Substring(2)
        Dim childB2 = parent3.Substring(0, 2) & parent1.Substring(2)
    
        ' 現世代から次世代へ世代交代
        Me.population.Clear()
        Me.population.Add(New Indivisual With {.Chromosome = childA1})
        Me.population.Add(New Indivisual With {.Chromosome = childA2})
        Me.population.Add(New Indivisual With {.Chromosome = childB1})
        Me.population.Add(New Indivisual With {.Chromosome = childB2})
    
    End Sub
    

突然変異(一定確率で呼び出される、遺伝子操作)

  •  交叉以外で外的要因からの遺伝子操作をおこない、進化or退化をおこないます。 最初は、確率判定と遺伝子操作処理だけ(突然変異をおこなうための処理だけ)にしていましたが、 途中で進化が停止してしまうことが多かったため、突然変異フェーズで調整処理を追加することにしました。

  •  2つの動作モードに分けていて、まず現世代が、進化が停止しているかチェックします。 チェックの結果、進化が停止している場合、調整的変異をおこない、揺らぎを発生させて進化が発生するように仕向けます。 もし進化が進行中の場合、通常の突然変異処理をおこないます。

  •  この【進化が停止しているかチェック】の判定方法ですが、①前世代の染色体と現世代の染色体が同じ場合、 かつ②現世代の各染色体が同じ構成で重複している場合に、進化が停止したと判断しています。

  •  例えばこんな状態。

  • 前世代
    10100
    10100
    10100
    10100
    
    現世代
    10100
    10100
    10100
    10100
    

  •  この場合、ある親1の 10 とある親2の 100 を組み合わせても、生まれてくる子供は 10100 となり、親と同じレベルのままというか、 永遠の平行世界に入ってしまって、進化が止まってしまいます。こんな状態になっていないかどうかをチェックするわけです。

  •  調整的変異は、強制的に遺伝子をいじってしまうわけですが、その代わりに最小限の変異になるように仕込んでいます。 右から左への走査と、最初に見つけた1つだけ 0 から 1 に変える。という部分です。

  •  ちなみに個人的な話ですが、確率判定というものを初めて知りました。ゲームの分野等で使用している処理なんですね。 確率を扱う処理というのは、なんだか運勢に対するプログラミングみたいで面白いな~と思いました。 ここでは、divideby_zero さんの記事(重み付きランダム)をそのまま使わせていただいています。

  • ' 突然変異(一定確率で呼び出される、遺伝子操作)
    Public Sub Mutation() Implements IGAable.Mutation
    
        If IsStopEvolution() Then
            ' 進化が停止した(と判断した場合)
    
            ' (調整)子供4の遺伝子を組み替える
            ' 右から左へ見ていき、最初に見つかった 0 を 1 に変える
            Dim chromosome = Me.population(3).Chromosome
            Dim reversed = chromosome.ToCharArray().Reverse()
            Dim found = False
    
            chromosome = String.Empty
            For Each gene In reversed
    
                If found = False AndAlso gene = "0"c Then
                    gene = "1"c
                    found = True
                End If
                chromosome &= gene
    
            Next
            chromosome = String.Join(String.Empty, chromosome.ToCharArray().Reverse())
            Me.population(3).Chromosome = chromosome
            Console.WriteLine("調整的変異を実行")
    
        Else
            ' 進化中
    
            ' wikipedia では、突然変異率は、0.1%~1%、高くても数%とのこと。
            ' 1%の確率で突然変異を起こす
            If Not Me.ProbabilityJudgement(New Random(), 1) Then
                Exit Sub
            End If
    
            ' 子供4の遺伝子を組み替える
            Dim chromosome = Me.population(3).Chromosome
            Dim c1 = chromosome.Substring(0, 1)
            Dim c2 = chromosome.Substring(1, 1)
            Dim c3 = chromosome.Substring(2)
    
            c2 = IIf(c2 = "0", "1", "0").ToString()
            Me.population(3).Chromosome = c1 & c2 & c3
            Console.WriteLine("突然変異を実行")
    
        End If
    
    End Sub
    
    ' 前世代と現世代が変わっていない場合、かつ現世代の染色体が全て同じ場合 true、違う場合 false
    Private Function IsStopEvolution() As Boolean
    
        Dim b1 = Me.previousPopulation(0).Chromosome = Me.population(0).Chromosome AndAlso
                      Me.previousPopulation(1).Chromosome = Me.population(1).Chromosome AndAlso
                      Me.previousPopulation(2).Chromosome = Me.population(2).Chromosome
        Dim b2 = Me.population(0).Chromosome = Me.population(1).Chromosome AndAlso
                      Me.population(0).Chromosome = Me.population(2).Chromosome AndAlso
                      Me.population(0).Chromosome = Me.population(3).Chromosome
    
        Return b1 AndAlso b2
    
    End Function
    
    ' Qiita
    ' 重み付きランダム
    ' http://qiita.com/divideby_zero/items/a8e749e307013ab24a0b
    ' 確率判定のサンプル
    Private Function GetRandomIndex(rnd As Random, ParamArray weightTable() As Integer) As Integer
    
        Dim totalWeight = weightTable.Sum()
        Dim value = rnd.Next(1, totalWeight + 1)
        Dim retIndex = -1
    
        For i As Integer = 0 To weightTable.Length - 1
    
            If value <= weightTable(i) Then
                retIndex = i
                Exit For
            End If
            value -= weightTable(i)
    
        Next
    
        Return retIndex
    
    End Function
    
    ' 確率判定
    ' rnd : Random クラスのインスタンス
    ' rate : 0%~100% の間を指定
    ' 指定確率と残りの確率を元に、内部テストした結果、
    ' 指定確率が選ばれた場合 true、選ばれなかった場合 false を返却
    Private Function ProbabilityJudgement(rnd As Random, rate As Integer) As Boolean
    
        ' 確率が大きい順に登録
        Dim weightTable As New List(Of Integer)
        If rate <= 100 - rate Then
            weightTable.Add(100 - rate)
            weightTable.Add(rate)
        Else
            weightTable.Add(rate)
            weightTable.Add(100 - rate)
        End If
    
        Dim index = GetRandomIndex(rnd, weightTable.ToArray())
        Dim isHit = (weightTable(index) = rate)
        Return isHit
    
    End Function
    
    ' ProbabilityJudgement メソッドの動作確認
    Private Sub ProbabilityJudgementTest()
    
        ' 5%の確率の確認
        Dim items As New List(Of Boolean)
        Dim r As New Random()
    
        For aaa As Integer = 0 To 10
    
            items.Clear()
            For i As Integer = 0 To 100000 '100
                items.Add(ProbabilityJudgement(r, 5))
            Next
    
            Console.WriteLine("当選 : {0}", items.Where(Function(x) x).Count() / items.Count() * 100)
            Console.WriteLine("落選 : {0}", items.Where(Function(x) Not x).Count() / items.Count() * 100)
            Console.WriteLine("")
    
        Next
    
        Console.ReadLine()
    
    End Sub
    

現世代の状態を表示

  •  現世代の各染色体の適応度をコンソール表示します。また、平均と最大も一緒に表示しています。 For 文使ってインデックス使うのでもよかったのですが、LINQ でもできるので使い慣れしたいのもあって、こちらを利用しました。

  • ' 現世代の状態を表示
    Public Sub ShowGeneration() Implements IGAable.ShowGeneration
    
        Console.WriteLine("")
    
        Dim items = Me.population.Select(Function(x, i) New With {.Index = i, .Data = x}).ToList()
        items.ForEach(Sub(x)
                          Console.WriteLine("個体{0} : 染色体({1}), 適応度({2})",
                                            x.Index + 1,
                                            x.Data.Chromosome,
                                            x.Data.Fitness)
                      End Sub)
    
        Console.WriteLine("--------------------------------------------------------------------")
        Dim avg = items.Average(Function(x) x.Data.Fitness)
        Dim max = items.Max(Function(x) x.Data.Fitness)
        Console.WriteLine("平均適応度 : {0}, 最大適応度 : {1}", avg, max)
    
        Console.WriteLine("")
    
    End Sub
    

実験結果と評価

  •  これらを組み込んだプログラムを実行して動作確認しました。以下はメインプログラムと表示結果です。

  • Module1.vb
    
    Sub Main()
    
        ' 第一世代を生成
        Dim worker As New GAWorker()
        worker.Generate1stGeneration()
    
        ' 第10世代まで進化させる
        For i As Integer = 1 To 10
    
            ' 現世代を評価
            worker.Evaluation()
    
            ' 現世代の状況表示
            worker.ShowGeneration()
    
            ' 選択
            worker.Selection()
    
            ' 交叉
            worker.Crossover()
    
            ' 突然変異
            worker.Mutation()
    
        Next
    
        ' 画面を閉じない
        Console.ReadLine()
    End Sub
    

  •  第1世代から第10世代までの進化の過程

  • 個体1 : 染色体(10101), 適応度(21)
    個体2 : 染色体(01110), 適応度(14)
    個体3 : 染色体(00101), 適応度(5)
    個体4 : 染色体(00111), 適応度(7)
    --------------------------------------------------------------------
    平均適応度 : 11.75, 最大適応度 : 21
    
    
    個体1 : 染色体(10110), 適応度(22)
    個体2 : 染色体(01101), 適応度(13)
    個体3 : 染色体(10111), 適応度(23)
    個体4 : 染色体(00101), 適応度(5)
    --------------------------------------------------------------------
    平均適応度 : 15.75, 最大適応度 : 23
    
    
    個体1 : 染色体(10110), 適応度(22)
    個体2 : 染色体(10111), 適応度(23)
    個体3 : 染色体(10101), 適応度(21)
    個体4 : 染色体(01111), 適応度(15)
    --------------------------------------------------------------------
    平均適応度 : 20.25, 最大適応度 : 23
    
    
    個体1 : 染色体(10110), 適応度(22)
    個体2 : 染色体(10111), 適応度(23)
    個体3 : 染色体(10101), 適応度(21)
    個体4 : 染色体(10111), 適応度(23)
    --------------------------------------------------------------------
    平均適応度 : 22.25, 最大適応度 : 23
    
    
    個体1 : 染色体(10111), 適応度(23)
    個体2 : 染色体(10111), 適応度(23)
    個体3 : 染色体(10110), 適応度(22)
    個体4 : 染色体(10111), 適応度(23)
    --------------------------------------------------------------------
    平均適応度 : 22.75, 最大適応度 : 23
    
    調整的変異を実行
    
    個体1 : 染色体(10111), 適応度(23)
    個体2 : 染色体(10111), 適応度(23)
    個体3 : 染色体(10111), 適応度(23)
    個体4 : 染色体(11111), 適応度(31)
    --------------------------------------------------------------------
    平均適応度 : 25, 最大適応度 : 31
    
    
    個体1 : 染色体(11111), 適応度(31)
    個体2 : 染色体(10111), 適応度(23)
    個体3 : 染色体(11111), 適応度(31)
    個体4 : 染色体(10111), 適応度(23)
    --------------------------------------------------------------------
    平均適応度 : 27, 最大適応度 : 31
    
    
    個体1 : 染色体(11111), 適応度(31)
    個体2 : 染色体(11111), 適応度(31)
    個体3 : 染色体(11111), 適応度(31)
    個体4 : 染色体(10111), 適応度(23)
    --------------------------------------------------------------------
    平均適応度 : 29, 最大適応度 : 31
    
    調整的変異を実行
    
    個体1 : 染色体(11111), 適応度(31)
    個体2 : 染色体(11111), 適応度(31)
    個体3 : 染色体(11111), 適応度(31)
    個体4 : 染色体(11111), 適応度(31)
    --------------------------------------------------------------------
    平均適応度 : 31, 最大適応度 : 31
    
    調整的変異を実行
    
    個体1 : 染色体(11111), 適応度(31)
    個体2 : 染色体(11111), 適応度(31)
    個体3 : 染色体(11111), 適応度(31)
    個体4 : 染色体(11111), 適応度(31)
    --------------------------------------------------------------------
    平均適応度 : 31, 最大適応度 : 31
    
    調整的変異を実行
    

  •  さて、コンソール表示された数字のかたまりだけ見てもなんのこっちゃという場合もありますので、 把握しやすいように、文字ではなく絵で見ることにします。

  • イメージ
  •  こちらは、OxyPlot を使って書いたグラフになります。 横軸が世代別を表していて、第1世代から第10世代まで、縦軸が適応度の大小を表していて、 高いほど優秀(どのくらい最適解として妥当か)という設定にしています。

  •  最大適応度の折れ線を見ると、優秀な染色体(解答候補)は、早い段階からぶっ飛んでいますね。 対して、平均適応度の折れ線を見ると、なかなか良い感じの推移速度で進化していることが分かります。

  •  遺伝的アルゴリズムで面白いのは、生命の進化でもあるんですけど、プログラム修正無しで、 導き出される答えが、だんだん優秀になっていくところでもあるな~と思いました。

  •  最後まで読んでいただきありがとうございました。

全体のプログラム

    Indivisual.vb
    
    
    ' 1つの個体情報
    Public Class Indivisual
    
        ' 染色体
        ' ターゲットにしている問題に対する、答え候補の1つ
        ' ※手抜き管理。本当は Byte(4) とかで厳格に管理するべき
        'Public Property Chromosome As Byte() = New Byte(4) {0, 0, 0, 0, 0}
        Public Property Chromosome As String = String.Empty
    
        ' 適応度
        ' ターゲットにしている問題に対する答えとして、どのくらい最適解になっているかの指標
        Public Property Fitness As Integer = -1
    
        ' コンストラクタ
        Public Sub New()
        End Sub
    
    End Class
    

    IGAable.vb
    
    
    ' 遺伝的アルゴリズムのメンバー
    Public Interface IGAable
    
        ' 第一世代の生成
        Sub Generate1stGeneration()
    
        ' 評価(各染色体メンバーに対して、適応度点数を付ける)
        Sub Evaluation()
    
        ' 選択(適応度が高いメンバーの選別、と同時に低いメンバーの淘汰)
        Sub Selection()
    
        ' 交叉(両親の優秀な遺伝子を受け継ぐ、次世代メンバーの生成)
        Sub Crossover()
    
        ' 突然変異(一定確率で呼び出される、遺伝子操作)
        Sub Mutation()
    
        ' 現世代の状態を表示
        Sub ShowGeneration()
    
    End Interface
    

    GAWorker.vb
    
    Imports System.Threading
    Imports System.Text
    Imports System.IO
    
    
    ' 遺伝子の管理を担当するクラスです。
    Public Class GAWorker
        Implements IGAable
    
        ' 本問題では、表現型がそのまま遺伝子型となり、String 型です。
        ' よって、表現型→遺伝子型への変換、逆変換の作業は不要です。
    
        ' 集団 (population) : List(Of Individual)
        ' 個体 (Indivisual) : Class
        '   染色体 (Chromosome) : String / 1 char : 遺伝子 (gene)
        '   適応度 (Fitness) : Integer
    
        ' 集団
        Private Property population As List(Of Indivisual) = Nothing
    
        ' 前世代集団
        Private Property previousPopulation As List(Of Indivisual) = Nothing
    
        ' コンストラクタ
        Public Sub New()
    
            Me.population = New List(Of Indivisual)
            Me.previousPopulation = New List(Of Indivisual)
    
            ' 前回の分析用 csv ファイルが存在する場合、削除
            If File.Exists("data.csv") Then
                File.Delete("data.csv")
            End If
    
        End Sub
    
        ' 第一世代の生成
        Public Sub Generate1stGeneration() Implements IGAable.Generate1stGeneration
    
            Dim index = 0
            While True
    
                ' 4つ作成したら抜ける
                If index = 4 Then
                    Exit While
                End If
    
                ' (調整)重複遺伝子は除外、最初から適応度が高い遺伝子も除外
                Dim chromosome = Me.GenerateChromosome()
                Dim b1 = Not Me.population.Exists(Function(x) x.Chromosome = chromosome)
                Dim b2 = Not chromosome.StartsWith("1111")
                If b1 AndAlso b2 Then
                    Me.population.Add(New Indivisual With {.Chromosome = chromosome})
                    index += 1
                End If
    
            End While
    
        End Sub
    
        Private Function GenerateChromosome() As String
    
            ' 高スペックすぎるパソコンでの動作対策、時間をずらしてランダムシードをずらす
            Thread.Sleep(1000)
    
            ' 01101 みたいな感じで、5 つ分の遺伝子の組み合わせを生成、返却
            Dim chromosome = String.Empty
            Dim rnd As New Random()
    
            For i As Integer = 0 To 4
                chromosome &= rnd.Next(2).ToString()
            Next
    
            Return chromosome
    
        End Function
    
        ' 評価(各染色体メンバーに対して、適応度点数を付ける)
        Public Sub Evaluation() Implements IGAable.Evaluation
    
            ' 染色体(10110等:String、2進数)を、10進数に変換して、適応度にセット
            Me.population.ForEach(Sub(x) x.Fitness = Convert.ToInt32(x.Chromosome, 2))
    
        End Sub
    
        ' 選択(適応度が高いメンバーの選別、と同時に低いメンバーの淘汰)
        Public Sub Selection() Implements IGAable.Selection
    
            ' 適応度の降順でソートして、上位 3 件分のみ取得
            Dim parents = Me.population.OrderByDescending(Function(x) x.Fitness).Take(3).ToList()
    
            ' 優秀なメンバーのみ残す
            Me.population.Clear()
            Me.population.AddRange(parents)
    
        End Sub
    
        ' 交叉(両親の優秀な遺伝子を受け継ぐ、次世代メンバーの生成)
        Public Sub Crossover() Implements IGAable.Crossover
    
            ' 現世代を前世代としてバックアップ
            Me.previousPopulation.Clear()
            Me.previousPopulation.AddRange(Me.population.ToList())
    
            ' メンバー数が 3 と固定されている前提なので、変数に分けて扱う
            Dim parent1 = Me.population(0).Chromosome
            Dim parent2 = Me.population(1).Chromosome
            Dim parent3 = Me.population(2).Chromosome
    
            ' 個体1と個体2、個体1と個体3を交叉
            Dim childA1 = parent1.Substring(0, 2) & parent2.Substring(2)
            Dim childA2 = parent2.Substring(0, 2) & parent1.Substring(2)
    
            Dim childB1 = parent1.Substring(0, 2) & parent3.Substring(2)
            Dim childB2 = parent3.Substring(0, 2) & parent1.Substring(2)
    
            ' 現世代から次世代へ世代交代
            Me.population.Clear()
            Me.population.Add(New Indivisual With {.Chromosome = childA1})
            Me.population.Add(New Indivisual With {.Chromosome = childA2})
            Me.population.Add(New Indivisual With {.Chromosome = childB1})
            Me.population.Add(New Indivisual With {.Chromosome = childB2})
    
        End Sub
    
        ' 突然変異(一定確率で呼び出される、遺伝子操作)
        Public Sub Mutation() Implements IGAable.Mutation
    
            If IsStopEvolution() Then
                ' 進化が停止した(と判断した場合)
    
                ' (調整)子供4の遺伝子を組み替える
                ' 右から左へ見ていき、最初に見つかった 0 を 1 に変える
                Dim chromosome = Me.population(3).Chromosome
                Dim reversed = chromosome.ToCharArray().Reverse()
                Dim found = False
    
                chromosome = String.Empty
                For Each gene In reversed
    
                    If found = False AndAlso gene = "0"c Then
                        gene = "1"c
                        found = True
                    End If
                    chromosome &= gene
    
                Next
                chromosome = String.Join(String.Empty, chromosome.ToCharArray().Reverse())
                Me.population(3).Chromosome = chromosome
                Console.WriteLine("調整的変異を実行")
    
            Else
                ' 進化中
    
                ' wikipedia では、突然変異率は、0.1%~1%、高くても数%とのこと。
                ' 1%の確率で突然変異を起こす
                If Not Me.ProbabilityJudgement(New Random(), 1) Then
                    Exit Sub
                End If
    
                ' 子供4の遺伝子を組み替える
                Dim chromosome = Me.population(3).Chromosome
                Dim c1 = chromosome.Substring(0, 1)
                Dim c2 = chromosome.Substring(1, 1)
                Dim c3 = chromosome.Substring(2)
    
                c2 = IIf(c2 = "0", "1", "0").ToString()
                Me.population(3).Chromosome = c1 & c2 & c3
                Console.WriteLine("突然変異を実行")
    
            End If
    
        End Sub
    
        ' 前世代と現世代が変わっていない場合、かつ現世代の染色体が全て同じ場合 true、違う場合 false
        Private Function IsStopEvolution() As Boolean
    
            Dim b1 = Me.previousPopulation(0).Chromosome = Me.population(0).Chromosome AndAlso
                          Me.previousPopulation(1).Chromosome = Me.population(1).Chromosome AndAlso
                          Me.previousPopulation(2).Chromosome = Me.population(2).Chromosome
            Dim b2 = Me.population(0).Chromosome = Me.population(1).Chromosome AndAlso
                          Me.population(0).Chromosome = Me.population(2).Chromosome AndAlso
                          Me.population(0).Chromosome = Me.population(3).Chromosome
    
            Return b1 AndAlso b2
    
        End Function
    
        ' Qiita
        ' 重み付きランダム
        ' http://qiita.com/divideby_zero/items/a8e749e307013ab24a0b
        ' 確率判定のサンプル
        Private Function GetRandomIndex(rnd As Random, ParamArray weightTable() As Integer) As Integer
    
            Dim totalWeight = weightTable.Sum()
            Dim value = rnd.Next(1, totalWeight + 1)
            Dim retIndex = -1
    
            For i As Integer = 0 To weightTable.Length - 1
    
                If value <= weightTable(i) Then
                    retIndex = i
                    Exit For
                End If
                value -= weightTable(i)
    
            Next
    
            Return retIndex
    
        End Function
    
        ' 確率判定
        ' rnd : Random クラスのインスタンス
        ' rate : 0%~100% の間を指定
        ' 指定確率と残りの確率を元に、内部テストした結果、
        ' 指定確率が選ばれた場合 true、選ばれなかった場合 false を返却
        Private Function ProbabilityJudgement(rnd As Random, rate As Integer) As Boolean
    
            ' 確率が大きい順に登録
            Dim weightTable As New List(Of Integer)
            If rate <= 100 - rate Then
                weightTable.Add(100 - rate)
                weightTable.Add(rate)
            Else
                weightTable.Add(rate)
                weightTable.Add(100 - rate)
            End If
    
            Dim index = GetRandomIndex(rnd, weightTable.ToArray())
            Dim isHit = (weightTable(index) = rate)
            Return isHit
    
        End Function
    
        ' ProbabilityJudgement メソッドの動作確認
        Private Sub ProbabilityJudgementTest()
    
            ' 5%の確率の確認
            Dim items As New List(Of Boolean)
            Dim r As New Random()
    
            For aaa As Integer = 0 To 10
    
                items.Clear()
                For i As Integer = 0 To 100000 '100
                    items.Add(ProbabilityJudgement(r, 5))
                Next
    
                Console.WriteLine("当選 : {0}", items.Where(Function(x) x).Count() / items.Count() * 100)
                Console.WriteLine("落選 : {0}", items.Where(Function(x) Not x).Count() / items.Count() * 100)
                Console.WriteLine("")
    
            Next
    
            Console.ReadLine()
    
        End Sub
    
        ' 現世代の状態を表示
        Public Sub ShowGeneration() Implements IGAable.ShowGeneration
    
            Console.WriteLine("")
    
            Dim items = Me.population.Select(Function(x, i) New With {.Index = i, .Data = x}).ToList()
            items.ForEach(Sub(x)
                              Console.WriteLine("個体{0} : 染色体({1}), 適応度({2})",
                                                x.Index + 1,
                                                x.Data.Chromosome,
                                                x.Data.Fitness)
                          End Sub)
    
            Console.WriteLine("--------------------------------------------------------------------")
            Dim avg = items.Average(Function(x) x.Data.Fitness)
            Dim max = items.Max(Function(x) x.Data.Fitness)
            Console.WriteLine("平均適応度 : {0}, 最大適応度 : {1}", avg, max)
    
            Console.WriteLine("")
    
        End Sub
    
        ' 分析用 csv ファイルを出力
        Public Sub OutputGeneration()
    
            Dim number = 0
            Dim avg = Me.population.Average(Function(x) x.Fitness)
            Dim max = Me.population.Max(Function(x) x.Fitness)
    
            Dim csvFile = "data.csv"
            If File.Exists(csvFile) Then
    
                ' ファイルが存在する場合、最終行データから前世代番号を取得して、現世代番号をセット
                Dim csvDatas = File.ReadAllLines(csvFile).Reverse()
                For Each csvData In csvDatas
    
                    Dim items = csvData.Split(","c)
                    If Not IsNumeric(items(0)) Then
                        Continue For
                    End If
    
                    number = CType(items(0), Integer)
                    number += 1
                    Exit For
    
                Next
    
                Dim wData = String.Format("{0},{1},{2}" & vbNewLine, number, avg, max)
                File.AppendAllText(csvFile, wData)
    
            Else
    
                number = 1
                Dim wData = String.Format("{0},{1},{2}" & vbNewLine, "GenerationNumber", "Average", "Max")
                File.WriteAllText(csvFile, wData)
    
                wData = String.Format("{0},{1},{2}" & vbNewLine, number, avg, max)
                File.AppendAllText(csvFile, wData)
    
            End If
    
        End Sub
    
    End Class
    

    Module1.vb
    
    Module Module1
    
        Sub Main()
    
            ' 第一世代を生成
            Dim worker As New GAWorker()
            worker.Generate1stGeneration()
    
            ' 第10世代まで進化させる
            For i As Integer = 1 To 10
    
                ' 現世代を評価
                worker.Evaluation()
    
                ' 現世代の状況表示
                worker.ShowGeneration()
                ' 分析用 csv ファイルを出力
                worker.OutputGeneration()
    
                ' 選択
                worker.Selection()
    
                ' 交叉
                worker.Crossover()
    
                ' 突然変異
                worker.Mutation()
    
            Next
    
            ' 画面を閉じない
            Console.ReadLine()
        End Sub
    
    End Module