Function RandLenDist(iTot As Long, _
Optional iMin As Long = 0#, _
Optional bVolatile As Boolean = False) As Long()
' shg 2018
' UDF wrapper for aiRandLen
Dim aiTmp() As Long
Dim aiOut() As Long
Dim iRow As Long
Dim nRow As Long
Dim iCol As Long
Dim nCol As Long
If bVolatile Then Application.Volatile
nRow = Application.Caller.Rows.Count
nCol = Application.Caller.Columns.Count
aiTmp = aiRandLen(iTot, nRow * nCol, iMin)
ReDim aiOut(1 To nRow, 1 To nCol)
For iRow = 1 To nRow
For iCol = 1 To nCol
aiOut(iRow, iCol) = aiTmp((iRow - 1) * nCol + iCol)
Next iCol
Next iRow
RandLenDist = aiOut
End Function
Function aiRandLen(ByVal iTot As Long, _
k As Long, _
Optional ByVal iMin As Long = 0&) As Long()
' shg 2018
' Applies string-cutting to return an array of k distinct Longs >= iMin,
' totalling iTot
' Partitioning n into k distinct positive integers is equivalent to
' partitioning n-k(k-1)/2 into k positive integers, some possibly equal,
' and then adding {k-1, k-2, ..., 0} respectively to each element.
Dim aiOut() As Long ' output array
Dim iOut As Long ' index to aiOut
Dim jOut As Long ' sort insertion point
Dim iCut As Long ' random cut point
If k < 1& Then Exit Function
If iMin < 0& Then iMin = 0&
iTot = iTot - k * iMin ' to accommodate min value
iTot = iTot - k * (k - 1&) \ 2& ' to accommodate distinct values
If iTot < 0& Then Exit Function
ReDim aiOut(1 To k)
With New Collection
.Add Item:=0&
.Add Item:=iTot
' create the cuts
For iOut = 1& To k - 1&
iCut = Int(Rnd() * (iTot + 1&))
' insertion-sort the cut
For jOut = .Count To 1& Step -1&
If .Item(jOut) <= iCut Then
.Add Item:=iCut, After:=jOut
Exit For
End If
Next jOut
Next iOut
' measure the distances between cuts and add the min to each
For iOut = 1& To k
aiOut(iOut) = .Item(iOut + 1&) - .Item(iOut) + iMin
Next iOut
End With
InsertionSort aiOut ' sort by length (required for the next step)
For iOut = 1& To k ' add the stepped lengths to make the values distinct
aiOut(iOut) = aiOut(iOut) + iOut - 1&
Next iOut
FYShuffle1D aiOut ' re-randomize order
aiRandLen = aiOut
End Function
Function InsertionSort(ByRef av As Variant) As Boolean
' Sorts 1D or 2D array av in situ; if 2D, one dimension must be 1
Dim iLB As Long
Dim iUB As Long
Dim LB As Long
Dim i As Long
Dim j As Long
Dim v As Variant
Select Case NumDim(av)
Case 0, Is > 2
' not an array, or > 2 dimensions
Case 1
iLB = LBound(av)
iUB = UBound(av)
For i = iLB + 1 To iUB
v = av(i)
For j = i - 1 To iLB Step -1
If av(j) <= v Then Exit For
av(j + 1) = av(j)
Next j
av(j + 1) = v
Next i
InsertionSort = True
Case 2
If UBound(av, 1) - LBound(av, 1) > 0 Then
If UBound(av, 2) - LBound(av, 2) > 0 Then Exit Function
iLB = LBound(av, 1)
iUB = UBound(av, 1)
LB = LBound(av, 2)
For i = iLB + 1 To iUB
v = av(i, LB)
For j = i - 1 To iLB Step -1
If av(j, LB) <= v Then Exit For
av(j + 1, LB) = av(j, LB)
Next j
av(j + 1, LB) = v
Next i
InsertionSort = True
Else
iLB = LBound(av, 2)
iUB = UBound(av, 2)
LB = LBound(av, 1)
For i = iLB + 1 To iUB
v = av(LB, i)
For j = i - 1 To iLB Step -1
If av(LB, j) <= v Then Exit For
av(LB, j + 1) = av(LB, j)
Next j
av(LB, j + 1) = v
Next i
InsertionSort = True
End If
End Select
End Function
Sub FYShuffle1D(av As Variant)
' shg 2015
' In-situ Fisher-Yates shuffle of 1D array av
' VBA only
Dim iLB As Long
Dim iTop As Long
Dim vTmp As Variant
Dim iRnd As Long
iLB = LBound(av)
iTop = UBound(av) - iLB + 1
Do While iTop
iRnd = Int(Rnd * iTop)
iTop = iTop - 1
vTmp = av(iTop + iLB)
av(iTop + iLB) = av(iRnd + iLB)
av(iRnd + iLB) = vTmp
Loop
End Sub
