Visual Basic for Applications/Knuth 字串洗牌
- 此程式碼模組包含用於字串的 Fisher-Yates 字元洗牌例程，以及用於洗牌一維陣列的 Durstenfeld-Knuth 例程。
- 過程 FisherYatesStrShuffle() 對單個字串的字元進行洗牌。這僅限於在一個字串中移動單個字元。
- 過程 KnuthArrShuffle() 對一維陣列的元素進行排序。該過程僅受陣列元素中可以儲存的內容的限制。
- 這兩種方法是偽隨機的且無偏差的。在其他地方，使用隨機生成器並不一定能保證結果沒有偏差。
- 該程式碼可以在支援 VBA 的任何 MS Office 應用程式中執行。
- Fisher-Yates 洗牌應用了一種偽隨機選擇方法。它在這裡用於字串中的字元，但對於陣列來說，更常用的方法是相關的 Durstenfeld-Knuth 方法。
- 按順序對字串的每個元素進行重新定位，會導致結果字串的一端嚴重偏差。Knuth 演算法改為在字串中提出了一個隨機位置。然後將該位置的元素累積到輸出中，並從原始字串中刪除。後續選擇以相同的方式從不斷縮短的字串中進行。
- 請注意，仍然有可能在過程中 不移動 特定的字元，但這隻在預期範圍內。
- 在頂部過程變數 Cycles 中設定所需的字串數量。即時視窗已被證明是顯示和複製的最佳位置。
- 應該指出的是，任何試圖避免 不移動 元素的嘗試，不僅會改變洗牌的隨機性質，還會阻止使用除非重複字串以外的任何其他字串。也就是說，具有重複字元的字串將無法洗牌。
- 用於陣列的 Durstenfeld-Knuth 方法與 Fisher-Yates 實現只有很小的不同。
- 為了減少處理，並且毫無疑問，為了克服在縮短過程中從陣列中間刪除元素的負擔，該演算法改為用最後一個元素覆蓋為輸出選擇的元素。在這個 VBA 實現中，陣列隨後透過 Redim Preserve 方便地縮短了一個元素。
- 參見 Fisher Yates Shuffle，以獲得對這兩種方法的良好描述。
將下面所有的程式碼複製到例如 MS Excel 的標準模組中，將工作簿儲存為 xlsm 檔案型別，並執行任一 test 過程以測試所需的程式碼。確保開啟即時視窗以獲取輸出。
Option Explicit
Private Sub testFisherYatesStrShuffle()
'run this to test the string shuffle
Dim bOK As Boolean, sStr As String, sR As String
Dim sOut As String, n As Long, Cycles As Long
'set number of shuffled versions needed
Cycles = 1
'test string
sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
For n = 1 To Cycles
bOK = FisherYatesStrShuffle(sStr, sR)
sOut = sR
If bOK = False Then
MsgBox "Problems in shuffle"
Exit Sub
End If
'output to message box and immediate window
'MsgBox "Before : " & sStr & vbCrLf & _
"After : " & sR
Debug.Print "Before : " & sStr
Debug.Print "After : " & sOut & vbCrLf
Next n
End Sub
Private Function FisherYatesStrShuffle(ByVal sIn As String, sOut As String) As Boolean
'Performs a naive Fisher-Yates shuffle on the input string.
'Returns result in sOut. Pseudo random character sequencing.
'Note: Some or all elements could occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This can be seen best for very short character strings, like "ABC".
Dim sL As String, sR As String, sT1 As String, sT2 As String, sMod As String
Dim sAcc As String, i As Long, j As Long, nL As Long, n As Long
'check input string
If sIn = "" Or Len(sIn) < 2 Then
MsgBox "At least 2 characters needed - closing"
Exit Function
End If
'initial assignments
nL = Len(sIn)
sMod = sIn
Randomize
For i = 1 To Len(sIn)
'first get a random number
j = Int((nL - 1 + 1) * Rnd + 1)
'find string value of jth element
sT1 = Mid$(sMod, j, 1)
DoEvents 'allow break
'accumulate jth element
sAcc = sAcc & sT1
'remove current character
sL = Left$(sMod, j - 1)
sR = Right$(sMod, nL - j)
sMod = sL & sR
'new string length
nL = Len(sMod)
DoEvents 'allow break
Next i
'transfer
sOut = sAcc
FisherYatesStrShuffle = True
End Function
Private Sub testKnuthArrShuffle()
'run this to test the array shuffle
Dim bOK As Boolean, sStr As String, sOut As String
Dim Cycles As Long, n As Long, bF As Boolean
Dim vS As Variant, vA As Variant, vB As Variant
'define a typical array for shuffling
vS = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
"N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
'set number of shuffled versions needed
Cycles = 1
For n = 1 To Cycles
'shuffle array
bOK = KnuthArrShuffle(vS, vA)
If bOK = False Then
MsgBox "Problems in array shuffle"
Exit Sub
End If
'arrays to strings for display
sStr = Arr1DToStr2(vS)
sOut = Arr1DToStr2(vA)
'display
' MsgBox "Before : " & sStr & vbCrLf & _
' "After : " & sOut
Debug.Print "Before : " & sStr
Debug.Print "After : " & sOut & vbCrLf
'return to an array in vB if needed
bF = StrTo1DArr2(sOut, vB)
Next n
End Sub
Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
' Performs a modified Knuth random shuffle on the elements of the input array.
' The original by Fisher-Yates, was modified for computers by Durstenfeld
' then popularised by Knuth. Returns result in vR with vIn unchanged.
'Note: Some or all elements COULD occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This is best seen for small arrays, say with only 3 elements or so.
Dim vW As Variant
Dim LB As Long, UB As Long, nL As Long
Dim i As Long, j As Long
'initial assignments
LB = LBound(vIn): UB = UBound(vIn)
ReDim vR(LB To UB) 'return array
ReDim vW(LB To UB) 'work array
nL = UB - LB + 1 'length of input array
vW = vIn 'transfer to a work array
'working
Randomize
For i = LB To nL
'first get a random number
j = Int((UB - LB + 1) * Rnd + LB)
'transfer jth of vW to ith of vR
vR(i) = vW(j)
'replace selection with current last of vW
vW(j) = vW(UB)
'remove last of vW by shortening array
ReDim Preserve vW(LB To UB - 1)
'get new UBound of shortened vW
UB = UBound(vW)
'exception; return if last chara
If UB = LB Then
vR(i + 1) = vW(UB)
Exit For
End If
DoEvents 'allow breaks
Next i
KnuthArrShuffle = True
End Function
Function StrTo1DArr2(ByVal sIn As String, vRet As Variant, _
Optional ByVal bLB1 As Boolean = True) As Boolean
' Loads string characters into 1D array (vRet). One per element.
' Optional choice of lower bound. bLB1 = True for one-based (default),
' else bLB1 = False for zero-based. vRet dimensioned in proc.
Dim nC As Long, sT As String
Dim LB As Long, UB As Long
If sIn = "" Then
MsgBox "Empty string - closing"
Exit Function
End If
'allocate array for chosen lower bound
If bLB1 = True Then
ReDim vRet(1 To Len(sIn))
Else
ReDim vRet(0 To Len(sIn) - 1)
End If
LB = LBound(vRet): UB = UBound(vRet)
'load charas of string into array
For nC = LB To UB
If bLB1 = True Then
sT = Mid$(sIn, nC, 1)
Else
sT = Mid$(sIn, nC + 1, 1)
End If
vRet(nC) = sT
Next
StrTo1DArr2 = True
End Function
Function Arr1DToStr2(vIn As Variant) As String
' Makes a single string from 1D array string elements.
' Works for any array bounds.
Dim nC As Long, sT As String, sAccum As String
Dim LB As Long, UB As Long
LB = LBound(vIn): UB = UBound(vIn)
'join characters of array into string
For nC = LB To UB
sT = vIn(nC)
sAccum = sAccum & sT
Next
Arr1DToStr2 = sAccum
End Function
- Fisher Yates Shuffle: 維基百科中寫得非常清楚的一篇文章，它一步一步地解釋了工作示例。