Sub MakeRnd179()
'///    This code is copyright 2018 by
'       Keith L. Yoder
'       Senior Research Fellow
'       Warring States Project
'       Unversity of Massachusetts at Amherst
'           klyoder at research dot umass dot edu
'           or-- keith underline yoder at yahoo dot com


Dim aData As Variant, i As Long, j As Long, k As Long, r As Long, iRepeat As Long
Dim buf As String, aMFCt As Variant, iRet As Long, tData As Variant, buf1 As String
Dim iMsc As Long, iFem As Long, iOth As Long, dRand As Double, dDiv1 As Double, dDiv2 As Double, bM As Boolean
Dim iM As Long, iW As Long, iO As Long, iData As Long, x As Long, a As Integer, b As Integer
Dim i179 As Long, iCumRand As Double, iTot As Long, xbuf As String, mbuf As String, tbuf As String
Dim i4f4m As Long, i4f4m1 As Long, i4f4m2 As Long, buf2 As String, tStart As Single, tEnd As Single, aHeaders As Variant
Dim iID As Long, iCt As Single, iD As Long, iX As Long, iT As Long, iXT As Long, ifmC As Long, ifmA As Long, sFtr As String

'tData Fields:
'   1       iID     Record ID
'   2       iCt     Score = sum of columns(3-8) + column(6), double-count chiasm-transfers
'   3       iD      # Duplicates
'   4       iX      # Chiasms
'   5       iT      # gTransfers
'   6       iXT     # Chiasm-gTransfers
'   7       ifmC    # Consecutive f=m strophes > 4
'   8       ifmA    # Alternating f=m strophes > 2
'   9       Feat    Summary string of features from cols 3-8
'   10-31    iSxx    Strophes 1-22 (x)

iRepeat = 1000
Do While True
    iRepeat = Val(InputBox("Enter number of random sequences to run. Each 100 runs will take approximately 1.5 minutes, depending on your computer system", , "1000"))
    If iRepeat = 0 Then
        MsgBox "Quitting function"
        Exit Sub
    End If
    i = MsgBox("Run " & iRepeat & " random sequences?", vbYesNoCancel)
    If i = vbYes Then
        Exit Do
    ElseIf i = vbCancel Then
        MsgBox "Quitting function"
        Exit Sub
    End If
Loop

i = MsgBox("Add extra placeholder in strophes 1, 2, and 12?", vbYesNo)
If i = vbNo Then
    'Comment: array elements = lengths of the 22 Ps 119 strophe m/f strings (sum=179)
    aMFCt = Array(7, 9, 8, 8, 8, 10, 8, 8, 8, 8, 8, 7, 8, 8, 8, 7, 8, 8, 8, 9, 9, 9)
Else
    'Comment:  array elements = lengths of the 22 Ps 119 strophe m/f strings with 3 extra placeholders (sum=182)
    aMFCt = Array(8, 10, 8, 8, 8, 10, 8, 8, 8, 8, 8, 7, 8, 8, 8, 7, 8, 8, 8, 9, 9, 9)
End If


tStart = Timer

aHeaders = Split("ID,Score,Dup,Chi,Trn,ChiTrn,C4,A2,Features,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15,S16,S17,S18,S19,S20,S21,S22", ",")
k = UBound(aHeaders) - LBound(aHeaders) + 1
ReDim tData(1 To iRepeat, 1 To k)

For i = LBound(aMFCt) To UBound(aMFCt)
    iTot = iTot + Val(aMFCt(i))
    DoEvents
Next
iM = 89
iW = 90
iO = iTot - (iM + iW)

