零からはじめまして

0からアフィリエイトをやってみてる大学生が日々を綴るブログです。

遺伝的アルゴリズムを用いた基礎的プログラミング

ついこのあいだのことなのですが、サークルの活動の一環でプログラムを書くことになりました。

内容は何でもよかったのですが、当時僕が気になっていた遺伝的アルゴリズムの学習のいい機会だと思って、それを使用したプログラムを書くことにしました。

 

遺伝的アルゴリズムと聞いて何だか難しそうな雰囲気だと、思う方もいるかもしれませんが、調べたり少しかじったりすると、プログラム初心者の僕でも三日である程度書けるほど簡単なものです。

 

というのも、サークル誌に記事を投稿しなければいけなかったため、猶予が三日しかなかったのだ。

そのため、公開しているソースコードは煩雑であるものの、僕の備忘録的な意味合いでは有益なものなのである。

 

 

遺伝的アルゴリズム概要

遺伝的アルゴリズムをざっくり説明すると、プログラムに偶然性を介入させるアルゴリズムのことです。

偶然性とは、例えば乱数を用いて値を決めたり、改変させたりすれば偶然性を介入させることができますよね?

ただ、そのプログラムを一回実行しただけでは求める値は求められないため、何度も繰り返し実行して、求める値の近似値を探索するため、解探索型アルゴリズムとも呼ばれます。

具体的には、以下、僕の記事より抜粋。

遺伝的アルゴリズムとは

遺伝的アルゴリズムとは生物進化を模倣し、近似解を求める解探索アルゴリズムである。データを遺伝子で表現した個体を複数用意し、適応度の高い個体を優先的に交叉等の操作を加えながら解を探索する。遺伝子の表現の仕方によっては様々な問題に活用可能である。例えば、シフトの決定やセールスマン問題、組み合わせ問題である。

 

用いた言語、及び環境

記事の投稿まで三日しかなかったため、その場にあるもので作るしかなかった。

python2.7系は環境が整っていたものの、手元には資料がなかったため断念。

python3系は環境構築をしようとしたものの、なぜか上手くいかなかったため断念。

C言語は当時は母に有料の開発環境しかないと言われ断念したが、後に無料の開発環境があることを知り、チクショーーー!!

 

というわけで、情弱なプログラマー理系という、理系にあるまじきカスみたいな僕はOSに標準で備わっている環境を使うことになった。

 

そのため、使用しているOSがwindowsの僕はVBSの使用に踏み切った。

 

VBSとか時代遅れワロタ、とか言っているあなたはVBSの簡便さを知らずに死んでいくがいい。

僕はアイコンをダブルクリックするだけで実行できるVBSが好きになりました。

 

というのは嘘で、プログラム書いた後に、これC++とかpythonでやっときゃよかった…ってなりましたが、精神衛生上いくないので考えるのをやめました。

 

ただ、僕はVBSを微塵も齧ったことがなかったため、それの勉強をしながらプログラムを書きました。

 

基礎的なプログラム

いきなりセールスマン問題とか、憤死確定だと思ったので、超簡単なプログラムを書きました。

内容は0と1の5桁の数値を遺伝子と考えて、それを目標値に近づけること。

目標値は11111にしました。

つまり、プログラムを実行していく過程で、数値が11111に近づいていく傾向が見られればよいのです。

以下記事より抜粋。

基礎的なプログラム

 VBSでプログラムをほとんど作成したことがないので、VBSになれることと、遺伝的アルゴリズムの基礎を用いたプログラムを作成した。

 内容はというと、遺伝子を10で表した文字列としたときに、解の近似解を求めるものである。

 今回は基礎的なものということで、5桁の文字列にすることにした。

 コードは最も単純なもので解は11111で初期集団はランダムな数値の20個で、一点交叉を用いることにし、突然変異は5%の確率にした。

 添付した画像はそれぞれ、上の20個が個体で、一番下の数字が世代数である。

 このように遺伝的アルゴリズムを用いたプログラムは、コードを変えずに何度も試行し、求めたい解の近似値を求める。

f:id:fyuyu:20170528132933j:plain

