遺伝的アルゴリズムを用いた基礎的プログラミング
ついこのあいだのことなのですが、サークルの活動の一環でプログラムを書くことになりました。
内容は何でもよかったのですが、当時僕が気になっていた遺伝的アルゴリズムの学習のいい機会だと思って、それを使用したプログラムを書くことにしました。
遺伝的アルゴリズムと聞いて何だか難しそうな雰囲気だと、思う方もいるかもしれませんが、調べたり少しかじったりすると、プログラム初心者の僕でも三日である程度書けるほど簡単なものです。
というのも、サークル誌に記事を投稿しなければいけなかったため、猶予が三日しかなかったのだ。
そのため、公開しているソースコードは煩雑であるものの、僕の備忘録的な意味合いでは有益なものなのである。
遺伝的アルゴリズム概要
遺伝的アルゴリズムをざっくり説明すると、プログラムに偶然性を介入させるアルゴリズムのことです。
偶然性とは、例えば乱数を用いて値を決めたり、改変させたりすれば偶然性を介入させることができますよね？
ただ、そのプログラムを一回実行しただけでは求める値は求められないため、何度も繰り返し実行して、求める値の近似値を探索するため、解探索型アルゴリズムとも呼ばれます。
具体的には、以下、僕の記事より抜粋。
遺伝的アルゴリズムとは生物進化を模倣し、近似解を求める解探索アルゴリズムである。データを遺伝子で表現した個体を複数用意し、適応度の高い個体を優先的に交叉等の操作を加えながら解を探索する。遺伝子の表現の仕方によっては様々な問題に活用可能である。例えば、シフトの決定やセールスマン問題、組み合わせ問題である。
用いた言語、及び環境
- VBS
- windows
記事の投稿まで三日しかなかったため、その場にあるもので作るしかなかった。
python2.7系は環境が整っていたものの、手元には資料がなかったため断念。
python3系は環境構築をしようとしたものの、なぜか上手くいかなかったため断念。
C言語は当時は母に有料の開発環境しかないと言われ断念したが、後に無料の開発環境があることを知り、チクショーーー！！
というわけで、情弱なプログラマー理系という、理系にあるまじきカスみたいな僕はOSに標準で備わっている環境を使うことになった。
そのため、使用しているOSがwindowsの僕はVBSの使用に踏み切った。
VBSとか時代遅れワロタ、とか言っているあなたはVBSの簡便さを知らずに死んでいくがいい。
僕はアイコンをダブルクリックするだけで実行できるVBSが好きになりました。
というのは嘘で、プログラム書いた後に、これC++とかpythonでやっときゃよかった…ってなりましたが、精神衛生上いくないので考えるのをやめました。
ただ、僕はVBSを微塵も齧ったことがなかったため、それの勉強をしながらプログラムを書きました。
基礎的なプログラム
いきなりセールスマン問題とか、憤死確定だと思ったので、超簡単なプログラムを書きました。
内容は0と1の5桁の数値を遺伝子と考えて、それを目標値に近づけること。
目標値は11111にしました。
つまり、プログラムを実行していく過程で、数値が11111に近づいていく傾向が見られればよいのです。
以下記事より抜粋。
基礎的なプログラム
VBSでプログラムをほとんど作成したことがないので、VBSになれることと、遺伝的アルゴリズムの基礎を用いたプログラムを作成した。
内容はというと、遺伝子を1と0で表した文字列としたときに、解の近似解を求めるものである。
今回は基礎的なものということで、5桁の文字列にすることにした。
コードは最も単純なもので解は11111で初期集団はランダムな数値の20個で、一点交叉を用いることにし、突然変異は5％の確率にした。
添付した画像はそれぞれ、上の20個が個体で、一番下の数字が世代数である。
このように遺伝的アルゴリズムを用いたプログラムは、コードを変えずに何度も試行し、求めたい解の近似値を求める。
こんな風に取り込んだデータを用いて、プログラムを実行して、何回も回数をこなすことで、目標値の近似解が求まります。
このプログラムのソースは全文公開します。
（プログラムの保守性は皆無です。カスな理系大学生のソースコードがどのようなものか見てみたいという方は、楽しめる思います。）
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)
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
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
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)
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
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Sub swap(ByRef x, ByRef y) ' 汎用の交換用
Dim d
d = x
x = y
y = d
End Sub
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体を用いて、同様な処理を行った。
プログラムでは何世帯まで実行するか実装させ、より多くの試行回数を行うことができるようにした。このとき、試行毎に、最優秀個体の評価点と順序データと都市の順番をテキストファイルに出力させることで、より確認がしやすくなった。
個体数とか違うとことかあるかも。
これが15個のデータで回した結果です。
アルファベット書いてない点は使わなかったデータの名残です。
a~z市まであったのだけれど、a~oの15個しか使わなかったということね。
市にはｘ値とｙ値を座標としてデータ入れてて、単純に巡回距離の最短を目指しました。
スタートはa市です。
ちなみに、この結果は6813世代目に出た結果です。
一応形にはなったけど、ループ文とか多すぎてめっちゃ時間かかる。
一万回実行させると40分くらいかかる。
というか、一万回実行しても結果出ないってどういうことだってばよ。
効率悪すぎるにもほどがある。
まあ、とりあえずソースは載せるけど、恐らく後に僕自身が見て嘲笑うだけだと思う。
僕以外に解読できる人いるのだろうか。
サークル誌ではいないと思って載せなかったけど…。
因みに、この下はソースだけにするからね。
何か質問とかあれば、僕の答えられる範囲で答えます。
（なぜか分からないけど、スペースが一つ抜けた結果さらに判読不能に！！）
（もはや書いた本人が分からないという世紀末状態！！！）
Option Explicit
Dim Input,ret,i
ret = MsgBox("あらかじめ入力ファイルinput_City.txtを用意してください." & vbCr & "中断しますか？", vbYesNo)
If ret = vbYes Then
WScript.Quit
End If
If ret = vbYes Then
WScript.Quit
End If
Input = InputBox("世代数を入力してください.")
MsgBox (Input & "を入力しました.")
MsgBox (Input & "を入力しました.")
For i=0 To Input - 1
procedure
If i Mod 200 = 0 Then
reserch
End If
Next
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)
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
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
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
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()
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
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)
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
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)
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
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
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
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
Cpy_Ary(i) = Split(Cpy_Ary(i)," ")
Next
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 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
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)
Set objFile = objFSO.CreateTextFile("input_Gene.txt",2,False)
objFile.WriteLine(Gen_Count)
'ファイルクローズ
objFile.Close
Set objFile = Nothing
objFile.Close
Set objFile = Nothing
'ファイルオープン
Set objFile = objFSO.OpenTextFile("input_Data.txt",2,False)
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
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
objFile.Close
Set objFile = Nothing
'ファイルオープン
Set objFile = objFSO.OpenTextFile("output_Value.txt", 8, True)
Set objFile = objFSO.OpenTextFile("output_Value.txt", 8, True)
objFile.WriteLine(Max_Value)
objFile.WriteLine(Max_Value_Sel)
objFile.WriteLine(Max_Value_City)
objFile.WriteLine(Max_Value_Sel)
objFile.WriteLine(Max_Value_City)
'ファイルクローズ
objFile.Close
Set objFile = Nothing
objFile.Close
Set objFile = Nothing
If Gen_Count Mod 3000 = 0 Then
Sort
End If
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
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
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
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
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)
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
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
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
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
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
objFile.Close
Set objFile = Nothing
'ファイルオープン
Set objFile = objFSO.OpenTextFile("input_Gene.txt",1,False)
Set objFile = objFSO.OpenTextFile("input_Gene.txt",1,False)
Do Until objFile.AtEndOfStream
Gen_Count = objFile.ReadLine
Loop
Gen_Count = objFile.ReadLine
Loop
'ファイルクローズ
objFile.Close
Set objFile = Nothing
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
'個体読み込み
'ファイルオープン
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
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
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
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
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
objFile.WriteLine (Cpy_Ary(i