For k = 1 To iRepeat
    
    ReDim aData(1 To 22)
    For i = 1 To 22
        aData(i) = Space(Val(aMFCt(i - 1)))
        DoEvents
    Next
    iMsc = 0
    iFem = 0
    iOth = 0
    
    For i = 1 To UBound(aData)
        
        For j = 1 To aMFCt(i - 1)
            If iMsc = iM And iFem = iW And iOth < iO Then
                buf = "o"
            ElseIf iMsc = iM And iOth = iO And iFem < iW Then
                buf = "f"
                i179 = i179 + 1
            ElseIf iFem = iW And iOth = iO And iMsc < iM Then
                buf = "m"
                i179 = i179 + 1
            Else
                dDiv1 = (iM - iMsc) / (iTot - (iMsc + iFem + iOth))
                dDiv2 = ((iM + iW) - (iMsc + iFem)) / (iTot - (iMsc + iFem + iOth))
                dRand = [RAND()]
                If dRand <= dDiv1 Then
                    buf = "m"
                ElseIf dRand <= dDiv2 Then
                    buf = "f"
                Else
                    buf = "o"
                End If
            End If
            Mid$(aData(i), j, 1) = buf
            If buf = "m" Then
                iMsc = iMsc + 1
            ElseIf buf = "f" Then
                iFem = iFem + 1
            Else
                iOth = iOth + 1
            End If
            DoEvents
        Next
        DoEvents
    Next
    
    If iMsc + iFem + iOth <> iTot Then
        Stop
    End If
    
    For i = 1 To UBound(aData)
        tData(k, i + 9) = Trim(aData(i))
        DoEvents
    Next
    
    For i = 1 To UBound(aData)
        aData(i) = Trim(Replace(aData(i), "o", ""))
        DoEvents
    Next
    
    iID = k
    iCt = 0: iD = 0: iX = 0: iT = 0: iXT = 0: ifmC = 0: ifmA = 0: sFtr = ""
    
    For i = 1 To UBound(aData)
        buf1 = aData(i)
        iMsc = iMsc + Len(Replace(buf1, "f", ""))
        iFem = iFem + Len(Replace(buf1, "m", ""))
        xbuf = ""
        For j = 1 To Len(buf1)
            xbuf = Mid$(buf1, j, 1) & xbuf
            DoEvents
        Next
        mbuf = Replace(Replace(Replace(buf1, "m", "0"), "f", "m"), "0", "f")
    
        If Len(buf1) - Len(Replace(buf1, "f", "")) = Len(buf1) - Len(Replace(buf1, "m", "")) Then
            i4f4m = i4f4m + 1
            If i4f4m = 1 Then
                If i Mod 2 = 0 Then
                    i4f4m2 = i4f4m2 + 1
                Else
                    i4f4m1 = i4f4m1 + 1
                End If
            Else
                If i Mod 2 = 0 Then
                    i4f4m2 = 0
                Else
                    i4f4m1 = 0
                End If
            End If
        Else
            i4f4m = 0
            If i Mod 2 = 0 Then
                i4f4m2 = 0
            Else
                i4f4m1 = 0
            End If
        End If
        If i4f4m > 4 Then
            ifmC = ifmC + 1
            sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & "." & Trim(Str(i4f4m)) & "fmC"
        Else
            If i4f4m2 > 2 And i Mod 2 = 0 Then
                ifmA = ifmA + 1
                sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & "." & Trim(Str(i4f4m2)) & "fmA"
            ElseIf i4f4m1 > 2 And i Mod 2 = 1 Then
                ifmA = ifmA + 1
                sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & "." & Trim(Str(i4f4m1)) & "fmA"
            End If
        End If
        
        For j = i + 1 To UBound(aData)
            buf2 = aData(j)
            If buf1 = buf2 Then
                iD = iD + 1
                sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & ".d." & Trim(Str(j))
            ElseIf mbuf = buf2 And xbuf = buf2 Then
                iXT = iXT + 1
                sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & ".xt." & Trim(Str(j))
            ElseIf mbuf = buf2 Then
                iT = iT + 1
                sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & ".t." & Trim(Str(j))
            ElseIf xbuf = buf2 Then
                iX = iX + 1
                sFtr = sFtr & IIf(sFtr > "", ", ", "") & Trim(Str(i)) & ".x." & Trim(Str(j))
            End If
            DoEvents
        Next
        DoEvents
    Next

    tData(k, 1) = iID
    iCt = iD + iX + iT + (2 * iXT) + ifmC + ifmA
    tData(k, 2) = iCt
    tData(k, 3) = iD
    tData(k, 4) = iX
    tData(k, 5) = iT
    tData(k, 6) = iXT
    tData(k, 7) = ifmC
    tData(k, 8) = ifmA
    tData(k, 9) = sFtr
    DoEvents
Next
    
Dim oWk As Worksheet, oLo As ListObject
Set oWk = ThisWorkbook.Worksheets.Add
oWk.Move after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
oWk.Range("A6").Activate
ActiveCell.Resize(UBound(tData, 1), UBound(tData, 2)).Value = tData
oWk.Range("A5").Activate
ActiveCell.Resize(1, UBound(aHeaders) + 1).Value = aHeaders
Set oLo = oWk.ListObjects.Add(xlSrcRange, oWk.Range(Cells(5, 1), Cells(UBound(tData, 1) + 6, UBound(tData, 2))), , , xlYes)
oLo.ShowTotals = True
oLo.TotalsRowRange.Cells(1, 1).Formula = "SUMS"
For i = 2 To 8
    oLo.TotalsRowRange.Cells(i).Formula = "=SUBTOTAL(109,[" & oLo.ListColumns(i).Name & "])"
    DoEvents
Next
oLo.ListColumns("Features").DataBodyRange.WrapText = True
oWk.Range("B3") = "Visible Rows = "
oWk.Range("B3").HorizontalAlignment = xlRight
oWk.Range("C3").Formula = "=SUBTOTAL(103," & oLo.Name & "[ID])"
oLo.ListColumns("Features").Range.EntireColumn.ColumnWidth = 14
oLo.ListColumns("Features").Range.Rows.AutoFit
oWk.Range(oLo.HeaderRowRange(1, oLo.ListColumns("S1").Index), oLo.TotalsRowRange(1, oLo.ListColumns.Count)).Columns.AutoFit


tEnd = Timer
MsgBox "Elapsed seconds = " & (tEnd - tStart)

End Sub