こんな風に取り込んだデータを用いて、プログラムを実行して、何回も回数をこなすことで、目標値の近似解が求まります。

このプログラムのソースは全文公開します。

(プログラムの保守性は皆無です。カスな理系大学生のソースコードがどのようなものか見てみたいという方は、楽しめる思います。)

Option Explicit
Dim objFSO,objFile,Ary(20),Count
Dim Ans,Gen_Count,Value_Ary(20),i,j,Cpy_Ary(10)
Dim L_Num(2),M_num(2),R_num(2)
Count = 0
Ans = 11111
'ファイルオープン
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("input.txt",1,False)
'ファイル読み込み&評価値0
Do Until objFile.AtEndOfStream
  If Count < UBound(Ary) Then
    Ary(Count) = objFile.ReadLine
    Value_Ary(Count) = 0
    Count = Count + 1
  Else
    Gen_Count = objFile.ReadLine
  End If
Loop
'ファイルクローズ
objFile.Close
Set objFile = Nothing
'評価値の判定
For i = 0 To UBound(Ary)
  For j = 1 To Len(Ans)
    If StrComp(Mid(Ary(i),j,1),Mid(Ans,j,1)) = 0 Then
      Value_Ary(i) = Value_Ary(i) + 1
    End If
  Next
Next
'評価値によるバブルソート昇順
For i = 0 To UBound(Value_Ary) - 2
  For j = i + 1 To UBound(Value_Ary) - 1
    If Value_Ary(j) > Value_Ary(i) Then
      Call swap(Value_Ary(i), Value_Ary(j))
      Call swap(Ary(i), Ary(j))
    End If
  Next
Next
'配列の分割&上位10に絞る
For i = 0 To UBound(Cpy_Ary) - 1
  Cpy_Ary(i) = Ary(i)
Next
'ランダムソート
For i = 0 To UBound(Cpy_Ary) - 2
  For j = i + 1 To UBound(Cpy_Ary) - 1
    If Int*1
    End If
  Next
Next
'ペアの決定&下二桁の交叉&上二桁の交叉
For i = 0 To UBound(Cpy_Ary) / 2 - 1
  L_Num(0) = Mid(Cpy_Ary(i * 2),1,2)
  M_Num(0) = Mid(Cpy_Ary(i * 2),3,1)
  R_Num(0) = Mid(Cpy_Ary(i * 2),4,2)
  L_Num(1) = Mid(Cpy_Ary(i * 2 + 1),1,2)
  M_Num(1) = Mid(Cpy_Ary(i * 2 + 1),3,1)
  R_Num(1) = Mid(Cpy_Ary(i * 2 + 1),4,2)
  Ary(i * 4)=L_Num(0)&M_Num(1)&R_Num(1)
  Ary(i * 4 + 1)=L_Num(1)&M_Num(0)&R_Num(0)
  Ary(i * 4 + 2)=L_Num(1)&M_Num(1)&R_Num(0)
  Ary(i * 4 + 3)=L_Num(0)&M_Num(0)&R_Num(1)
Next
'突然変異の判定
For i = 0 To UBound(Ary) - 1
  If Int*2
Next
objFile.WriteLine(Gen_Count + 1)
'inputファイルクローズ
objFile.Close
Set objFile = Nothing
'outputファイルオープン
  Set objFile = objFSO.CreateTextFile("output.txt",8,False)
For i = 0 To UBound(Ary) - 1
  objFile.WriteLine(Ary(i))
Next
objFile.WriteLine(Gen_Count + 1)
'outputファイルクローズ
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Sub swap(ByRef x, ByRef y) ' 汎用の交換用
    Dim d
    d = x
    x = y
    y = d
End Sub
 
内容はいたって簡単で、
適当に入力したinput.txtから数値を読み取って、一点交叉とか突然変異とか選定して、input.txtとoutput.txtに出力するだけです。
アイコンをクリックするたびに、一回実行するようになっています。
 
このくらいなら、まだ見られるプログラムかな…。
ていうか、次のプログラムが酷すぎて、こっちが綺麗に見える。

