Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
'フォルダ内の棋譜を連続解析し、X手目まで指した局面での評価値を表示します。
'対局者名を指定するとそちら側から見た評価値を表示させることができるので、ウォーズなどの棋譜をまとめて解析する際自分のidを指定するなどしてお使いください。
'実行方法:将棋エンジンの実行ファイルがあるディレクトリにこのファイル(ScoreCp.vbs)を置き、コマンドプロンプトで以下のコマンドを実行します。
'X手目まで指したときの評価値を表示させるには
'> cscript ScoreCp.vbs エンジンファイル名 {棋譜フォルダ名|棋譜ファイル名} スレッド数 検討時間[秒] X
'対局者名を指定する場合は
'> cscript ScoreCp.vbs エンジンファイル名 {棋譜フォルダ名|棋譜ファイル名} スレッド数 検討時間[秒] X 自分の名前
'としてください。
'出力は標準出力の他、解析結果.txtというテキストファイルに書き出されます。
Option Explicit 'Dim宣言強制
Main 'プログラム開始
'主プログラム
Sub Main
'変数宣言
Dim objWshShell, objWshScriptExec, objFS, objTSin, objLog
Dim objStdIn, objStdOut
Dim strEngine, strEngineOut, strUSIPos, strUSImove, strEngineName
Dim strPonder, strThread
Dim strDate, strName(1), strLog
Dim str, str1, str2, str3, str4
Dim i, k, n, id
Dim numPath, strPath()
Dim intTime
Dim intTesu, intThread
Dim ary, ret
Dim strKIFmove(2000)
Dim X, username, usernameid, strError
Dim ScoreCp
Dim BlackOrWhite
Const pathLog = "解析結果.txt"
'object作成
Set objWshShell = WScript.CreateObject("WScript.Shell")
Set objFS = WScript.CreateObject("Scripting.FileSystemObject")
'引数処理
ret = setupArgs(WScript.Arguments, strEngine, numPath, strPath, intThread, intTime, X, username)
If ret = 1 Then
Exit Sub
End If
'Logファイルを開く
Set objLog = objFS.OpenTextFile(pathLog, 8, True) '8:append
'エンジン起動
Set objWshScriptExec = objWshShell.Exec(strEngine)
'入出力
set objStdIn = objWshScriptExec.StdIn
set objStdOut = objWshScriptExec.StdOut
'ヘッダー送受信
EngineIn objStdIn, "usi"
Do While objStdOut.AtEndOfStream <> True
str = EngineOut(objStdOut)
'WScript.Echo str 'debug
'usiokで終了
If str = "usiok" Then
Exit Do
End If
Loop
EngineIn objStdIn, "isready"
str = EngineOut(objStdOut)
If str <> "readyok" Then
WScript.Echo "readyok メッセージが受信できません。"
Exit Sub
End If
'思考条件を送る(エンジン別)
If Instr(LCase(strEngine), "gikou") > 0 Then
strEngineName = "gikou"
strPonder = "setoption name USI_Ponder value false"
strThread = "setoption name Thread value " & intThread
ElseIf Instr(LCase(strEngine), "gpsusi") > 0 Then
strEngineName = "GPSShogi"
strPonder = "setoption name USI_Ponder value false"
strThread = "setoption name Thread value " & intThread
ElseIf Instr(LCase(strEngine), "gpsfish") > 0 Then
strEngineName = "GPSfish"
strPonder = "setoption name Ponder value false"
strThread = "setoption name Threads value " & intThread
ElseIf Instr(LCase(strEngine), "u2b") > 0 Then
strEngineName = "Bonanza"
strPonder = "setoption name Ponder value false"
strThread = "setoption name Threads value " & intThread
ElseIf Instr(LCase(strEngine), "bonanza") > 0 Then
strEngineName = "Bonanza"
strPonder = "setoption name Ponder value false"
strThread = "setoption name Thread value " & intThread
ElseIf Instr(LCase(strEngine), "ukamuse") > 0 Then
strEngineName = "ukamuse"
strPonder = "setoption name USI_Ponder value false"
strThread = "setoption name Thread value " & intThread
End If
EngineIn objStdIn, strPonder 'ponder
EngineIn objStdIn, strThread 'スレッド数
WriteLog objLog, vbCRLF & "---解析開始日時:" & Now & "---" & vbCRLF & "エンジン:" & strEngine & " スレッド数:" & intThread & " 制限時間:" & intTime & "秒" & vbCRLF
'Xが偶数ならX手目まで指した局面は先手番、Xが奇数ならX手目は後手番
id = X Mod 2
If username = False Then
If id = 0 Then
WriteLog objLog, X & "手まで指した局面での先手番から見た評価値を表示します" & vbCRLF
Else
WriteLog objLog, X & "手まで指した局面での後手番から見た評価値を表示します" & vbCRLF
End If
Else
WriteLog objLog, X & "手まで指した局面での" & username & "側から見た評価値を表示します" & vbCRLF
End If
'棋譜ファイルに関するループ
For i = 0 To numPath - 1
'棋譜ファイルを読み、変数に格納する
Set objTSin = objFS.OpenTextFile(strPath(i), 1) '1:readonly
ReadKif objTSin, strKIFmove, intTesu, strDate, strName
str1 = strDate
str2 = strName(0)
str3 = strName(1)
WriteLog objLog, str1 & " " & str2 & " " & str3
If username = False Then
usernameid = 100
ElseIf username = strName(0) Then
usernameid = 0
ElseIf username = strName(1) Then
usernameid = 1
Else
usernameid = "NA"
End If
If usernameid = "NA" Then
Writelog objLog, " 対局者名が不正です" & vbCRLF
ElseIf intTesu < CLng(X) Then
strError = "棋譜が" & X & "手未満です"
Writelog objlog, " " & strError & vbCRLF
Else
'局面文字列初期化
strUSIPos = "position startpos moves"
'対局開始
EngineIn objStdIn, "usinewgame"
'局面をX手目まで進める
For n = 0 To (X - 1)
strUSImove = KIF2USImove(strKIFmove(n))
strUSIpos = strUSIpos + " " + strUSImove
Next
'局面を送信する
EngineIn objStdIn, strUSIpos
'思考命令を送信する
str = "go btime 100 wtime 100 byoyomi " & (intTime * 1000)
EngineIn objStdIn, str
'初期化
ScoreCp = 100
'受信文字列に関するループ
Do While objStdOut.AtEndOfStream <> True
'文字列を受信する
strEngineOut = EngineOut(objStdOut)
'WScript.Echo(strEngineOut)
'info string行
If InStr(strEngineOut, "info string") > 0 Then
'何もしない
'info行
ElseIf InStr(strEngineOut, "info ") > 0 Then
'トークン分解
ary = Split(strEngineOut, " ")
'評価値を取得
For k = 0 To UBound(ary) - 1
'score cpあるいはscore mateの次が評価値
If (ary(k) = "score") Then
ScoreCp = ary(k + 2)
Exit For
End If
Next
End If
If InStr(strEngineOut, "bestmove ") > 0 Then
str4 = ScoreCp
If username = false Then
WriteLog objLog, " 評価値:" & str4 & vbCRLF
ElseIf usernameid = 0 Then
If id = 0 Then
WriteLog objLog, " 評価値:" & str4 & vbCRLF
ElseIf id = 1 Then
Writelog objLog, " 評価値:" & (-1 * str4) & vbCRLF
End If
ElseIf usernameid = 1 Then
If id = 0 Then
Writelog objLog, " 評価値:" & (-1 * str4) & vbCRLF
ElseIf id = 1 Then
WriteLog objLog, " 評価値:" & str4 & vbCRLF
End If
End If
EngineIn objStdIn, "stop"
Exit Do
End If
Loop
End If
Next
'エンジン終了
EngineIn objStdIn, "quit"
End Sub
'引数処理
'args : I : 引数
'strEngine : O : エンジンファイル名
'numPath : O : 棋譜ファイルの数
'strPath() : O : 棋譜ファイルのpath
'intThread : O : スレッド数
'intTime(0/1) : O : 先手/後手の思考時間[秒]
'関数値 : 0/1=正常/エラー
Function setupArgs(args, strEngine, numPath, strPath, intThread, intTime, X, username)
Dim objFS, objFolder, colFiles, objFile, strUsage
Dim i, str
strUsage = "使い方:" & vbCRLF & "cscript usi.vbs エンジンファイル名 {棋譜フォルダ名|棋譜ファイル名} スレッド数 検討時間[秒] X[手目]" & vbCRLF & "あるいは" & vbCRLF & "cscript usi.vbs エンジンファイル名 {棋譜フォルダ名|棋譜ファイル名} スレッド数 検討時間[秒] X[手目] 自分の名前"
'引数の数チェック
If (args.Length < 5) Or (args.Length > 6) Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
End If
'エンジンファイル名
strEngine = args.Item(0)
'ファイル一覧取得
str = args.Item(1)
Set objFS = WScript.CreateObject("Scripting.FileSystemObject")
If LCase(Right(str, 4)) <> ".kif" Then
'棋譜フォルダ名で指定
If Not objFS.FolderExists(str) Then
WScript.Echo "フォルダ " & str & " は存在しません。"
setupArgs = 1
Exit Function
End If
Set objFolder = objFS.GetFolder(str)
Set colFiles = objFolder.Files
i = 0
For Each objFile In colFiles
If LCase(Right(objFile.Path, 4)) = ".kif" Then
ReDim Preserve strPath(i)
strPath(i) = objFile.Path
i = i + 1
End If
Next
numPath = i
If numPath = 0 Then
WScript.Echo "フォルダ " & str & " に棋譜ファイル(.kif)が存在しません。"
setupArgs = 1
Exit Function
End If
Else
'棋譜ファイル名で指定(一個)
If Not objFS.FileExists(str) Then
WScript.Echo "ファイル " & str & " は存在しません。"
setupArgs = 1
Exit Function
End If
ReDim strPath(0)
strPath(0) = str
numPath = 1
End If
'スレッド数
intThread = args.Item(2)
'考慮時間
intTime = args.Item(3)
X = args.Item(4)
If args.Length = 5 Then
username = False
Else
username = args.Item(5)
End If
'エラーチェック(正の数値)
If Not isNumeric(intThread) Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
ElseIf CLng(intThread) <= 0 Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
End If
If Not isNumeric(intTime) Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
ElseIf CLng(intTime) <= 0 Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
End If
If Not isNumeric(X) Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
ElseIf CLng(X) <= 0 Then
WScript.Echo strUsage
setupArgs = 1
Exit Function
End If
setupArgs = 0
End Function
'エンジンへコマンドを送る
Sub EngineIn(f, str)
f.WriteLine str
'WScript.Echo "> " & str 'debug
End Sub
'エンジンからメッセージを受け取る
Function EngineOut(f)
Dim str
str = f.ReadLine
'WScript.Echo "< " & str 'debug
EngineOut = str
End Function
'出力
Sub WriteLog(f, str)
'標準出力
WScript.StdOut.Write str
'ファイル出力
f.Write str
End Sub
'棋譜ファイルを読んで指し手文字列を配列に入れる
Sub ReadKif(objTS, strKIFmove, intTesu, strDate, strName)
Dim str, strLine, ary
Dim i
'ヘッダー
Do Until objTS.AtEndOfStream
strLine = Trim(objTS.ReadLine)
If (InStr(strLine, "開始日時:") > 0) Then
strDate = Replace(strLine, "開始日時:", "")
ElseIf (InStr(strLine, "先手:") > 0) Then
strName(0) = Replace(strLine, "先手:", "")
ElseIf (InStr(strLine, "後手:") > 0) Then
strName(1) = Replace(strLine, "後手:", "")
ElseIf (InStr(strLine, "手数") > 0) And (InStr(strLine, "指手") > 0) Then
Exit Do
End If
Loop
'棋譜本体
i = 0
Do Until objTS.AtEndOfStream
strLine = Trim(objTS.ReadLine)
'WScript.Echo i & " " & strLine
'コメント行以外
If strLine <> "" And Left(strLine, 1) <> "*" Then
'投了
If (InStr(strLine, "投了") > 0) Or (InStr(strLine, "千日手") > 0) Or (InStr(strLine, "勝ち") > 0) Then
Exit Do
End If
'指し手文字列を取り出す(2番目の文字列)
ary = Split(strLine, " ")
str = ary(1)
'"同"は前の手の移動先で置き換える
str = Replace(str, "同 ", "同")
str = Replace(str, "同 ", "同")
If (InStr(str, "同") > 0) And (i > 0) Then
str = Replace(str, "同", Left(strKIFmove(i - 1), 2))
End If
strKIFmove(i) = str
i = i + 1
End If
Loop
'手数
intTesu = i
End Sub
'指し手文字列変換:KIF->USI
'7六歩(77) -> 7g7f
'2二角成(88) -> 8h2b+
'5三歩打 -> P*5c
Function KIF2USImove(kif)
Dim ret, str
ret = ""
'成り駒を一字に変換する
str = kif
str = Replace(str, "成香", "杏")
str = Replace(str, "成桂", "圭")
str = Replace(str, "成銀", "全")
'移動元
If (InStr(str, "打") > 0) And (Len(str) = 4) Then
ret = KIF2USIkoma(Mid(str, 3, 1)) & "*"
ElseIf (InStr(str, "成") > 0) And (Len(str) = 8) Then
ret = Mid(str, 6, 1) & Num2a(Mid(str, 7, 1))
ElseIf (Len(str) = 7) Then
ret = Mid(str, 5, 1) & Num2a(Mid(str, 6, 1))
End If
'移動先
ret = ret & Str2Num(Mid(str, 1, 1), 0) & Num2a(Str2Num(Mid(str, 2, 1), 1))
'成る
If (InStr(str, "成") > 0) And (Len(str) = 8) Then
ret = ret & "+"
End If
'関数値
KIF2USImove = ret
End Function
'半角数字(1...9)を全角数字(id=0:1...9/id=1:一...九)に変換する
Function Num2Str(num, id)
Const strjp = "123456789"
Const strcn = "一二三四五六七八九"
Num2Str = ""
If isNumeric(num) And (1 <= CLng(num)) And (CLng(num) <= 9) Then
If id = 0 Then
Num2Str = Mid(strjp, CLng(num), 1)
ElseIf id = 1 Then
Num2Str = Mid(strcn, CLng(num), 1)
End If
End If
End Function
'全角数字(id=0:1...9/id=1:一...九)を半角数字(1...9)に変換する
Function Str2Num(str, id)
Const strjp = "123456789"
Const strcn = "一二三四五六七八九"
Dim i
For i = 1 To 9
If (id = 0) And (str = Mid(strjp, i, 1)) Then
Str2Num = i
Exit Function
ElseIf (id = 1) And (str = Mid(strcn, i, 1)) Then
Str2Num = i
Exit Function
End If
Next
Str2Num = 0
End Function
'KIF駒文字をUSI駒文字(大文字)に変換する
'kif : KIF駒文字(1文字)
Function KIF2USIkoma(kif)
Dim i, aryKIF, aryUSI, ret
aryKIF = Array("歩", "香", "桂", "銀", "金", "角", "飛", "玉")
aryUSI = Array("P", "L", "N", "S", "G", "B", "R", "K" )
ret = ""
For i = 0 To UBound(aryKif)
If kif = aryKIF(i) Then
ret = aryUSI(i)
Exit For
End If
Next
KIF2USIkoma = ret
End Function
'数字(1...9)を文字(a...i)に変換する
Function Num2a(str)
Dim aryA, ret, num
aryA = Array("a", "b", "c", "d", "e", "f", "g", "h", "i")
num = Cint(str)
If (1 <= num) And (num <= 9) Then
ret = aryA(num - 1)
Else
ret = ""
End If
Num2a = ret
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment