PDA

View Full Version : Random name generation



Lowercase
25-01-2009, 09:22 PM
i made this code to generate random name, it works but i don't think the result is really great...

basically, how it works :

you paste some text in the memo, click on button1 it will parse the text and put all couple of letters in the listbox. click now on button2, an it will generate a word in the edit

do someone know a better way ?


unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Memo1: TMemo;
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ D?İclarations priv?İes }
public
{ D?İclarations publiques }
end;

var
Form1: TForm1;

implementation

const
Alphabet = ['a'..'z']; { Uppercase letters have already been deleted! }
Vowels = ['a', 'e', 'i', 'o', 'u', 'y']; { Uppercase letters have already been deleted! }
Consonants = Alphabet - Vowels;

{$R *.dfm}
function validchar(c:char) : boolean ;
begin
result := false;
if (c in ['a'..'z']) then result:=true;
end;

function isConsonant (c:char) : boolean ;
begin
result := false;
if (c in Consonants) then result:=true;
end;

function isVowel (c:char) : boolean ;
begin
result := false;
if (c in Vowels) then result:=true;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
i,j,k :integer;
buffer,syl :string ;
found:boolean;
begin
for i := 0 to memo1.Lines.Count -1 do
begin
buffer := memo1.Lines[i];
buffer := lowercase(buffer);
j:=1;
while j $$ length(buffer)-1 do
if validchar(buffer[j]) and validchar(buffer[j+1]) then
begin
syl :=buffer[j]+buffer[j+1];
found:=false;
k:=0;
while k $$ listbox1.Items.Count do
begin
if syl = listbox1.Items[k] then found := true;
k:=k+1;
end;
if not found then listbox1.Items.Add(syl);
j:=j+1
end else j:=j+1;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
numsyl,i,j:integer;
str,temp,input:string;
bufferstrings:tstrings;
begin
numsyl:=5 + random(5);
str := listbox1.Items[random(listbox1.Items.Count)];
temp:= str;
//vcc
//ccv
//cvc
//cvv
bufferstrings:=Tstringlist.Create;
for i := 0 to numsyl-1 do
begin
bufferstrings.Clear;
for j := 0 to listbox1.Items.Count-1 do
begin
input:= listbox1.Items[j];

if isVowel( temp[1] ) then
begin
// 1st is a vowel
if isVowel( temp[2] ) then
begin
// 2nd is a vowel = 3rd must be a consonant
if (temp[2] = input[1]) and (not isVowel(input[1])) then bufferstrings.Add(listbox1.Items[j])
end
else
begin
// 2nd is a consonant = 3rd must be a consonant or vowel
if (temp[2] = input[1]) then bufferstrings.Add(listbox1.Items[j]);
end;
end
else
begin
// 1st is a consonant
if isVowel( temp[2] ) then
begin
// 2nd is a vowel = 3rd must be a consonant or vowel
if (temp[2] = input[1]) then bufferstrings.Add(listbox1.Items[j])
end
else
begin
// 2nd is a consonant = 3rd must be a vowel
if (temp[2] = input[1]) and (isVowel(input[1])) then bufferstrings.Add(listbox1.Items[j]);
end;
end;

end;
if bufferstrings.Count <> 0 then
begin
input:=bufferstrings.Strings[random(bufferstrings.Count)];
str := str + input[2];
temp:=input;
end
else
begin
break;
end
end;
edit1.Text:=str;
bufferstrings.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
randomize;
end;

end.

replace $$ by <>, i don't know why, it seems that bbcode parser cut a portion of code without this trick...

ize
05-03-2009, 03:17 PM
Hi there, are you still working on this? I'm fairly new and catching up on all the posts here - it's a great resource and i've learned a lot already. Normally if an app does roughly what i want it to do then i'm happy :)

