Posts: 545
Threads: 116
Joined: Apr 2022
Reputation:
39
A silly little program inspired by staying up too late and leaving youtube playing while I was programming, and a video came up on the Babel Library. Here's a small piece of that:
Code: (Select All) 'babeltype
'
'an experiment at 1,000,000 virtual chimpanzees typing away, with a couple rules
'
' press any key to pause the program, and the spacebar to continue
' take a screen shot if you get a miracle sentence.
'
' press escape to quit
Dim vowel$(6), cm$(7), word$(10)
vowel$(1) = "a"
vowel$(2) = "e"
vowel$(3) = "i"
vowel$(4) = "o"
vowel$(5) = "u"
vowel$(6) = "y"
cm$(1) = "t"
cm$(2) = "n"
cm$(3) = "s"
cm$(4) = "h"
cm$(5) = "r"
cm$(6) = "d"
cm$(7) = "l"
word$(1) = "the "
word$(2) = "be "
word$(3) = "and "
word$(4) = "a "
word$(5) = "of "
word$(6) = "to "
word$(7) = "in "
word$(8) = "I "
word$(9) = "you "
word$(10) = "it "
start$ = "yes"
Do
_Limit 90
r = Int(1 + Rnd * 2)
For n = 1 To r:
If start$ = "yes" Then
Select Case Int(1 + Rnd * 90)
Case 1 To 6
Print UCase$(cm$(1 + Int(Rnd * 7)));
Case 7 To 88
Print UCase$(Chr$(97 + Int(Rnd * 26)));
Case 89, 90
W$ = word$(Int(1 + Rnd * 10))
Mid$(W$, 1, 1) = UCase$(Left$(W$, 1))
Print W$;
End Select
start$ = "no"
Else
Select Case Int(1 + Rnd * 90)
Case 1 To 6
Print cm$(1 + Int(Rnd * 7));
Case 7 To 88
Print Chr$(97 + Int(Rnd * 26));
Case 89, 90
Print word$(Int(1 + Rnd * 10));
End Select
End If
Next
r = Int(1 + Rnd * 2)
For n = 1 To r: Print vowel$(Int(1 + Rnd * 6));: Next
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 2.2 Then
Print cm$(1 + Int(Rnd * 7));
Else
Print Chr$(97 + Int(Rnd * 26));
End If
Next
If Rnd * 6 < 2.5 Then
Print vowel$(Int(1 + Rnd * 6));
If Rnd * 6 < 2.5 Then
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 2.2 Then
Print cm$(1 + Int(Rnd * 7));
Else
Print Chr$(97 + Int(Rnd * 26));
End If
Next
End If
End If
If Rnd * 24 < 1.5 Then
p = Int(1 + Rnd * 88)
Select Case p
Case 1 To 18
Print ",";
Case 19 To 23
Print ";";
Case 24
Print ":";
Case 25 To 75
Print ".";
start$ = "yes"
Case 76 To 83
Print "?";
start$ = "yes"
Case 84 To 88
Print "!";
start$ = "yes"
End Select
End If
Print " ";
k$ = InKey$
If k$ <> "" And k$ <> Chr$(27) Then
Do
_Limit 30
a$ = InKey$
Loop Until a$ = " "
End If
Loop Until k$ = Chr$(27)
End
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
Hmm... I wonder if you did that with syllables and one syllable words...
b = b + ...
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation:
39
09-01-2022, 01:30 PM
(This post was last modified: 09-01-2022, 01:30 PM by James D Jarvis.)
I took a look at what I did last night at 1AM and cleaned it up to be a little to more consistent with English.
Code: (Select All) 'babeltype_better
'
'an experiment at 1,000,000 virtual chimpanzees typing away, with a couple rules
'
' press any key to pause the program, and the spacebar to continue
' take a screen shot if you get a miracle sentence.
'
' press escape to quit
Dim vowel$(6), cm$(7), word$(10)
'dumped using cm$ for now but leaving it here just in case
vowel$(1) = "a"
vowel$(2) = "e"
vowel$(3) = "i"
vowel$(4) = "o"
vowel$(5) = "u"
vowel$(6) = "y"
cm$(1) = "t"
cm$(2) = "n"
cm$(3) = "s"
cm$(4) = "h"
cm$(5) = "r"
cm$(6) = "d"
cm$(7) = "l"
word$(1) = "the "
word$(2) = "be "
word$(3) = "and "
word$(4) = "a "
word$(5) = "of "
word$(6) = "to "
word$(7) = "in "
word$(8) = "I "
word$(9) = "you "
word$(10) = "it "
start$ = "yes"
Do
_Limit 90
r = Int(1 + Rnd * 2)
AW$ = ""
For n = 1 To r:
If start$ = "yes" Then
Select Case Int(1 + Rnd * 90)
Case 1 To 80
AW$ = AW$ + UCase$(eng$)
Case 81 To 88
AW$ = AW$ + UCase$(Chr$(97 + Int(Rnd * 26)))
Case 89, 90
W$ = word$(Int(1 + Rnd * 10))
Mid$(W$, 1, 1) = UCase$(Left$(W$, 1))
AW$ = AW$ + W$
End Select
start$ = "no"
Else
Select Case Int(1 + Rnd * 90)
Case 1 To 80
AW$ = AW$ + eng$
Case 81 To 88
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
Case 89, 90
AW$ = AW$ + word$(Int(1 + Rnd * 10))
End Select
End If
Next
r = Int(1 + Rnd * 2)
For n = 1 To r: AW$ = AW$ + vowel$(Int(1 + Rnd * 6)): Next
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 4.2 Then
AW$ = AW$ + eng$
Else
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
End If
Next
If Rnd * 6 < 2.5 Then
AW$ = AW$ + vowel$(Int(1 + Rnd * 6))
If Rnd * 6 < 4.5 Then
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 4.2 Then
AW$ = AW$ + eng$
Else
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
End If
Next
End If
End If
AW$ = sift$(AW$)
Print AW$;
If Rnd * 24 < 1.5 Then
p = Int(1 + Rnd * 88)
Select Case p
Case 1 To 18
Print ",";
Case 19 To 23
Print ";";
Case 24
Print ":";
Case 25 To 75
Print ".";
start$ = "yes"
Case 76 To 83
Print "?";
start$ = "yes"
Case 84 To 88
Print "!";
start$ = "yes"
End Select
End If
Print " ";
k$ = InKey$
If k$ <> "" And k$ <> Chr$(27) Then
Do
_Limit 30
a$ = InKey$
Loop Until a$ = " "
End If
Loop Until k$ = Chr$(27)
End
Function eng$
'returns an english letter based on analysis of frequency of letters in english words
c = Int(1 + Rnd * 10000)
Select Case c
Case 1 To 1260
a$ = "e"
Case 1261 To 2197
a$ = "t"
Case 2198 To 3031
a$ = "a"
Case 3032 To 3801
a$ = "o"
Case 3802 To 4481
a$ = "n"
Case 4482 To 5152
a$ = "i"
Case 5153 To 5763
a$ = "h"
Case 5764 To 6374
a$ = "s"
Case 6375 To 6942
a$ = "r"
Case 6943 To 7366
a$ = "l"
Case 7367 To 7780
a$ = "d"
Case 7781 To 8065
a$ = "u"
Case 8063 To 8338
a$ = "c"
Case 8339 To 8591
a$ = "m"
Case 8592 To 8825
a$ = "w"
Case 8826 To 9029
a$ = "y"
Case 9030 To 9232
a$ = "f"
Case 9233 To 9424
a$ = "g"
Case 9425 To 9590
a$ = "p"
Case 9591 To 9744
a$ = "b"
Case 9745 To 9850
a$ = "v"
Case 9851 To 9937
a$ = "k"
Case 9938 To 9960
a$ = "j"
Case 9961 To 9980
a$ = "x"
Case 9981 To 9991
a$ = "q"
Case 9992 To 10000
a$ = "z"
End Select
eng$ = a$
End Function
Function sift$ (w$)
If Left$(w$, 2) = "ll" And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "ll", "l")
If InStr(w$, "ooo") Then w$ = StrReplacefirst$(w$, "ooo", "oo")
If InStr(w$, "eee") Then w$ = StrReplacefirst$(w$, "eee", "ee")
If InStr(w$, "aaa") Then w$ = StrReplacefirst$(w$, "aaa", "a")
If InStr(w$, "aa") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "aa", "a")
If InStr(w$, "yy") Then w$ = StrReplacefirst$(w$, "yy", "y")
If InStr(w$, "ii") Then w$ = StrReplacefirst$(w$, "ii", "i")
If InStr(w$, "uuu") Then w$ = StrReplacefirst$(w$, "uuu", "u")
If InStr(w$, "uu") Then w$ = StrReplacefirst$(w$, "uu", "u")
If InStr(w$, "eoe") Then w$ = StrReplacefirst$(w$, "eoe", "eo")
If InStr(w$, "eooe") Then w$ = StrReplacefirst$(w$, "eooe", "eo")
If Left$(w$, 2) = "lp" And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "lp", "pl")
If InStr(w$, "hp") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "hp", "ph")
If InStr(w$, "ht") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "ht", "th")
If InStr(w$, "hg") And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "hg", "gh")
If InStr(w$, "uo") And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "uo", "ou")
If Right$(w$, 1) = "q" Then w$ = w$ + "e"
If Right$(w$, 1) = "v" Then w$ = w$ + "e"
If Right$(w$, 1) = "j" Then w$ = w$ + "e"
If Right$(w$, 2) = "lw" Then w$ = Left$(w$, Len(w$) - 2) + "wly"
If Right$(w$, 2) = "br" Then w$ = Left$(w$, Len(w$) - 2) + "ber"
If Right$(w$, 2) = "gn" Then w$ = Left$(w$, Len(w$) - 2) + "ng"
sift$ = w$
End Function
Function StrReplacefirst$ (myString$, find$, replaceWith$)
'noncase sensitive, replace the first occourence of find$ in mystring$ with replacewith$
Dim a$, b$
Dim As Long basei, i
If Len(myString$) = 0 Then Exit Function
a$ = myString$
b$ = LCase$(find$)
basei = 1
i = InStr(basei, LCase$(a$), b$)
Do While i
a$ = Left$(a$, i - 1) + replaceWith$ + Right$(a$, Len(a$) - i - Len(b$) + 1)
basei = i + Len(replaceWith$)
i = 0
Loop
StrReplacefirst$ = a$
End Function
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation:
39
(09-01-2022, 12:34 PM)bplus Wrote: Hmm... I wonder if you did that with syllables and one syllable words...
well... here it is with slightly more 3 letter words.
Code: (Select All) 'babeltype_better _more 3 letter words
'
'an experiment at 1,000,000 virtual chimpanzees typing away, with a couple rules
'
' press any key to pause the program, and the spacebar to continue
' take a screen shot if you get a miracle sentence.
'
' press escape to quit
Dim vowel$(6), cm$(7), word$(10)
'dumped using cm$ for now but leaving it here just in case
vowel$(1) = "a"
vowel$(2) = "e"
vowel$(3) = "i"
vowel$(4) = "o"
vowel$(5) = "u"
vowel$(6) = "y"
cm$(1) = "t"
cm$(2) = "n"
cm$(3) = "s"
cm$(4) = "h"
cm$(5) = "r"
cm$(6) = "d"
cm$(7) = "l"
word$(1) = "the "
word$(2) = "be "
word$(3) = "and "
word$(4) = "a "
word$(5) = "of "
word$(6) = "to "
word$(7) = "in "
word$(8) = "I "
word$(9) = "you "
word$(10) = "it "
start$ = "yes"
Do
_Limit 90
r = Int(1 + Rnd * 2)
AW$ = ""
For n = 1 To r:
If start$ = "yes" Then
Select Case Int(1 + Rnd * 90)
Case 1 To 80
AW$ = AW$ + UCase$(eng$)
Case 81 To 88
AW$ = AW$ + UCase$(Chr$(97 + Int(Rnd * 26)))
Case 89, 90
W$ = word$(Int(1 + Rnd * 10))
Mid$(W$, 1, 1) = UCase$(Left$(W$, 1))
AW$ = AW$ + W$
End Select
start$ = "no"
Else
Select Case Int(1 + Rnd * 90)
Case 1 To 80
AW$ = AW$ + eng$
Case 81 To 88
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
Case 89, 90
AW$ = AW$ + word$(Int(1 + Rnd * 10))
End Select
End If
Next
r = Int(1 + Rnd * 2)
For n = 1 To r: AW$ = AW$ + vowel$(Int(1 + Rnd * 6)): Next
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 4.2 Then
AW$ = AW$ + eng$
Else
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
End If
Next
If Rnd * 6 < 2.5 Then
AW$ = AW$ + vowel$(Int(1 + Rnd * 6))
If Rnd * 6 < 4.5 Then
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 4.2 Then
AW$ = AW$ + eng$
Else
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
End If
Next
End If
End If
If Len(AW$) > 3 And Int(1 + Rnd * 10) < 3 Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
AW$ = eng$ + vowel$(1 + Int(Rnd * 6)) + eng$
Case 4, 5
AW$ = eng$ + vowel$(1 + Int(Rnd * 6)) + vowel$(1 + Int(Rnd * 6))
Case 6
AW$ = vowel$(1 + Int(Rnd * 6)) + eng$ + vowel$(1 + Int(Rnd * 6))
End Select
End If
AW$ = sift$(AW$)
Print AW$;
If Rnd * 24 < 1.5 Then
p = Int(1 + Rnd * 88)
Select Case p
Case 1 To 18
Print ",";
Case 19 To 23
Print ";";
Case 24
Print ":";
Case 25 To 75
Print ".";
start$ = "yes"
Case 76 To 83
Print "?";
start$ = "yes"
Case 84 To 88
Print "!";
start$ = "yes"
End Select
End If
Print " ";
k$ = InKey$
If k$ <> "" And k$ <> Chr$(27) Then
Do
_Limit 30
a$ = InKey$
Loop Until a$ = " "
End If
Loop Until k$ = Chr$(27)
End
Function eng$
'returns an english letter based on analysis of frequency of letters in english words
c = Int(1 + Rnd * 10000)
Select Case c
Case 1 To 1260
a$ = "e"
Case 1261 To 2197
a$ = "t"
Case 2198 To 3031
a$ = "a"
Case 3032 To 3801
a$ = "o"
Case 3802 To 4481
a$ = "n"
Case 4482 To 5152
a$ = "i"
Case 5153 To 5763
a$ = "h"
Case 5764 To 6374
a$ = "s"
Case 6375 To 6942
a$ = "r"
Case 6943 To 7366
a$ = "l"
Case 7367 To 7780
a$ = "d"
Case 7781 To 8065
a$ = "u"
Case 8063 To 8338
a$ = "c"
Case 8339 To 8591
a$ = "m"
Case 8592 To 8825
a$ = "w"
Case 8826 To 9029
a$ = "y"
Case 9030 To 9232
a$ = "f"
Case 9233 To 9424
a$ = "g"
Case 9425 To 9590
a$ = "p"
Case 9591 To 9744
a$ = "b"
Case 9745 To 9850
a$ = "v"
Case 9851 To 9937
a$ = "k"
Case 9938 To 9960
a$ = "j"
Case 9961 To 9980
a$ = "x"
Case 9981 To 9991
a$ = "q"
Case 9992 To 10000
a$ = "z"
End Select
eng$ = a$
End Function
Function sift$ (w$)
If Left$(w$, 2) = "ll" And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "ll", "l")
If InStr(w$, "ooo") Then w$ = StrReplacefirst$(w$, "ooo", "oo")
If InStr(w$, "eee") Then w$ = StrReplacefirst$(w$, "eee", "ee")
If InStr(w$, "aaa") Then w$ = StrReplacefirst$(w$, "aaa", "a")
If InStr(w$, "aa") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "aa", "a")
If InStr(w$, "yy") Then w$ = StrReplacefirst$(w$, "yy", "y")
If InStr(w$, "ii") Then w$ = StrReplacefirst$(w$, "ii", "i")
If InStr(w$, "uuu") Then w$ = StrReplacefirst$(w$, "uuu", "u")
If InStr(w$, "uu") Then w$ = StrReplacefirst$(w$, "uu", "u")
If InStr(w$, "eoe") Then w$ = StrReplacefirst$(w$, "eoe", "eo")
If InStr(w$, "eooe") Then w$ = StrReplacefirst$(w$, "eooe", "eo")
If Left$(w$, 2) = "lp" And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "lp", "pl")
If InStr(w$, "hp") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "hp", "ph")
If InStr(w$, "ht") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "ht", "th")
If InStr(w$, "hg") And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "hg", "gh")
If InStr(w$, "uo") And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "uo", "ou")
If Right$(w$, 1) = "q" Then w$ = w$ + "e"
If Right$(w$, 1) = "v" Then w$ = w$ + "e"
If Right$(w$, 1) = "j" Then w$ = w$ + "e"
If Right$(w$, 2) = "lw" Then w$ = Left$(w$, Len(w$) - 2) + "wly"
If Right$(w$, 2) = "br" Then w$ = Left$(w$, Len(w$) - 2) + "ber"
If Right$(w$, 2) = "gn" Then w$ = Left$(w$, Len(w$) - 2) + "ng"
sift$ = w$
End Function
Function StrReplacefirst$ (myString$, find$, replaceWith$)
'noncase sensitive, replace the first occourence of find$ in mystring$ with replacewith$
Dim a$, b$
Dim As Long basei, i
If Len(myString$) = 0 Then Exit Function
a$ = myString$
b$ = LCase$(find$)
basei = 1
i = InStr(basei, LCase$(a$), b$)
Do While i
a$ = Left$(a$, i - 1) + replaceWith$ + Right$(a$, Len(a$) - i - Len(b$) + 1)
basei = i + Len(replaceWith$)
i = 0
Loop
StrReplacefirst$ = a$
End Function
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation:
39
latest version, sifts out a few more non-english letter combos
Code: (Select All) 'babeltype_better _more 3 letter words and more accurate probability of english letters
'
'an experiment at 1,000,000 virtual chimpanzees typing away, with a couple rules
'
' press any key to pause the program, and the spacebar to continue
' take a screen shot if you get a miracle sentence.
'
' press escape to quit
Dim Shared vowel$(6), cm$(7), word$(10)
Dim Shared toomanyv$(625)
'dumped using cm$ for now but leaving it here just in case
vowel$(1) = "a"
vowel$(2) = "e"
vowel$(3) = "i"
vowel$(4) = "o"
vowel$(5) = "u"
vowel$(6) = "y"
cm$(1) = "t"
cm$(2) = "n"
cm$(3) = "s"
cm$(4) = "h"
cm$(5) = "r"
cm$(6) = "d"
cm$(7) = "l"
word$(1) = "the "
word$(2) = "be "
word$(3) = "and "
word$(4) = "a "
word$(5) = "of "
word$(6) = "to "
word$(7) = "in "
word$(8) = "I "
word$(9) = "you "
word$(10) = "it "
buildtoomanyv ' wuld array toomanyv$
start$ = "yes"
Do
_Limit 90
r = Int(1 + Rnd * 2)
AW$ = ""
For n = 1 To r:
If start$ = "yes" Then
Select Case Int(1 + Rnd * 90)
Case 1 To 80
AW$ = AW$ + UCase$(eng$)
Case 81 To 88
AW$ = AW$ + UCase$(Chr$(97 + Int(Rnd * 26)))
Case 89, 90
W$ = word$(Int(1 + Rnd * 10))
Mid$(W$, 1, 1) = UCase$(Left$(W$, 1))
AW$ = AW$ + W$
End Select
start$ = "no"
Else
Select Case Int(1 + Rnd * 90)
Case 1 To 80
AW$ = AW$ + eng$
Case 81 To 88
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
Case 89, 90
AW$ = AW$ + word$(Int(1 + Rnd * 10))
End Select
End If
Next
r = Int(1 + Rnd * 2)
For n = 1 To r: AW$ = AW$ + evow$: Next
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 4.2 Then
AW$ = AW$ + eng$
Else
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
End If
Next
If Rnd * 6 < 2.5 Then
AW$ = AW$ + evow$
If Rnd * 6 < 4.5 Then
r = Int(1 + Rnd * 2)
For n = 1 To r
If Rnd * 6 < 4.2 Then
AW$ = AW$ + eng$
Else
AW$ = AW$ + Chr$(97 + Int(Rnd * 26))
End If
Next
End If
End If
If Len(AW$) > 3 And Int(1 + Rnd * 10) < 3 Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
AW$ = eng$ + evow$ + eng$
Case 4, 5
AW$ = eng$ + evow$ + evow$
Case 6
AW$ = evow$ + eng$ + evow$
End Select
End If
AW$ = sift$(AW$)
Print AW$;
If Rnd * 24 < 1.5 Then
p = Int(1 + Rnd * 88)
Select Case p
Case 1 To 18
Print ",";
Case 19 To 23
Print ";";
Case 24
Print ":";
Case 25 To 75
Print ".";
start$ = "yes"
Case 76 To 83
Print "?";
start$ = "yes"
Case 84 To 88
Print "!";
start$ = "yes"
End Select
End If
Print " ";
k$ = InKey$
If k$ <> "" And k$ <> Chr$(27) Then
Do
_Limit 30
a$ = InKey$
Loop Until a$ = " "
End If
Loop Until k$ = Chr$(27)
End
Function eng$
'returns an english letter based on analysis of frequency of letters in english words
c = Int(1 + Rnd * 10000)
Select Case c
Case 1 To 1260
a$ = "e"
Case 1261 To 2197
a$ = "t"
Case 2198 To 3031
a$ = "a"
Case 3032 To 3801
a$ = "o"
Case 3802 To 4481
a$ = "n"
Case 4482 To 5152
a$ = "i"
Case 5153 To 5763
a$ = "h"
Case 5764 To 6374
a$ = "s"
Case 6375 To 6942
a$ = "r"
Case 6943 To 7366
a$ = "l"
Case 7367 To 7780
a$ = "d"
Case 7781 To 8065
a$ = "u"
Case 8063 To 8338
a$ = "c"
Case 8339 To 8591
a$ = "m"
Case 8592 To 8825
a$ = "w"
Case 8826 To 9029
a$ = "y"
Case 9030 To 9232
a$ = "f"
Case 9233 To 9424
a$ = "g"
Case 9425 To 9590
a$ = "p"
Case 9591 To 9744
a$ = "b"
Case 9745 To 9850
a$ = "v"
Case 9851 To 9937
a$ = "k"
Case 9938 To 9960
a$ = "j"
Case 9961 To 9980
a$ = "x"
Case 9981 To 9991
a$ = "q"
Case 9992 To 10000
a$ = "z"
End Select
eng$ = a$
End Function
Function evow$
'return a random english vowel roughly in line with frequencey of vowels in english
Select Case Int(1 + Rnd * 398)
Case 1 To 124
V$ = "e"
Case 125 To 204
V$ = "a"
Case 205 To 280
V$ = "o"
Case 281 To 355
V$ = "i"
Case 356 To 382
V$ = "u"
Case 383 To 398
V$ = "y"
End Select
evow$ = V$
End Function
Function sift$ (w$)
Dim v$(4)
If Len(w$) > 3 Then
For n = 1 To 625
If InStr(w$, toomanyv$(n)) Then
rp$ = Left$(toomanyv$(n), 1) + Right$(toomanyv$(n), 1)
w$ = StrReplacefirst$(w$, toomanyv$(n), rp$)
End If
Next
End If
If Left$(w$, 2) = "ll" And Int(1 + Rnd * 10) < 10 Then w$ = StrReplacefirst$(w$, "ll", "l")
If InStr(w$, "ooo") Then w$ = StrReplacefirst$(w$, "ooo", "oo")
If InStr(w$, "eee") Then w$ = StrReplacefirst$(w$, "eee", "ee")
If InStr(w$, "aaa") Then w$ = StrReplacefirst$(w$, "aaa", "a")
If InStr(w$, "aa") And Int(1 + Rnd * 10) < 10 Then w$ = StrReplacefirst$(w$, "aa", "a")
If InStr(w$, "yy") Then w$ = StrReplacefirst$(w$, "yy", "y")
If InStr(w$, "ii") Then w$ = StrReplacefirst$(w$, "ii", "i")
If InStr(w$, "uuu") Then w$ = StrReplacefirst$(w$, "uuu", "u")
If InStr(w$, "uu") Then w$ = StrReplacefirst$(w$, "uu", "u")
If InStr(w$, "eoe") Then w$ = StrReplacefirst$(w$, "eoe", "eo")
If InStr(w$, "eooe") Then w$ = StrReplacefirst$(w$, "eooe", "eo")
If Left$(w$, 2) = "ss" Then w$ = vowel$(Int(1 + Rnd * 6)) + w$
If Left$(w$, 2) = "lp" And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "lp", "pl")
If InStr(w$, "hp") And Int(1 + Rnd * 10) < 9 Then w$ = StrReplacefirst$(w$, "hp", "ph")
If InStr(w$, "ht") And Int(1 + Rnd * 10) < 10 Then w$ = StrReplacefirst$(w$, "ht", "th")
If InStr(w$, "hg") And Int(1 + Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "hg", "gh")
If InStr(w$, "uo") And Int(1 + Rnd * 10) < 10 Then w$ = StrReplacefirst$(w$, "uo", "ou")
If Right$(w$, 1) = "q" Then w$ = w$ + "e"
If Right$(w$, 1) = "v" Then w$ = w$ + "e"
If Right$(w$, 1) = "j" Then w$ = w$ + "e"
If Right$(w$, 2) = "lw" Then w$ = Left$(w$, Len(w$) - 2) + "wly"
If Right$(w$, 2) = "br" Then w$ = Left$(w$, Len(w$) - 2) + "ber"
If Right$(w$, 2) = "gn" Then w$ = Left$(w$, Len(w$) - 2) + "ng"
If Right$(w$, 2) = "bl" Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
w$ = w$ + "y"
Case 4, 5, 6
w$ = w$ + "e"
End Select
End If
If Left$(w$, 2) = "nn" Then w$ = StrReplacefirst$(w$, "nn", "n")
If Right$(w$, 2) = "nn" Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
w$ = Left$(w$, Len(w$) - 1)
Case 4, 5, 6
w$ = w$ + "e"
End Select
End If
If Left$(w$, 2) = "mm" Then w$ = StrReplacefirst$(w$, "mm", "m")
If Right$(w$, 2) = "mm" Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
w$ = Left$(w$, Len(w$) - 1)
Case 4, 5, 6
w$ = w$ + "e"
End Select
End If
If InStr(w$, "hh") And Int(1 * Rnd * 10) < 10 Then w$ = StrReplacefirst$(w$, "hh", "h")
If InStr(w$, "hc") And Int(1 * Rnd * 10) < 10 Then w$ = StrReplacefirst$(w$, "hc", "ch")
If InStr(w$, "ww") And Int(1 * Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "ww", "wh")
If InStr(w$, "ww") And Int(1 * Rnd * 10) < 8 Then w$ = StrReplacefirst$(w$, "ww", "w")
If Right$(w$, 2) = "nr" Then w$ = Left$(w$, Len(w$) - 1) + evow$ + "r"
If Right$(w$, 2) = "tn" Then w$ = Left$(w$, Len(w$) - 1) + evow$ + "n"
sift$ = w$
End Function
Function StrReplacefirst$ (myString$, find$, replaceWith$)
'noncase sensitive, replace the first occourence of find$ in mystring$ with replacewith$
Dim a$, b$
Dim As Long basei, i
If Len(myString$) = 0 Then Exit Function
a$ = myString$
b$ = LCase$(find$)
basei = 1
i = InStr(basei, LCase$(a$), b$)
If i > 0 Then
lw$ = Left$(a$, i - 1)
rw$ = Right$(a$, Len(a$) - (Len(lw$) + Len(find$)))
a$ = lw$ + replaceWith$ + rw$
End If
StrReplacefirst$ = a$
End Function
Sub buildtoomanyv
n = 0
For a = 1 To 5
For b = 1 To 5
For c = 1 To 5
For d = 1 To 5
n = n + 1
toomanyv$(n) = vowel$(a) + vowel$(b) + vowel$(c) + vowel$(d)
Next
Next
Next
Next
End Sub
|
