Generate list from strings and numbers vba - vba

Question

This question is based on this puzzle that I am trying to do in vba: https://codegolf.stackexchange.com/questions/166765/fun-with-strings-and-numbers
Basically we have strings in col A and numbers in column B and in column C we have to generate a list so that:
The total count of any string should be exactly equal to its
corresponding number in the input data.
No string should be repeated adjacently in the sequence, and every
string should appear in the output list.
The selection of the next string should be done randomly as long as
they don't break above two rules. Each solution should have a
non-zero probability of being chosen.
If no combination is possible, the output should be just 0.
I tried this but I don't how to solve the problem so that it doesn't break rule #2. Any input would be appreciated thanks.
Sub generateList()
Application.ScreenUpdating = False
Dim fI As Long, totTimes As Long, i As Long, j As Long, fO As Long, tryCount As Long
Dim myArr()
Dim randNum As Long
OUT.Range("A1:A" & OUT.Rows.Count).Clear
fO = 1
With DATA
fI = .Range("A" & .Rows.Count).End(xlUp).Row
If fI < 2 Then MsgBox "No data!": Exit Sub
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("B2:B" & fI), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With DATA.Sort
.SetRange DATA.Range("A1:B" & fI)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
fI = .Range("A" & .Rows.Count).End(xlUp).Row
If fI < 2 Then MsgBox "No data!": Exit Sub
totTimes = 0: j = 0
For i = 2 To fI
If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then j = j + 1
Next i
If j < 1 Then MsgBox "No valid data present. Make sure column B has numbers and column A some string.": Exit Sub
ReDim Preserve myArr(1 To j, 1 To 2)
j = 0
For i = 2 To fI
If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then
totTimes = totTimes + CLng(.Range("B" & i).Value)
j = j + 1
myArr(j, 1) = .Range("A" & i)
myArr(j, 2) = .Range("B" & i)
End If
Next i
Do While totTimes > 0
randNum = WorksheetFunction.RandBetween(1, j)
If myArr(randNum, 2) > 0 Then
totTimes = totTimes - 1
OUT.Range("A" & fO) = myArr(randNum, 1)
myArr(randNum, 2) = myArr(randNum, 2) - 1
fO = fO + 1
End If
tryAgain:
Loop
End With
Application.ScreenUpdating = True
OUT.Activate
MsgBox "Process Completed"
End Sub

Answer 1