It's not a better way, but here's a method:
i created "rules" for which letters can follow other letters depending on whether they start, end or are in the middle of the word.
This is more random than your method (i couldn't figure out what you put in the memo), most of the words aren't english, but you could change the rules to compenste for this.

Psuedo code:


loop through names
loop through all words in name
loop through all letters in word
pick a random letter
if it's been used already pick another one
if they've all been tried then exit to name loop
if there's only 1 letter in the word then skip checks
check vowel/consonant order (to make it semi-pronouncable)
check if this is a valid letter according to the ruleset
if any of the checks fail then exit to name loop
end letter loop
end word loop
end name loop


Here's the app. Still room for improvement, but it kinda works well enough for me :)
{*------------------------------------------------------------------------------
random name generator
@author ize
@version 2009/03/03 1.0 initial revision.
@comment quick pgd app to generate random names
-------------------------------------------------------------------------------}
program rng;

{$apptype console}

type
{*------------------------------------------------------------------------------
record to hold character info and rules
code: ascii code for char
exs: character exclusion for beginning of word. character indexes are or'd together
and 1 shifted left
eg: a=0, b=1, c=2. the "exs" for this would be (1 shl 0)+(1 shl 1)+(1 shl 2)=7
exs of 0 = exclude all chars, 67108863 = allow all chars
i have written an app so i didn't have to re-calc these :)
exn: as above but for exclusion within a word
exf: as above but for characters ending the word
-------------------------------------------------------------------------------}
tmychar = record
code: byte;
exs,exn,exf : cardinal;
end;

{*------------------------------------------------------------------------------
constants
-------------------------------------------------------------------------------}
const
maxchar = 26;
defminlen = 3;
defmaxlen = 6;
defwrdcnt = 1;
defgencnt = 10;
cs = 97; // starting character ascii code = "a"
vowels = [0,4,8,14,20]; // signify vowels in dataset
swchar = '/';
switches : array[0..7] of string[3] = ('cfg','min','max','gen','wrd','dbg','rnd','?');

{*------------------------------------------------------------------------------
global variables
-------------------------------------------------------------------------------}
var
cfg,defcfg : array[0..maxchar-1] of tmychar;
minlen,maxlen : integer;
gencount : integer;
wrdcount,nmelen : integer;
err : integer;
incomp : Boolean=False;

{*------------------------------------------------------------------------------
character index
@param c is the character to check
@return the character index for a given char
-------------------------------------------------------------------------------}
function ci(c: char): byte;
begin
result:=ord(c)-cs;
end;

{*------------------------------------------------------------------------------
check if a character is a vowel
@param c is the character to check
@return true if it is, false if not
-------------------------------------------------------------------------------}
function isvowel(c: char): boolean;
begin
result:=ci(c) in vowels;
end;

{*------------------------------------------------------------------------------
check if the current character is valid
@param wrd is the word to be checked
@param len is the desired name length
@return true if it's valid, false if not
-------------------------------------------------------------------------------}
function valid(const wrd: string;const len: integer): boolean;
var
i : integer;
c1,c2: byte;

{*------------------------------------------------------------------------------
vowel/consonant order check
checks there aren't too many vowels/consonants in succession. three characters are
checked
@param c a true element checks for a vowel, false for consonant
@return true if it fits the v/c ruleset, false if not
-------------------------------------------------------------------------------}
function check(c: array of boolean): boolean;
var
k: integer;
begin
result:=true;
for k:=0 to 2 do
result:=result and (isvowel(wrd[i+k])=c[k]);
end;

begin
// vowel/consonant check
i:=length(wrd)-2;
if i>=1 then begin
result:=
check([true, false, false]) or
check([true, false, true]) or
check([true, true, false]) or
check([false, false, true]) or
check([false, true, false]) or
check([false, true, true]);
if not result then exit;
end;

// check character exclusions
i:=length(wrd)-1;
c1:=ci(wrd[i]);
c2:=ci(wrd[i+1]);
if i=1 then result:=(cfg[c1].exs and (1 shl c2)=(1 shl c2)) // begin name
else if (i>1) and (i<len-1) then result:=(cfg[c1].exn and (1 shl c2)=(1 shl c2)) // in name
else if (i=len-1) then result:=(cfg[c2].exf and (1 shl c1)=(1 shl c1)) // end of name
else result:=true; //default result (1 char)
end;

{*------------------------------------------------------------------------------
add a character to the current name
@param wrd is the current word
@param len is the desired name length
@return the character to be added
-------------------------------------------------------------------------------}
function addchar(const wrd: string;const len: integer): string;
var
i,c: integer;
rep: array[0..maxchar-1] of byte; // to stop repeated character checks
b : boolean;
begin
result:='';
c:=0;
fillchar(rep,sizeof(rep),0);
repeat
// safeguard for infinite loop
inc(c);
if c>maxchar then begin
err:=-1;
exit;
end;
// only use un-tried characters
repeat
i:=random(maxchar);
until rep[i]=0;
rep[i]:=1;
b:=valid(wrd+chr(cfg[i].code),len);
if ((not b) and (incomp)) or (incomp) then writeln(len,'.',c,': ',wrd+chr(cfg[i].code));
until b;
result:=chr(cfg[i].code);
end;

{*------------------------------------------------------------------------------
return the maximum value. saves adding maths unit
@param a
@param b
@return biggest of the two vars
-------------------------------------------------------------------------------}
function max(a,b: integer): integer;
begin
if a>b then result:=a else result:=b;
end;

{*------------------------------------------------------------------------------
return the minimum value. saves adding maths unit
@param a
@param b
@return smallest of the two vars
-------------------------------------------------------------------------------}
function min(a,b: integer): integer;
begin
if a<b then result:=a else result:=b;
end;

{*------------------------------------------------------------------------------
convert a string to lowercase. saves adding sysutils unit
@param s is the string to convert
@return converted string
-------------------------------------------------------------------------------}
function lowercase(s: string): string;
var
i: integer;
begin
for i:=1 to length(s) do
if ord(s[i]) in [65..90] then s[i]:=chr(ord(s[i])+32);
result:=s;
end;

{*------------------------------------------------------------------------------
check if a fileexists. saves adding sysutils unit
@param fn is the filename to check
@return true if it exists, false if not
-------------------------------------------------------------------------------}
function fileexists(fn: string): boolean;
var
f: file of byte;
begin
{$i-} // turn off runtime errors
assignfile(f,fn);
reset(f);
closefile(f);
{$i+}
result:=(ioresult=0) and (fn<>'');
end;

{*------------------------------------------------------------------------------
convert a string to an integer
@param s is the string to convert
@param i is the converted integer
@return true if successful, false if not
-------------------------------------------------------------------------------}
function str2int(s: string;out i: integer): boolean;
var
c: integer;
begin
val(s,i,c);
result:=(c=0);
end;

{*------------------------------------------------------------------------------
load configuration from file
@param fn is the filename to load
-------------------------------------------------------------------------------}
procedure loadcfg(fn: string);
var
i: integer;
f: file of tmychar;
begin
fn:=lowercase(fn); // force lowercase
// check extension
if (not fileexists(fn)) or (copy(fn,length(fn)-3,4)<>'.rng') then begin
writeln('error loading file: ',fn);
writeln;
exit;
end;

{$i-} // turn off runtime errors.
assignfile(f,fn);
reset(f);
i:=0;
while (i<maxchar) and (not eof(f)) do begin
read(f,cfg[i]);
inc(i);
end;
closefile(f);
{$i+}
if (ioresult<>0) then begin
writeln('error loading file. using defaults');
writeln;
move(defcfg,cfg,sizeof(tmychar)*maxchar);
end;
end;

{*------------------------------------------------------------------------------
show app usage
-------------------------------------------------------------------------------}
procedure usage;
begin
write('usage: rng [/cfg filename] [/min number] [/max number] [/gen number]');
Writeln(' [/wrd number] [/dbg] [/rnd number]');
writeln;
writeln(' cfg load configuration file');
writeln(' min set minimum name length [3..max], default: ',defminlen);
writeln(' max set maximum name length [min..20], default: ',defmaxlen);
writeln(' gen set attempted number of names to generate [1..100], default: ',defgencnt);
writeln(' wrd set number of words per name [1..10], default: ',defwrdcnt);
writeln(' dbg debug mode (show all attempts)');
writeln(' rnd set the "seed" for randomization(0=use system clock)');
writeln(' ? display this help');
writeln;
halt;
end;

{*------------------------------------------------------------------------------
check the parameters
-------------------------------------------------------------------------------}
procedure checkparams;
var
i,o: integer;
found: boolean;
s: string;
label
skip;

{*------------------------------------------------------------------------------
get the parameter and convert it to a number
@param p is the parameter index
@param v is the return value
@param def is the default value to assign on error
@param l is the lower limit
@param h is the upper limit
-------------------------------------------------------------------------------}
procedure num(p: byte;out v: integer;const def,l,h: integer);
begin
if not str2int(paramstr(p),v) then v:=def
else v:=min(max(v,l),h);
end;

begin
if paramcount=0 then goto skip; // use defaults
i:=1;
while i<=paramcount do begin
s:=lowercase(paramstr(i));
if s[1]=swchar then begin
found:=false;
for o:=0 to high(switches) do
if copy(s,2,4)=string(switches[o]) then begin
if (i=paramcount) or (paramstr(i+1)[1]=swchar) then begin
if (copy(s,2,3)<>'dbg') and (copy(s,2,1)<>'?') then begin
writeln('no paramater for option: ',s);
halt;
end;
end;
if copy(s,2,3)='cfg' then loadcfg(paramstr(i+1))
else if copy(s,2,1)='?' then usage
else if copy(s,2,3)='dbg' then incomp:=True
else if copy(s,2,3)='rnd' then num(i+1,RandSeed,0,-maxint,MaxInt)
else if copy(s,2,3)='min' then num(i+1,minlen,defminlen,3,maxlen)
else if copy(s,2,3)='max' then num(i+1,maxlen,defmaxlen,minlen,20)
else if copy(s,2,3)='wrd' then num(i+1,wrdcount,defwrdcnt,1,10)
else if copy(s,2,3)='gen' then num(i+1,gencount,defgencnt,1,100);
found:=true;
break;
end;
if not found then begin
Writeln('unknown switch: ',s);
usage;
end;
end;
inc(i);
end;
skip:
if RandSeed=0 then Randomize;
if incomp then Writeln('Seed: ',RandSeed);
end;

{*------------------------------------------------------------------------------
initialization
-------------------------------------------------------------------------------}
procedure init;
var
i: integer;
begin
// set default char rules. allows all char combinations so names wont make much
// sense
for i:=0 to 25 do
with defcfg[i] do begin
code:=cs+i; exn:=67108863; exs:=67108863; exf:=67108863;
end;
minlen:=defminlen;
maxlen:=defmaxlen;
gencount:=defgencnt;
wrdcount:=defwrdcnt;
move(defcfg,cfg,sizeof(tmychar)*maxchar);
RandSeed:=0;
end;

{*------------------------------------------------------------------------------
main loop
-------------------------------------------------------------------------------}
procedure main;
var
t,i,o,p: byte;
text: string;
tmp,s: string;
begin
t:=0;
for i:=1 to gencount do begin
err:=0; // reset error flag
text:='';
// loop all names
for o:=1 to wrdcount do begin
nmelen:=minlen+random((maxlen-minlen)+1); // random length between min & max
p:=nmelen;
tmp:='';
// loop through current name
while nmelen>0 do begin
s:=addchar(tmp,p);
if err<>0 then Break
else tmp:=tmp+s;
dec(nmelen,max(length(s),1));
end;
if (err=0) and (o<wrdcount) then tmp:=tmp+' '; // add a space between names
if (err=0) or (incomp) then text:=text+tmp;
if err<>0 then Break;
end;
if err<>0 then text:=text+'-';
if ((err<>0) and (incomp)) or (err=0) then begin
Inc(t);
writeln('result(',i,'): '+text);
end;
end;
if t=0 then Writeln('No valid results generated');
end;

{*------------------------------------------------------------------------------
main code start
-------------------------------------------------------------------------------}
begin
writeln('random name generator v1.0');
writeln;
init;
checkparams;
main;
end.


Here are the apps: Random Name Generator (http://www.mediafire.com/?gzmddym2mzk)

Extract to a folder somewhere
rng.exe is the console app to generate the names.
run it from a command window and use /? for options

rngcodes.exe is the app to create/load/save the rulesets
pick a letter from the listbox choose which letters are allowed on the grid to the right. each letter has 3 sections for Starting, Ending & middle of the word. LMB selects & RMB clears

example.rng is just an example ruleset (most words aren't english, needs tweaking)

Lowercase
10-10-2009, 01:37 PM
Hey

Sorry for the bump...

Now, i use a dictionnary based procedure.

I'll take a look to your code and thanks by the way. ;D

Lowercase
03-04-2010, 05:11 PM
here is my try :


unit rndname;
{
rndname.pas unit
(C) 2010 lowercase - news431-516@yahoo.fr
Freeware/do whatever you like, but don't claim autorship for this
code, please.
Use at your own risk. Might be buggy.

Contents :
----------

Quick and dirty functions to generate random names, using
"pseudo markov chain" (no maths here).

How to use :
------------

1) load or build a dictionnary
2) just call CreateName
}

interface

uses classes, sysutils;

Procedure BuildDictionnary(afile : string);
//build a dictionnary from any text file
procedure SaveDictionnary(filename : string);
//Save a dictionnary into a file
procedure LoadDictionnary(filename : string);
//Load a dictionnary from an existing file
Function CreateName: string;
//the main goal : generate a name

implementation

Type
TDictionnary = array[0..26,0..26] of integer;
// holds the chars stats from A to Z and the last is space

const
ValidChars = 'ABCDEFGHJKLMNPQRSTUVWXYZ';

var
Dic : TDictionnary;
DicLoaded : boolean = false;

procedure UpdateDictionnary(char1, char2 : char);
var
pos1, pos2 : integer;
val : integer;
begin
pos1 := ord(char1) - 65 ;
pos2 := ord(char2) - 65 ;
if (char2=' ') then pos2 := 26;
val := dic[pos1,pos2];
val := val + 1 ;
dic[pos1,pos2] := val;
end;

procedure SaveDictionnary(filename : string);
var
F : Tfilestream;
begin
F := Tfilestream.Create(filename, fmcreate or fmopenreadwrite or fmsharedenynone);
try
F.Write(dic, Sizeof(dic));
finally
F.Free;
end;
end;

procedure LoadDictionnary(filename : string);
var
F : Tfilestream;
begin
F := Tfilestream.Create(filename, fmopenread or fmsharedenynone);
try
F.read(dic, Sizeof(dic));
finally
F.Free;
dicloaded := true;
end;
end;

Procedure BuildDictionnary(afile : string);
var
F : Tstringlist;
buffer : string;
k,i,j,len : integer;
c1,c2 : char;
begin
F:= Tstringlist.Create;
try
F.LoadFromFile(afile);
//compute combinations
for k := 0 to F.Count - 1 do
begin
buffer := f.Strings[k];
len := length(buffer);
buffer := uppercase(buffer);
for i := 1 to len do
begin
if buffer[i] <> ' ' then
begin
c1 := buffer[i];
if ((i+1) > len) then
UpdateDictionnary(c1,' ')
else
begin
c2 := buffer[i+1];
if c2= ' 'then UpdateDictionnary(c1,' ')
else UpdateDictionnary(c1,c2)
end;
end;
end;
end;

//average the result;
for i := 0 to 26 do
begin
len := 0;
for j := 0 to 26 do
begin
len := len + dic[i,j];
end;
if len > 0 then
for j := 0 to 26 do
begin
k := dic[i,j];
k := round(k * 100 / len);
dic[i,j] := k
end;
end;

finally
F.Free;
//SaveDictionnary;
dicloaded := true;
end;
end;

Function LookupNextChar(c : char; var dostop : boolean) : char;
var
pos,i : integer;
val, j : integer;
l : char;
charset : string;
begin
result := ' ';
charset := '';
pos := ord(c) - 65 ;
for i := 0 to 26 do
begin
val := dic[pos,i];
if val <> 0 then
begin
if i = 26 then
l := ' '
else
l := chr(65+i);
for j := 0 to val-1 do
charset := Charset + l;
end;
end;
dostop := (Length(charset) = 0);
if not(dostop) then
result := charset[Random(Length(charset)) + 1];
if result = ' ' then dostop := true;
end;

Function CreateName: string;
var
buffer : char;
maxlen,len : integer;
stop : boolean;
begin
if not DicLoaded then exit;
maxlen := random(4)+ 4;
repeat
result := '';
buffer := ValidChars[Random(Length(ValidChars)) + 1];
Result := result + buffer;
stop :=false;
repeat
buffer:=lookupnextchar(buffer,stop);
Result := result + buffer;
len :=length(Result);
until (len > maxlen) or stop;
until (len > maxlen);
end;

initialization
Randomize;
end.