ちょっと応用プログラミング

セールスマン問題を解こうとしました。
ただ失敗して、次のような欠点を抱えています。
  • めっちゃ時間かかる
  • 実質15個くらいしかデータ扱えない
  • めっちゃ汚い

だって、VBS使うの初めてだったんだもん。

遺伝的アルゴリズムやり始めたばっかだもん。

そもそもプログラム自体そんなに書いてなかったんだもん。

てゆうか、独学で自己流とか無謀にも程があると思うんだもん。

うん、次はもっとうまくやるよ。

 

以下、記事より抜粋。

少し応用したプログラミング

 セールスマン問題というのを知っていますか?

 セールスマン問題は、家や都市間を移動する際に、どのような順番で廻れば効率がよいのかを考える問題です。

 プログラムの設計としては、世代数を記したテキストファイルと、街とその街の座標を記したテキストファイルから読み込む。世代数が0のときだけ、初期個体を100体生成させ、この中から優秀個体を30体と優秀個体を順序交叉させ作った50体をテキストファイルに出力させ、世代数が1以上のときはこの80体の個体と新たに作った20体を用いて、同様な処理を行った。

 プログラムでは何世帯まで実行するか実装させ、より多くの試行回数を行うことができるようにした。このとき、試行毎に、最優秀個体の評価点と順序データと都市の順番をテキストファイルに出力させることで、より確認がしやすくなった。

個体数とか違うとことかあるかも。

 

f:id:fyuyu:20170528135029j:plain

f:id:fyuyu:20170528135115j:plain

これが15個のデータで回した結果です。

アルファベット書いてない点は使わなかったデータの名残です。

a~z市まであったのだけれど、a~oの15個しか使わなかったということね。

市にはx値とy値を座標としてデータ入れてて、単純に巡回距離の最短を目指しました。

スタートはa市です。

ちなみに、この結果は6813世代目に出た結果です。

 

一応形にはなったけど、ループ文とか多すぎてめっちゃ時間かかる。

一万回実行させると40分くらいかかる。

というか、一万回実行しても結果出ないってどういうことだってばよ。

効率悪すぎるにもほどがある。

まあ、とりあえずソースは載せるけど、恐らく後に僕自身が見て嘲笑うだけだと思う。

僕以外に解読できる人いるのだろうか。

サークル誌ではいないと思って載せなかったけど…。

因みに、この下はソースだけにするからね。

何か質問とかあれば、僕の答えられる範囲で答えます。

(なぜか分からないけど、スペースが一つ抜けた結果さらに判読不能に!!)

(もはや書いた本人が分からないという世紀末状態!!!)

Option Explicit
Dim Input,ret,i
ret = MsgBox("あらかじめ入力ファイルinput_City.txtを用意してください." & vbCr & "中断しますか?", vbYesNo)
If ret = vbYes Then
  WScript.Quit
End If
Input = InputBox("世代数を入力してください.")
MsgBox (Input & "を入力しました.")
For i=0 To Input - 1
  procedure
  If i Mod 200 = 0 Then
    reserch
  End If
Next
 
MsgBox ("終了しました。")
Sub reserch()
Dim objFSO,objFile,Value_Ary(),Sel_Ary(),Part_Ary(),i,j
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("output_Value.txt",1,False)
i = - 1
Do Until objFile.AtEndOfStream
  i = i + 1
  Redim Preserve Value_Ary(i),Sel_Ary(i),Part_Ary(i)
  Value_Ary(i) = objFile.ReadLine
  Sel_Ary(i) = objFile.ReadLine
  Part_Ary(i) = objFile.ReadLine
Loop
For i = 0 To UBound(Value_Ary) - 1
  For j = i + 1 To UBound(Value_Ary)
    If Value_Ary(j) - Value_Ary(i) > 0 Then
      Call Swap(Sel_Ary(i),Sel_Ary(j))
      Call Swap(Value_Ary(i),Value_Ary(j))
      Call Swap(Part_Ary(i),Part_Ary(j))
    End If
  Next
