Kaprekar

構文
  1. array = Kaprekar( num )
引数
num
戻値

プログラム

//////////////////////////////////////////////////
// 【引数】
//   num 
// 【戻値】
// 
//////////////////////////////////////////////////
FUNCTION Kaprekar(num)
	IFB !reTest(num, "\d+") THEN
		RESULT = ERR_VALUE
		EXIT
	ENDIF
	DIM res[-1]
	DIM cnt = 0
	arrayPush(res, num)
	WHILE TRUE
		DIM array[-1]
		FOR n = 1 TO LENGTH(res[cnt])
			arrayPush(array, COPY(res[cnt], n, 1))
		NEXT
		QSORT(array, 1)		// 降順
		mx = VAL(JOIN(array, ""))
		QSORT(array, 0)		// 昇順
		mn = VAL(JOIN(array, ""))
		arrayPush(res, mx - mn)
		cnt = cnt + 1
		IF res[cnt-1] = res[cnt] THEN BREAK
	WEND
	RESIZE(res, UBound(res)-1)
 	RESULT = SLICE(res)
FEND

//////////////////////////////////////////////////
// 【引数】
//   array : 要素を追加する配列(参照引数) 
//   str : 追加する要素 
// 【戻値】
//   処理後の配列の中の要素の数 
//////////////////////////////////////////////////
FUNCTION arrayPush(var arr[], str)
	DIM res = RESIZE(arr, UBound(arr) + 1)
	arr[res] = str
	RESULT = res + 1
FEND

//////////////////////////////////////////////////
// 【引数】
//   str : 正規表現による検索の対象となる文字列 
//   Pattern : 正規表現で使用するパターンを設定 
//   IgnoreCase : 大文字・小文字を区別しない場合はTrue、区別する場合はFalse 
//   Global : 文字列全体を検索する場合はTrue、しない場合はFalse 
// 【戻値】
//   正規表現にマッチするかどうか 
//////////////////////////////////////////////////
FUNCTION reTest(str, Pattern, IgnoreCase = TRUE, Global = TRUE)
	DIM re = CREATEOLEOBJ("VBScript.RegExp")
	re.Pattern = Pattern
	re.IgnoreCase = IgnoreCase
	re.Global = Global
	RESULT = re.Test(str)
FEND

//////////////////////////////////////////////////
// 【引数】
//   配列 : 上限値を求める配列 
// 【戻値】
//   配列の上限値 
//////////////////////////////////////////////////
FUNCTION UBound(array[])
	RESULT = RESIZE(array)
FEND

プログラム実行例

カプレカ数を出力

DIM arr = Kaprekar(2005)

FOR item IN arr
	PRINT item
NEXT

//////////////////////////////////////////////////
// 【引数】
//   array : 要素を追加する配列(参照引数) 
//   str : 追加する要素 
// 【戻値】
//   処理後の配列の中の要素の数 
//////////////////////////////////////////////////
FUNCTION arrayPush(var arr[], str)
	DIM res = RESIZE(arr, UBound(arr) + 1)
	arr[res] = str
	RESULT = res + 1
FEND

//////////////////////////////////////////////////
// 【引数】
//   num 
// 【戻値】
// 
//////////////////////////////////////////////////
FUNCTION Kaprekar(num)
	IFB !reTest(num, "\d+") THEN
		RESULT = ERR_VALUE
		EXIT
	ENDIF
	DIM res[-1]
	DIM cnt = 0
	arrayPush(res, num)
	WHILE TRUE
		DIM array[-1]
		FOR n = 1 TO LENGTH(res[cnt])
			arrayPush(array, COPY(res[cnt], n, 1))
		NEXT
		QSORT(array, 1)		// 降順
		mx = VAL(JOIN(array, ""))
		QSORT(array, 0)		// 昇順
		mn = VAL(JOIN(array, ""))
		arrayPush(res, mx - mn)
		cnt = cnt + 1
		IF res[cnt-1] = res[cnt] THEN BREAK
	WEND
	RESIZE(res, UBound(res)-1)
 	RESULT = SLICE(res)
FEND

//////////////////////////////////////////////////
// 【引数】
//   str : 正規表現による検索の対象となる文字列 
//   Pattern : 正規表現で使用するパターンを設定 
//   IgnoreCase : 大文字・小文字を区別しない場合はTrue、区別する場合はFalse 
//   Global : 文字列全体を検索する場合はTrue、しない場合はFalse 
// 【戻値】
//   正規表現にマッチするかどうか 
//////////////////////////////////////////////////
FUNCTION reTest(str, Pattern, IgnoreCase = TRUE, Global = TRUE)
	DIM re = CREATEOLEOBJ("VBScript.RegExp")
	re.Pattern = Pattern
	re.IgnoreCase = IgnoreCase
	re.Global = Global
	RESULT = re.Test(str)
FEND

//////////////////////////////////////////////////
// 【引数】
//   配列 : 上限値を求める配列 
// 【戻値】
//   配列の上限値 
//////////////////////////////////////////////////
FUNCTION UBound(array[])
	RESULT = RESIZE(array)
FEND
結果
2005
5175
5994
5355
1998
8082
8532
6174