Pasted

Option Compare Binary
Option Explicit
 
Function RandSignature() As String
 
  Dim NumSyllables As Variant
  Dim i As Long
  
  Select Case RandChoice(4)
  Case 0: NumSyllables = Array(2, 2, 4)
  Case 1: NumSyllables = Array(2, 3, 3)
  Case 2: NumSyllables = Array(3, 1, 4)
  Case 3: NumSyllables = Array(3, 2, 3)
  End Select
  
  For i = LBound(NumSyllables) To UBound(NumSyllables)
    RandSignature = RandSignature _
      & IIf(i > LBound(NumSyllables), " ", "") & RandName(NumSyllables(i))
  Next i
 
End Function
 
Function RandName(ByVal NumSyllables As Long) As String
 
  Dim i As Long
  Dim s As String
  Dim DiphthongUsed As Boolean '= False
 
  For i = 1 To NumSyllables
    s = ""
    If i > 1 Or RandChance(4 / 5) Then
      Do
        s = Mid$("bcdfghjklmnpqrsStTvwxyzZ", 1 + RandChoice(24), 1)
      Loop Until _
        InStr("iy mh mm my nh nn ny uw Ww Yy", Right$(RandName, 1) & s) = 0
      If Len(RandName) > 0 And InStr("aeiou", Right$(RandName, 1)) > 0 _
        And InStr("chjqSTwxyZ", s) = 0 And RandChance(1 / 3) _
      Then
        s = s & s
      End If
    End If
    If InStr("bfgkpsSvz", s) > 0 And RandChance(1 / 3) Then
      s = s & Mid$("lr", 1 + RandChoice(2), 1)
    ElseIf InStr("dtT", s) > 0 And RandChance(1 / 6) Then
      s = s & "r"
    End If
    If Right$(s, 1) = "y" Then
      s = s & Mid$("aeou", 1 + RandChoice(4), 1)
    ElseIf Right$(s, 1) = "q" Or Right$(s, 1) = "w" Then
      s = s & Mid$("aeio", 1 + RandChoice(4), 1)
    Else
      s = s & Mid$("aeiou", 1 + RandChoice(5), 1)
    End If
    If DiphthongUsed Then
      If RandChance(1 / 4) Then s = s & Mid$("mn", 1 + RandChoice(2), 1)
    Else
      If InStr("aeo", Right$(s, 1)) > 0 And RandChance(1 / 3) Then
        s = s & Mid$("mnWY", 1 + RandChoice(4), 1)
      ElseIf InStr("i", Right$(s, 1)) > 0 And RandChance(1 / 3) Then
        s = s & Mid$("mn", 1 + RandChoice(2), 1)
      ElseIf InStr("u", Right$(s, 1)) > 0 And RandChance(1 / 3) Then
        s = s & Mid$("mnY", 1 + RandChoice(3), 1)
      End If
      DiphthongUsed = InStr("WY", Right$(s, 1)) > 0
    End If
    RandName = RandName & s
  Next i
  
  If Len(RandName) < 2 Or InStr("iu", Right$(RandName, 1)) > 0 _
    Or (InStr("aeo", Right$(RandName, 1)) > 0 _
    And RandChance(IIf(Right$(RandName, 1) = "e", 2 / 3, 1 / 3))) _
  Then
    RandName = RandName & Mid$("dfgKlmnprsStTvxz", 1 + RandChoice(16), 1)
  End If
  
  If InStr("n", Right$(RandName, 1)) > 0 And RandChance(1 / 2) Then
    RandName = RandName & Mid$("dkts", 1 + RandChoice(5), 1)
  ElseIf InStr("lr", Right$(RandName, 1)) > 0 And RandChance(1 / 2) Then
    RandName = RandName & Mid$("kmnpts", 1 + RandChoice(5), 1)
  ElseIf InStr("f", Right$(RandName, 1)) > 0 And RandChance(1 / 2) Then
    RandName = RandName & Mid$("kts", 1 + RandChoice(3), 1)
  ElseIf InStr("s", Right$(RandName, 1)) > 0 And RandChance(1 / 2) Then
    RandName = RandName & Mid$("kt", 1 + RandChoice(2), 1)
  ElseIf InStr("km", Right$(RandName, 1)) > 0 And RandChance(1 / 2) Then
    RandName = RandName & Mid$("ts", 1 + RandChoice(2), 1)
  ElseIf InStr("p", Right$(RandName, 1)) > 0 And RandChance(1 / 2) Then
    RandName = RandName & Mid$("s", 1 + RandChoice(1), 1)
  End If
  
  RandName = Replace$(RandName, "c", "ch")
  RandName = Replace$(RandName, "K", "ck")
  RandName = Replace$(RandName, "q", "qu")
  RandName = Replace$(RandName, "S", "sh")
  RandName = Replace$(RandName, "T", "th")
  RandName = Replace$(RandName, "Z", "zh")
  RandName = Replace$(RandName, "W", "u")
  RandName = Replace$(RandName, "Y", "i")
  RandName = Replace$(RandName, "kk", "ck")
  RandName = Replace$(RandName, "nb", "mb")
  RandName = Replace$(RandName, "np", "mp")
  
  If Right$(RandName, 1) = "u" Then
    RandName = Left$(RandName, Len(RandName) - 1) & "w"
  ElseIf Right$(RandName, 1) = "i" Then
    RandName = Left$(RandName, Len(RandName) - 1) & "y"
  End If
 
  RandName = UCase$(Left$(RandName, 1)) & Mid$(RandName, 2)
 