Next
objFile.Close
Set objFile = Nothing
Set objFile = objFSO.CreateTextFile("output_Sort.txt",2,False)
For i = 0 To UBound(Value_Ary)
  objFile.WriteLine(Value_Ary(i))
  objFile.WriteLine(Sel_Ary(i))
  objFile.WriteLine(Part_Ary(i))
Next
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
End Sub
Sub procedure()
Dim objFSO,objFile
Dim City_Ary(),Place_Ary(),Sel_Ary(199),Cpy_Ary(),Ary(),Value_Ary(),L_Num(),R_Num(),Cpy_Place()
Dim Max_Value,Max_Value_Sel,Left_Len,Max_Value_City,Split_Sel
Dim Count,Gen_Count,i,j,k,l,First_City,First_Place,Cpy_Count,Cpy_Num,Top_Num,Num
Count = 0 
Top_Num = 100
'ファイルオープン
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("input_City.txt",1,False)
'ファイル読み込み&評価値0&配列決定
Do Until objFile.AtEndOfStream
  If Count Mod 2 = 0 Then
    If Count = 0 Then
      First_City = objFile.ReadLine
    Else
      Redim Preserve City_Ary(Count / 2 - 1)
      City_Ary(Count / 2 - 1) = objFile.ReadLine
    End If
  Else
    If Count = 1 Then
      First_Place = objFile.ReadLine
    Else
      Redim Preserve Place_Ary*3
      Call Swap(Value_Ary(i),Value_Ary(j))
    End If
  Next
Next
Max_Value = Value_Ary(0)*1000
Max_Value_Sel = Sel_Ary(0)
Split_Sel = Split(Sel_Ary(0)," ")
For i = 0 To UBound(City_Ary)
  Call Sort_Place_Point(Split_Sel(i),City_Ary,i)
Next
For i = 0 To UBound(City_Ary)
  Redim Preserve Cpy_Place(i)
  Cpy_Place(i) = City_Ary(UBound(City_Ary) - i)   
Next
For i = 0 To UBound(Split_Sel) + 1
  If i = 0 Then 
    Max_Value_City = First_City
  Else
    Max_Value_City = Max_Value_City & "→" & Cpy_Place(i - 1)
  End If
Next
'上位選定
For i = 0 To Top_Num - 1
  Redim Preserve Cpy_Ary(i)
  Cpy_Ary(i) = Sel_Ary(i)
Next
'突然変異
For i = 0 To Top_Num - 1
  Randomize
  If CInt(3*Rnd) + 1 = 1 Then
    Randomize
    Count = Int(24*Rnd) + 1
    Cpy_Ary(i) = Replace(Cpy_Ary(i),"Count","Int*4
    End If
  Next
Next
'ペアの決定&順序交叉
For i = 0 To UBound(Cpy_Ary)
  Cpy_Ary(i) = Split(Cpy_Ary(i)," ")
Next
Randomize
Left_Len = Int*5 - 2) * Rnd) + 1
For i = 0 To UBound(Cpy_Ary)
  For j = 0 To Left_Len
    Redim Preserve L_Num(i)
    If j = 0 Then
      L_Num(i) = Cpy_Ary(i)(j)
    Else 
      L_Num(i) = L_Num(i) & " " & Cpy_Ary(i)(j)
    End If
  Next
  For k = j To UBound(Cpy_Ary(0))
    Redim Preserve R_Num(i)
    If k = j Then
      R_Num(i) = Cpy_Ary(i)(k)
    Else 
      R_Num(i) = R_Num(i) & " " & Cpy_Ary(i)(k)
    End If
  Next 
Next
For i = 0 To (UBound(Cpy_Ary) + 1) / 2 - 1
  Cpy_Ary(i * 2) = L_Num(i * 2) & " " & R_Num(i * 2 + 1)
  Cpy_Ary(i * 2 + 1) = L_Num(i * 2 + 1) & " " & R_Num(i * 2)
