将棋の棋譜を連続解析し、任意の手数での評価値を表示する

ScoreCp.vbs

'フォルダ内の棋譜を連続解析し、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
'７六歩(77)   -> 7g7f
'２二角成(88) -> 8h2b+
'５三歩打     -> 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:１...９/id=1:一...九)に変換する
Function Num2Str(num, id)
	Const strjp = "１２３４５６７８９"
	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:１...９/id=1:一...九)を半角数字(1...9)に変換する
Function Str2Num(str, id)
	Const strjp = "１２３４５６７８９"
	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