Results 1 to 4 of 4

Thread: Random name generation

  1. #1

    Random name generation

    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 ?

    [pascal]
    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.[/pascal]

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

  2. #2

    Re: Random name generation

    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:
    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 [pascal]
    {*------------------------------------------------------------------------------
    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.
    [/pascal]

    Here are the apps: Random Name Generator

    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)
    Windows Vista x64 Ultimate<br />AMD Athlon x64 4000+<br />Codegear Delphi 2009, Delphi 2007, Borland Delphi 7

  3. #3

    Re: Random name generation

    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.

  4. #4

    Re: Random name generation

    here is my try :

    [pascal]
    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.
    [/pascal]

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Comodo SSL