End Function
 
Function RandChance(ByVal Chance As Double) As Boolean
 
  RandChance = Rand < Chance
 
End Function
 
Function RandChoice(ByVal NumChoices As Long) As Long
 
  RandChoice = Int(IIf(NumChoices > 1, NumChoices, 1) * Rand)
 
End Function
 
  #Const UseShuffling = False
' #Const UseShuffling = True
 
Function Rand(Optional ByVal Seed = -1) As Double
 
' Stephen K. Park and Keith W. Miller, "Random number generators: good ones are
' hard to find", in Communications of the ACM, volume 31 (1988), number 10,
' pp. 1192-1201. The method of computing the next number in the sequence
' x = (a x) mod m is due to Linus Schrage, first described in his paper "A more
' portable Fortran random number generator", in ACM Transactions on Mathematical
' Software, vol.5 (1979), pp.132-138.
 
  Const Modulus As Long = 2147483647
  Const Multiplier As Long = 69621
  Const Quotient As Long = Modulus \ Multiplier '= 30845
  Const Remainder As Long = Modulus Mod Multiplier '= 23902
  
  Static RandValue As Long '= 0
  
  #If UseShuffling Then
' The shuffling technique is described in William H. Press et al., Numerical
' Recipes in Fortran 77 - The Art of Scientific Computing, Second Edition,
' Volume 1 of Fortran Numerical Recipes, Cambridge University Press, 1992,
' ISBN 0-521-43064-X, in section 7.1 "Uniform Deviates", pp.267-277.
 
  Const ShuffleSize As Long = 32
  Const ShuffleDiv As Long = 1 + (Modulus - 1) \ ShuffleSize
  Static ShuffleArray(1 To ShuffleSize) As Long
  Static OutputValue As Long
  #End If
  
  Dim i As Long
  
  If RandValue <= 0 Or Seed >= 0 Then
    Seed = Seed Mod Modulus
    If Seed <= 0 Then Seed = _
      (1 + (((CLng(Date) Mod 65536) * 25173 + 13849) Mod 65536) \ 338) _
      * (1 + Int(CDbl(Timer) * 128#))
    RandValue = Seed
    #If UseShuffling Then
    OutputValue = 0
    #End If
    For i = 1 To 100
      Rand
      #If UseShuffling Then
      If i > ShuffleSize Then
        If OutputValue <= 0 Then OutputValue = RandValue
      ElseIf i > 0 Then
        ShuffleArray(i) = RandValue
      End If
      #End If
    Next i
  End If
 
  RandValue = _
    Multiplier * (RandValue Mod Quotient) - Remainder * (RandValue \ Quotient)
  If RandValue < 0 Then RandValue = RandValue + Modulus
  
  #If UseShuffling Then
  If OutputValue > 0 Then
    i = 1 + OutputValue \ ShuffleDiv
    OutputValue = ShuffleArray(i)
    ShuffleArray(i) = RandValue
  End If
  Rand = OutputValue / Modulus
  #Else
  Rand = RandValue / Modulus
  #End If
 
End Function