Next
'ファイルオープン
Set objFile = objFSO.CreateTextFile("input_Gene.txt",2,False)
objFile.WriteLine(Gen_Count)
'ファイルクローズ
objFile.Close
Set objFile = Nothing
'ファイルオープン
Set objFile = objFSO.OpenTextFile("input_Data.txt",2,False)
Cpy_Num = UBound(Cpy_Ary)
For i = 1 To UBound(Sel_Ary) - Cpy_Num
  Redim Preserve Cpy_Ary(i + Cpy_Num)
  For j = 0 To UBound(City_Ary)
    Redim Preserve Ary(j)
    Randomize
    Ary(j) = CInt*6
Next
'ファイルクローズ
objFile.Close
Set objFile = Nothing
'ファイルオープン
Set objFile = objFSO.OpenTextFile("output_Value.txt", 8, True)
objFile.WriteLine(Max_Value)
objFile.WriteLine(Max_Value_Sel)
objFile.WriteLine(Max_Value_City)
'ファイルクローズ
objFile.Close
Set objFile = Nothing
If Gen_Count Mod 3000 = 0 Then
  Sort
End If
Set objFSO = Nothing
End Sub
Function Determine_Value(ByVal Select_Num,ByVal Place_Point(),ByVal First_Place)'価値決定関数
Dim i,j,Cpy_Place()
Select_Num = Split(Select_Num," ")
For i = 0 To UBound(Place_Point)
  Call Sort_Place_Point(Select_Num(i),Place_Point,i)
Next
For i = 0 To UBound(Place_Point)
  Redim Preserve Cpy_Place(i)
  Cpy_Place(i) = Place_Point(UBound(Place_Point) - i)
Next
Determine_Value = 1 / Distance_Place_Point(Cpy_Place,First_Place)
End Function
Sub Sort_Place_Point(ByVal Num,ByRef Point_Ary(),ByVal count)'順序ソート
Dim i
Num = Num + count
For i = 0 To Num - 2
  Call Swap(Point_Ary(Num - i - 2),Point_Ary(Num - i - 1))
Next
End Sub
Function Distance_Place_Point(ByVal Point(),ByVal First_Point)'距離計算
Dim dx(),dy(),dp()
Dim i,j
Distance_Place_Point = 0
First_Point = Split(First_Point,",")
For i = 0 To UBound(Point)
  Point(i) = Split(Point(i),",")
Next
For i = 0 To UBound(Point)
  Redim Preserve dx(i),dy(i)
  If i = 0 Then
    dx(i) = First_Point(0) - Point(i)(0)
    dy(i) = First_Point(1) - Point(i)(1)
  Else
    dx(i) = Point(i - 1)(0) - Point(i)(0)
    dy(i) = Point(i - 1)(1) - Point(i)(1)
  End If
Next
For i = 0 To UBound(dx)
  Redim Preserve dp(i)
  dp(i) = Sqr(dx(i) * dx(i) + dy(i) * dy(i))
  Distance_Place_Point = Distance_Place_Point + dp(i)
Next
End Function
Sub Sort()
Dim objFSO,objFile,Value_Ary(),Sel_Ary(),Part_Ary(),i,j
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("output_Sort.txt",1,False)
i = 0
Do Until objFile.AtEndOfStream
  If i < 200 Then
    Redim Preserve Value_Ary(i),Sel_Ary(i),Part_Ary(i)
    Value_Ary(i) = objFile.ReadLine
    Sel_Ary(i) = objFile.ReadLine
    Part_Ary(i) = objFile.ReadLine
  Else
    Exit Do
  End If
  If i > 5 Then
    If Value_Ary(i) = Value_Ary(i - 1) Then
      If Value_Ary(i - 1) = Value_Ary(i - 2) Then
        If Value_Ary(i - 3) = Value_Ary(i - 4) Then
          If Value_Ary(i - 4) = Value_Ary(i - 5) Then
            i = i - 1
          End If
        End If
      End If
    End If
  End If
  i = i + 1
Loop

objFile.Close
Set objFile = Nothing
Set objFile = objFSO.OpenTextFile("input_Sort.txt",2,True)
For i = 0 To UBound(Sel_Ary)
  objFile.WriteLine(Sel_Ary(i))
