Generates a large list of randomly constructed words.
Can also generate several paragraphs of punctuated random text.
The MakeWord procedure is fully independent and easily coped to other programs.
Contains other procedures of interest as well such as:
MakeJibberJabber > make paragraphs of punctuated random text.
ColumnizeText > displays a sorted array with sequential items in columns rather than rows.
StackSort > my own sort routine that eliminates duplicates while it sorts.
Here is an amusing audio clip of the 'jibberish' text generated by 'Name The Baby'.
A text to speech program was used to produce this audio.
http://205.196.123.34/p98igd3zvf1g/5ixb ... Jabber.mp3
if the link above breaks, this one should work as well.
http://www.mediafire.com/?5ixbgwt3n7m4af9
B.P.
Code: Select all
; <><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
; <> <>
; <> NameTheBaby.pb - by BasicallyPure - 1.21.2012 <>
; <> <>
; <> Version 1.00 <>
; <> <>
; <> PureBasic 4.60 <>
; <> <>
; <><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
EnableExplicit
#BabyNames = 5000 ; how many names to make
Declare.s MakeWord(WordLength = 0, Mode = 0)
Declare.s ColumnizeText(Array Names.s(1), columns = 6, width = 12)
Declare StackSort(Array Names.s(1))
Declare.s MakeJibberJabber()
Dim Names.s(#BabyNames - 1)
Define Event ; store window event
Define text$ ; general usage
Define n ; loop counter
Define flags = #PB_Window_MinimizeGadget | #PB_Window_ScreenCentered
If Not OpenWindow(0, 0, 0, 950, 600, "Name The Baby", flags) : End : EndIf
;- Gadgets
;{
#EdtGad = 0
#BtnGad1 = 1
#BtnGad2 = 2
#BtnGad3 = 3
#BtnGad4 = 4
#FrameGad1 = 5
LoadFont(0,"Courier New", 12)
SetGadgetFont(#PB_Default, FontID(0))
EditorGadget(#EdtGad, 0 ,0 ,800 ,600)
SetGadgetColor(0, #PB_Gadget_FrontColor, $FFFFFF)
SetGadgetColor(0, #PB_Gadget_BackColor, $663E0B)
ButtonGadget(#BtnGad1, 824, 050, 102, 25, "New List")
ButtonGadget(#BtnGad2, 824, 090, 102, 25, "Sort")
ButtonGadget(#BtnGad3, 824, 130, 102, 25, "Randomize")
ButtonGadget(#BtnGad4, 824, 210, 102, 25, "Jibberish")
Frame3DGadget(#FrameGad1,810,25, 130,145, "Baby names")
;}
Macro makenames
; fill the array with random names
For n = 0 To #BabyNames - 1
Names(n) = MakeWord(0,1)
Next n
text$ = ColumnizeText(Names())
SetGadgetText(#EdtGad, text$)
EndMacro
makenames
;- event loop
;{
Repeat
Event = WaitWindowEvent()
If Event = #PB_Event_Gadget
Select EventGadget()
Case #BtnGad1 ; make new list
makenames
Case #BtnGad2 ; sort the names using my sort
StackSort(Names())
text$ = ColumnizeText(Names())
SetGadgetText(#EdtGad, text$)
Case #BtnGad3 ; randomize the names
RandomizeArray(Names())
text$ = ColumnizeText(Names())
SetGadgetText(#EdtGad, text$)
Case #BtnGad4 ; make jibber jabber
text$ = MakeJibberJabber()
SetGadgetText(#EdtGad, text$)
EndSelect
EndIf
Until Event = #PB_Event_CloseWindow
;}
End
Procedure.s MakeWord(WordLength = 0, Mode = 0)
; procedure returns a randomly constructed word
; if WordLength = 0 (default) then length is random 3 to 10
; mode = 0 --- all lower case (default)
; mode = 1 --- first letter is upper case
; mode = 2 --- all upper case
Protected vcFlag.i, LL$, NL$, word$
Static cc ; the number of available consonants
Static sc ; the number of special consonants
Static vc ; the number of available vowels
Static sv ; the number of special vowels
Static sb ; the number of special beginnings
Static con$ ; stores all of the available consonants
Static vow$ ; stores all of the available vowels
Static beg$ ; stores all special beginnings consonants
Static init = #True
Macro GetData(dataBlock, counterVariable, storageString)
Restore dataBlock
Read.s LL$
While LL$
counterVariable + 1
storageString + LL$
Read.s LL$
Wend
EndMacro
If init ; do this only once
; count and store all the consonants and vowels
GetData(consonants, cc, con$)
GetData(specialConsonants, sc, con$)
cc + sc - 1
GetData(vowels, vc, vow$)
GetData(specialVowels, sv, vow$)
vc + sv - 1
GetData(specialBeginnings, sb, beg$)
sb - 1
init = #False
EndIf
If WordLength < 1
WordLength = 3 + Random(3) + Random(2) + Random(2)
EndIf
If Random(10) > 2 ; make first letter a consonant
If Not Random(10) ; use a special beginning
word$ = RTrim(Mid(beg$, 1 + Random(sb) << 1, 2))
Else
word$ = RTrim(Mid(con$, 1 + Random(cc - sc) << 1, 2))
EndIf
vcFlag = #False
Else ; make first letter a vowel
word$ = RTrim(Mid(vow$, 1 + Random(vc - sv) << 1, 2))
vcFlag = #True
EndIf
LL$ = Right(word$,1)
While Len(word$) < WordLength ; choose the remaining letters
Repeat
Repeat
If vcFlag ; last was vowel so add a consonant
NL$ = RTrim(Mid(con$, 1 + Random(cc) << 1, 2))
Else ; last was consonant so add a vowel
NL$ = RTrim(Mid(vow$, 1 + Random(vc) << 1, 2))
EndIf
Until NL$ <> LL$
Until Len(word$) + Len(NL$) <= WordLength
word$ + NL$ : LL$ = Right(NL$,1) : vcFlag ! 1
Wend
Select mode
Case 0 ; default all lower case
; do nothing
Case 1 ; make first letter upercase
word$ = UCase(Left(word$,1)) + Right(word$,Len(word$)-1)
Case 2 ; make all letters uppercase
word$ = UCase(word$)
EndSelect
ProcedureReturn word$
DataSection
specialBeginnings: ; only used at word beginnings
Data.s "bl","br","cl","cr","dr","fl","fr","gr","kl","kr","pl","pr","qu","sl","sm"
Data.s "sn","sp","sw"
Data.s ""
consonants:
Data.s "b ","b ","c ","c ","c ","c ","d ","d ","d ","d ","d ","d ","f ","f ","f "
Data.s "g ","g ","g ","h ","h ","h ","h ","h ","h ","h ","h ","j ","j ","k ","l "
Data.s "l ","l ","l ","l ","m ","m ","m ","n ","n ","n ","n ","n ","n ","n ","n "
Data.s "n ","p ","p ","p ","r ","r ","r ","r ","r ","r ","r ","r ","s ","s ","s "
Data.s "s ","s ","s ","s ","s ","s ","t ","t ","t ","t ","t ","t ","t ","t ","t "
Data.s "t ","t ","t ","v ","w ","w ","w ","x ","x ","y ","y ","y ","z ","ch","th"
Data.s "sh","st","sk","sp","tr","ph"
Data.s ""
specialConsonants: ; never used at begining of words
Data.s "ng","nt","rk","nd","ck","ds","ks","rt","nk","bb","gg","ll","nn","ss"
Data.s ""
vowels:
Data.s "a ","a ","a ","e ","e ","e ","e ","e ","i ","i ","i "
Data.s "o ","o ","o ","u ","a ","a ","a ","e ","e ","e ","e "
Data.s "e ","i ","i ","i ","o ","o ","o ","u "
Data.s ""
specialVowels: ; never used at beginning of words
Data.s "oa","ea","ie","ia","ya","yo","oo","ee","y "
Data.s ""
EndDataSection
EndProcedure
Procedure.s ColumnizeText(Array Names.s(1), columns = 6, width = 12)
; This procedure returns a formated text string.
; give a one dimensional string array name as first parameter
; [optional] specify the number of columns and the width of each column.
; if tha array has been sorted then the array elements are shown with
; sequential items in columns instead of rows.
; This is irrelevent If the Array is not sorted.
Protected size = ArraySize(Names()) + 1
If Not size : ProcedureReturn "" : EndIf
Protected text$
Protected idx ; array index
Protected m, n ; loop counters
Protected increment, switch, maxM
Protected rows = size / columns ; number of full rows
Protected partial = size - (rows * columns) ; partial row
If partial : rows + 1 : EndIf
For n = 1 To rows
increment = rows
switch = partial
idx = n - 1
If n = rows And partial
maxM = partial
Else
maxM = columns
EndIf
For m = 1 To maxM
text$ + LSet(Names(idx), width)
idx + increment
If idx = size : Break : EndIf
switch - 1
If Not switch : increment - 1 : EndIf
Next m
text$ + #CRLF$
Next n
ProcedureReturn text$
EndProcedure
Procedure.s MakeJibberJabber()
; procedure returns a text string containg several
; paragraphs of punctuated and word wrapped jibberjabber.
Protected text$ ; holds procedure return text
Protected fc$ ; first character of word is: space or null
Protected w$ ; temporary storage of current line's text
Protected qFlag ; quote flag; if true then quote is open
Protected wc ; word count of each sentence
Protected LL ; character count of current line
Protected paragraphs, sentences, words ; loop counters
Protected WrapLimit = 77 ; words wrap beyond this column
For paragraphs = 1 To 35 + Random(10)
LL = 0
For sentences = 1 To 1 + Random(6) ; paragraph construction loop
wc = 4 + Random(10) ;set number words in this sentence
For words = 1 To wc ; sentence construction loop
If Not Random(15) And Not qFlag ; begin quote
LL - Len(text$)
text$ = RTrim(text$,",")
LL + Len(text$)
If words > 1
w$ + ", "
ElseIf LL
w$ + " "
EndIf
w$ + Chr(34) + MakeWord(0,1)
qFlag ! 1
ElseIf Not Random(16) ; upper case option
If Not Random(3) And words < wc ; if not last word
w$ + fc$ + MakeWord(0,2) + "!" ; all upper case
Else
w$ + fc$ + MakeWord(0,1) ; first letter upper case
EndIf
Else ; make ordinary word
w$ + fc$
If words = 1 ; capitalize first word of sentence
w$ + MakeWord(0,1)
Else
w$ + MakeWord()
EndIf
If Not Random(15) And words < wc
w$ + "," ; add comma
ElseIf Not Random(29)
w$ + "'s"
EndIf
EndIf
If Not Random(3) And qFlag ; end quote
w$ = RTrim(w$,",")
If Not Random(9)
w$ + "?" + Chr(34) ; end quote with question
Else
w$ + "," + Chr(34) ; end quote with comma
EndIf
qFlag ! 1
EndIf
If LL + Len(w$) > WrapLimit ; wrap before adding this word
text$ + #CRLF$
LL = 0
w$ = LTrim(LTrim(w$,",")," ")
EndIf
If wc > words ; sentence not finished
text$ + w$ ; add this word and continue
LL + Len(w$)
w$ = ""
EndIf
fc$ = " " ; space before next word
Next words
; end the sentence
If qFlag ; automatic end quote
If Not Random(4)
w$ + "?"
Else
w$ + "."
EndIf
w$ + Chr(34)
qFlag ! 1
Else
If Not Random(12)
w$ + "?"
Else
w$ + "."
EndIf
EndIf
If LL + Len(w$) > WrapLimit
w$ = LTrim(LTrim(w$,",")," ")
text$ + #CRLF$ + w$
LL = Len(w$)
Else
text$ + w$
LL + Len(w$)
EndIf
fc$ = " "
w$ = ""
Next sentences
fc$ = ""
text$ + #CRLF$ + #CRLF$
Next paragraphs
ProcedureReturn text$
EndProcedure
Procedure StackSort(Array List.s(1))
; sort a string array of one dimension
; this sorting algorithm was developed by BasicallyPure
; special feature > duplicate names are replaced by a new one
Protected a, b, n, max
Protected size = ArraySize(List())
Structure stk
List stack.s()
EndStructure
Dim Stacks.stk(size)
For a = 0 To size
AddElement(Stacks(a)\stack())
Next a
Macro PushStack(stackNumber, item)
AddElement(Stacks(stackNumber)\stack())
Stacks(stackNumber)\stack() = item
EndMacro
Macro PopStack(stackNumber)
Stacks(stackNumber)\stack()
DeleteElement(Stacks(stackNumber)\stack())
EndMacro
Repeat ; this is the sorting loop
max = 0 ; this variable remembers the maximum stack number used
; disperse items into sorting stacks
For n = 0 To size
a = 0 ; this variable indicates the active stack
While List(n) < Stacks(a)\stack() : a + 1 : Wend
If a > max : max = a : EndIf
PushStack(a, List(n))
Next n
; reassemble the array using two active stacks
a = 0 : b = 1
For n = size To 0 Step -1
; prevent duplicate names
If Stacks(a)\stack() = Stacks(b)\stack()
Stacks(a)\stack() = MakeWord(0,1)
EndIf
If Stacks(a)\stack() > Stacks(b)\stack()
List(n) = PopStack(a)
If ListIndex(Stacks(a)\stack()) = 0
a = b
If max > b : b + 1 : EndIf
EndIf
Else
List(n) = PopStack(b)
If ListIndex(Stacks(b)\stack()) = 0
If max > b : b + 1 : EndIf
EndIf
EndIf
Next n
Until max < 2
EndProcedure