I have a solution (that isn't based on yours, unfortunately) that gives correct results... some of the time. I think I know why it falls short, I just have given up on fixing it.
It's also terrible for golfing, since it's a rather large amount of code, and it's an unholy mishmash of different approaches and implementation ideas that I made up as I went (and I never cleaned it up properly)... but maybe some of this will inspire you to get further.
As per rule #3, I select each letter at random. It was hit and miss using only that approach so I moved to weighted probabilities, which is what the code further down uses - and it seems to work somewhat well. Occasionally there will be 1 letter too many for one of the elements, or there will be adjacent equal elements, so it doesn't actually solve the puzzle all the time.
Ideas to remedy this problem:
Adjust the probability weights based on the frequency each letter has already been used. If you set dbg to true, you'll see that I implemented some calculations with that in mind, but never got around to figuring out how to actually adjust the weights themselves.
Hardcode a check or two for how many letters have been used early in the result, for the largest element group
Change the rand section to make more than 1 pass (maybe best out of 3) - the weights are sorted by "size", so doing 3 (or n) passes should increasingly favor the larger element groups
Maybe a combination of the first and the last suggestion.
Here's the code:
Sub NonRepeatSort(v() As String)
Dim lElementCount As Long
Dim lElement As Element ' Largest
Dim tElement As Long ' Total element count
Dim tEleGroups As Long ' Number of groups of elements
Dim tEle As Element
Dim e As Element
Dim EleCol As New Collection
Dim dbg As Boolean
dbg = False
Dim s As String, res As String, previousRes As String, inputString As String
Dim lCounter As Long
For i = 1 To UBound(v)
' Check if element already exists
On Error Resume Next
s = ""
s = EleCol.Item(v(i, 1))
On Error GoTo 0
' If not, create new
If s = "" Then
Set tEle = New Element
With tEle
.SetName = v(i, 1)
.SetTotal = CLng(v(i, 2))
End With
EleCol.Add Item:=tEle, Key:=tEle.Name
End If
Next i
For Each e In EleCol
' Find the largest element
If e.Total > lElementCount Then
lElementCount = e.Total
Set lElement = e
End If
' Count total elements
tElement = tElement + e.Total
' And groups
tEleGroups = tEleGroups + 1
' Generate inputstring
For k = 1 To e.Total
inputString = inputString + e.Name
Next k
Next e
' If the largest element is larger than the total remaining elements, we'll break rule 4
If lElement.Total - (tElement - lElement.Total) > 1 Then
Debug.Print "0"
GoTo EndForSomeReason
End If
' Bubble sort - lowest to highest
' Adapted from https://stackoverflow.com/a/3588073/4604845
Dim tmpE As Element
For x = 1 To EleCol.Count - 1
For y = 1 To EleCol.Count
If EleCol.Item(x).Total > EleCol.Item(y).Total Then
Set tmpE = EleCol.Item(y)
EleCol.Remove y
EleCol.Add tmpE, tmpE.Name, x
End If
Next y
Next x
' Weighted probability array
Dim pArr() As Variant, tmpProb As Double
ReDim Preserve pArr(1 To 2, 1 To EleCol.Count)
For u = 1 To UBound(pArr, 2)
Set pArr(2, u) = EleCol.Item(u)
tmpProb = tmpProb + pArr(2, u).Freq(tElement)
pArr(1, u) = tmpProb
Next u
' The meat of it
Dim r As Long, lBool As Boolean, sLen As Long, o As Double, t As Long
For j = 1 To tElement
Do
' Reset loop control
lBool = False
' Generate a random number between 1 and 100 _
to decide which group we pick a letter from
r = Rand1To100
For i = 1 To UBound(pArr, 2)
If r <= pArr(1, i) And Not r > pArr(1, i) Then
If dbg Then Debug.Print "Probability match: " & pArr(2, t).Name
t = i
Exit For
End If
Next i
Set tEle = EleCol.Item(t)
If dbg Then Debug.Print "Name: " & tEle.Name
' If the random group is different from the previous result, proceed
If tEle.Name <> previousRes Then
lBool = True
Else
If dbg Then Debug.Print "This was also the previous result - skipping"
End If
' If the use-frequency for the random group is lower than _
how many times it appears in the string, proceed
If lBool Then
o = Round((tEle.Used / tElement) * 100, 5)
If dbg Then Debug.Print "Freq: " & tEle.Freq(tElement)
If dbg Then Debug.Print "Used: " & tEle.UsedFreqI()
If dbg Then Debug.Print "res%: " & Round((Len(res) / tElement) * 100, 1)
If dbg Then Debug.Print "o : " & o
' check use-frequency against modeled frequency
If o < tEle.Freq(tElement) Then
If dbg Then Debug.Print "Proceed with " & tEle.Name
lBool = True
Else
lBool = False
End If
End If
If dbg Then Debug.Print "----------"
lCounter = lCounter + 1
Loop While (Not lBool And lCounter < 1000)
tEle.IncrementUsed
res = res + tEle.Name
previousRes = tEle.Name
Next j
' Generate results
Debug.Print "INPUT : " & inputString
Debug.Print "RESULT: " & res
EndForSomeReason:
End Sub
Function Rand1To100() As Long
Dim r As Long
Randomize
r = ((100 - 1) * Rnd + 1)
r = Round(r, 0)
Rand1To100 = r
End Function
Private Sub TestSort()
Dim v(1 To 4, 1 To 2) As String
v(1, 1) = "A"
v(1, 2) = "6"
v(2, 1) = "B"
v(2, 2) = "2"
v(3, 1) = "C"
v(3, 2) = "2"
v(4, 1) = "D"
v(4, 2) = "4"
Call NonRepeatSort(v)
End Sub
And you'll need this class module:
' * Class module named Element
Private pName As String
Private pTotal As Long
Private pUsed As Long
Private FrequencyCoefficient As Long ' Obsolete?
' Name
Public Property Get Name() As String
Name = pName
End Property
Public Property Let SetName(s As String)
pName = s
End Property
' Total
Public Property Get Total() As Long
Total = pTotal
End Property
Public Property Let SetTotal(t As Long)
pTotal = t
End Property
' Used
Public Property Get Used() As Long
Used = pUsed
End Property
Public Sub IncrementUsed()
pUsed = pUsed + 1
End Sub
' Freq coefficient
Public Property Get Freq(f As Long) As Double
' Where f is the total number of elements
'Freq = FrequencyCoefficient
Freq = Round((Me.Total / f) * 100, 5)
End Property
Private Property Let SetFreq(f As Long)
' Obsolete?
' Where f is the total number of elements
FrequencyCoefficient = Round((Me.Total / f) * 100)
End Property
' Used freq - internal
Public Property Get UsedFreqI() As Long
If Me.Used > 0 Then
UsedFreqI = Round((Me.Used / Me.Total) * 100)
'Debug.Print "UF: " & UsedFreqI
Else
UsedFreqI = 0
End If
End Property
' Used freq - external
Public Property Get UsedFreqE(f As Long) As Long
If Me.Used > 0 Then
UsedFreq = Round((Me.Used / f) * 100)
Else
UsedFreq = 0
End If
End Property