Next
objFile.Close
Set objFile = Nothing
Set objFile = objFSO.OpenTextFile("output_Data.txt",2,True)
For i = 0 To UBound(Sel_Ary)
  objFile.WriteLine(Value_Ary(i))
  objFile.WriteLine(Sel_Ary(i))
  objFile.WriteLine(Part_Ary(i))
Next
objFile.Close
Set objFile = Nothing
End Sub
Sub Swap(ByRef x, ByRef y) '汎用ソート
    Dim d
    d = x
    x = y
    y = d
End Sub
 
 
 
お粗末さまでした。。

*1:2 * Rnd) + 1) = 1 Then
      Call swap(Cpy_Ary(i), Cpy_Ary(j

*2:20 * Rnd) + 1) = 1 Then
    j=Int((Len(Ans) - 1)*Rnd)
    If Mid(Ary(i),j,1) = 1 Then
      Ary(i) = Replace(Ary(i),"0","1",1,1,1)
    Else
      Ary(i) = Replace(Ary(i),"1","0",1,1,1)
    End If
  End If
Next
'inputファイルオープン
Set objFile = objFSO.CreateTextFile("input.txt",2,True)
'input出力
For i = 0 To UBound(Ary) - 1
  objFile.WriteLine(Ary(i

*3:Count - 1) / 2 - 1)
      Place_Ary((Count - 1) / 2 - 1) = objFile.ReadLine
    End If
  End If
Count = Count + 1
Loop

Count = 0
'ファイルクローズ
objFile.Close
Set objFile = Nothing
'ファイルオープン
Set objFile = objFSO.OpenTextFile("input_Gene.txt",1,False)
Do Until objFile.AtEndOfStream   
  Gen_Count = objFile.ReadLine
Loop
'ファイルクローズ
objFile.Close
Set objFile = Nothing
If Gen_Count = 0 Then
  For i = 0 To UBound(Sel_Ary)
    For j = 0 To UBound(City_Ary)
      Redim Preserve Ary(j)
      Randomize
      Ary(j) = CInt((UBound(City_Ary) - j) * Rnd + 1)
    Next
    Sel_Ary(i) = Join(Ary)
  Next
Else
'個体読み込み
'ファイルオープン
  Count = - 1
  If Gen_Count Mod 150 = 0 Then
    If Gen_Count > 3000 Then
      Set objFile = objFSO.OpenTextFile("input_Sort.txt",1,False)
    Else
      Set objFile = objFSO.OpenTextFile("input_Data.txt",1,False)
    End If 
  Else
    Set objFile = objFSO.OpenTextFile("input_Data.txt",1,False)
  End If
  Do Until objFile.AtEndOfStream   
    If Count < UBound(Sel_Ary) Then  
      Count = Count + 1
      Sel_Ary(Count) = objFile.ReadLine
    Else
      Num = objFile.Readline
    End If
  Loop
'ファイルクローズ
  objFile.Close
  Set objFile = Nothing
End If
Cpy_Count = Count
Gen_Count = Gen_Count + 1

'評価値決定
For i = 0 To UBound(Sel_Ary)
  Redim Preserve Value_Ary(i)
  Value_Ary(i) = Determine_Value(Sel_Ary(i),Place_Ary,First_Place)
Next
'評価値によるバブルソート昇順
For i = 0 To UBound(Value_Ary) - 1
  For j = i + 1 To UBound(Value_Ary)
    If Value_Ary(j) > Value_Ary(i) Then
      Call Swap(Sel_Ary(i),Sel_Ary(j

*4:Count - 2)*Rnd) + 1")
  End If
Next

'ランダムソート
For i = 0 To UBound(Cpy_Ary) - 1
  For j = i + 1 To UBound(Cpy_Ary)
    Randomize
    If Int(Rnd) + 1 = 1 Then
      Call swap(Cpy_Ary(i), Cpy_Ary(j

*5:UBound(Cpy_Ary(0

*6:UBound(City_Ary) - j) * Rnd + 1)
  Next
  Cpy_Ary(i + Cpy_Num) = Join(Ary)
Next

For i = 0 To UBound(Cpy_Ary)
  objFile.WriteLine (Cpy_Ary(i