element-lists/names-2.0.1-pascal/namegen1.pas

   1 unit Namegen1;
   2
   3 interface
   4
   5 uses
   6   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   7   Forms, Dialogs, StdCtrls, Menus, ExtCtrls, Spin, Clipbrd;
   8
   9 const
  10     ElementSize = 30;
  11     ElementArraySize = 2000;
  12     ListLines = 21;
  13
  14 type
  15   TNameGenerator = class(TForm)
  16     ForenameOpenDialog: TOpenDialog;
  17     SurnameOpenDialog: TOpenDialog;
  18     Forename: TLabel;
  19     Surname: TLabel;
  20     ForenameButton: TButton;
  21     SurnameButton: TButton;
  22     GenerateButton: TButton;
  23     Close: TButton;
  24     CopyButton: TButton;
  25     NameList: TListBox;
  26     MainMenu1: TMainMenu;
  27     File1: TMenuItem;
  28     Forename1: TMenuItem;
  29     Surname1: TMenuItem;
  30     Generate1: TMenuItem;
  31     Copy1: TMenuItem;
  32     Exit1: TMenuItem;
  33     N1: TMenuItem;
  34     N3: TMenuItem;
  35     SaveButton: TButton;
  36     ForenameOnly: TRadioButton;
  37     ForenameAndSurname: TRadioButton;
  38     SaveDialog: TSaveDialog;
  39     Save1: TMenuItem;
  40     ListFileButton: TButton;
  41     ListFile: TLabel;
  42     MassGenNumber: TSpinEdit;
  43     MassGenButton: TButton;
  44     ListTo1: TMenuItem;
  45     N2: TMenuItem;
  46     Massgenerate1: TMenuItem;
  47     EnhancedNADJ: TCheckBox;
  48     EnhancedNounCreation1: TMenuItem;
  49     N4: TMenuItem;
  50     procedure FormCreate(Sender: TObject);
  51     procedure FormDestroy(Sender: TObject);
  52     procedure ForenameButtonClick(Sender: TObject);
  53     procedure CloseClick(Sender: TObject);
  54     procedure Exit1Click(Sender: TObject);
  55     procedure Forename1Click(Sender: TObject);
  56     procedure SurnameButtonClick(Sender: TObject);
  57     procedure Surname1Click(Sender: TObject);
  58     procedure ListFileButtonClick(Sender: TObject);
  59     procedure ListTo1Click(Sender: TObject);
  60     procedure ForenameAndSurnameClick(Sender: TObject);
  61     procedure SaveButtonClick(Sender: TObject);
  62     procedure Save1Click(Sender: TObject);
  63     procedure GenerateButtonClick(Sender: TObject);
  64     procedure CopyButtonClick(Sender: TObject);
  65     procedure Generate1Click(Sender: TObject);
  66     procedure Copy1Click(Sender: TObject);
  67     procedure MassGenButtonClick(Sender: TObject);
  68     procedure Massgenerate1Click(Sender: TObject);
  69     procedure LoadForenameFile;
  70     procedure LoadSurnameFile;
  71     procedure MakeListFile;
  72     procedure SaveSelection;
  73     procedure GenerateNames;
  74     procedure CopySelection;
  75     procedure MassGenerate;
  76     procedure ForenameOnlyClick(Sender: TObject);
  77     procedure EnhancedNounCreation1Click(Sender: TObject);
  78     procedure EnhancedNADJClick(Sender: TObject);
  79   private
  80     { Private declarations }
  81   public
  82     { Public declarations }
  83   end;
  84
  85     TElement = string[ElementSize];
  86     TElementArray = array [1..ElementArraySize] of TElement;
  87     PElementArray = ^TElementArray;
  88
  89     function MyReadLn(FileHandle : integer; var ThisElement : string) : boolean;
  90     function MakeName : string;
  91     function MakeNameString(NPre, NAMid, ASuf : PElementArray; NPreNo, NAMidNO, ASufNo : integer; IsNADJ : boolean) : string;
  92     function Capitalise(Item : string) : string;
  93     function Plural(Item : string) : string;
  94     function Number(Item : string) : string;
  95     function NNName(Part1, Part2 : string) : string;
  96     function NAName(Noun, Adj : string) : string;
  97
  98 var
  99   NameGenerator                             : TNameGenerator;
 100
 101   ForenameLoaded, SurnameLoaded, ListLoaded,
 102   ForenameNADJ, SurnameNADJ                 : boolean;
 103
 104   ForenameNPre, ForenameNAMid, ForenameASuf,
 105   SurnameNPre,  SurnameNAMid,  SurnameASuf  : PElementArray;
 106
 107   ForenameNPreNo, ForenameNAMidNo, ForenameASufNo,
 108   SurnameNPreNo,  SurnameNAMidNo,  SurnameASufNo  : integer;
 109
 110
 111 implementation
 112
 113 {$R *.DFM}
 114
 115 procedure TNameGenerator.FormCreate(Sender: TObject);
 116 begin
 117     ForenameLoaded := FALSE;
 118     SurnameLoaded := FALSE;
 119     ForenameNPre  := AllocMem(SizeOf(TElementArray));
 120     ForenameNAMid := AllocMem(SizeOf(TElementArray));
 121     ForenameASuf  := AllocMem(SizeOf(TElementArray));
 122     SurnameNPre   := AllocMem(SizeOf(TElementArray));
 123     SurnameNAMid  := AllocMem(SizeOf(TElementArray));
 124     SurnameASuf   := AllocMem(SizeOf(TElementArray));
 125     ForenameNPreNo  := 0;
 126     ForenameNAMidNo := 0;
 127     ForenameASufNo  := 0;
 128     SurnameNPreNo   := 0;
 129     SurnameNAMidNo  := 0;
 130     SurnameASufNo   := 0;
 131 end;
 132
 133 procedure TNameGenerator.FormDestroy(Sender: TObject);
 134 begin
 135     FreeMem(ForenameNPre,  SizeOf(TElementArray));
 136     FreeMem(ForenameNAMid, SizeOf(TElementArray));
 137     FreeMem(ForenameASuf,  SizeOf(TElementArray));
 138     FreeMem(SurnameNPre,   SizeOf(TElementArray));
 139     FreeMem(SurnameNAMid,  SizeOf(TElementArray));
 140     FreeMem(SurnameASuf,   SizeOf(TElementArray));
 141 end;
 142
 143 procedure TNameGenerator.ForenameButtonClick(Sender: TObject);
 144 begin
 145     LoadForenameFile;
 146 end;
 147
 148 procedure TNameGenerator.Forename1Click(Sender: TObject);
 149 begin
 150     LoadForenameFile;
 151 end;
 152
 153 procedure TNameGenerator.SurnameButtonClick(Sender: TObject);
 154 begin
 155     LoadSurnameFile;
 156 end;
 157
 158 procedure TNameGenerator.Surname1Click(Sender: TObject);
 159 begin
 160     LoadSurnameFile;
 161 end;
 162
 163 procedure TNameGenerator.ListFileButtonClick(Sender: TObject);
 164 begin
 165     MakeListFile;
 166 end;
 167
 168 procedure TNameGenerator.ListTo1Click(Sender: TObject);
 169 begin
 170     MakeListFile;
 171 end;
 172
 173 procedure TNameGenerator.SaveButtonClick(Sender: TObject);
 174 begin
 175     SaveSelection;
 176 end;
 177
 178 procedure TNameGenerator.Save1Click(Sender: TObject);
 179 begin
 180     SaveSelection;
 181 end;
 182
 183 procedure TNameGenerator.GenerateButtonClick(Sender: TObject);
 184 begin
 185     GenerateNames;
 186 end;
 187
 188 procedure TNameGenerator.Generate1Click(Sender: TObject);
 189 begin
 190     GenerateNames;
 191 end;
 192
 193 procedure TNameGenerator.CopyButtonClick(Sender: TObject);
 194 begin
 195     CopySelection;
 196 end;
 197
 198 procedure TNameGenerator.Copy1Click(Sender: TObject);
 199 begin
 200     CopySelection;
 201 end;
 202
 203 procedure TNameGenerator.MassGenButtonClick(Sender: TObject);
 204 begin
 205     MassGenerate;
 206 end;
 207
 208 procedure TNameGenerator.Massgenerate1Click(Sender: TObject);
 209 begin
 210     MassGenerate;
 211 end;
 212
 213 procedure TNameGenerator.CloseClick(Sender: TObject);
 214 begin
 215     Halt;
 216 end;
 217
 218 procedure TNameGenerator.Exit1Click(Sender: TObject);
 219 begin
 220     Halt;
 221 end;
 222
 223 procedure TNameGenerator.ForenameOnlyClick(Sender: TObject);
 224 begin
 225     if ForenameLoaded then
 226         begin
 227             GenerateButton.Enabled := TRUE;
 228             Generate1.Enabled := TRUE;
 229             CopyButton.Enabled := TRUE;
 230             Copy1.Enabled := TRUE;
 231             if ListLoaded then
 232                 begin
 233                     MassGenButton.Enabled := TRUE;
 234                     Massgenerate1.Enabled := TRUE;
 235                 end;
 236         end;
 237 end;
 238
 239 procedure TNameGenerator.ForenameAndSurnameClick(Sender: TObject);
 240 begin
 241     if not SurnameLoaded then
 242         begin
 243             GenerateButton.Enabled := FALSE;
 244             Generate1.Enabled := FALSE;
 245             CopyButton.Enabled := FALSE;
 246             Copy1.Enabled := FALSE;
 247             MassGenButton.Enabled := FALSE;
 248             Massgenerate1.Enabled := FALSE;
 249         end;
 250 end;
 251
 252 procedure TNameGenerator.LoadForenameFile;
 253
 254 type
 255     TSection = (None, NPre, NAMid, ASuf);
 256
 257 var
 258     ForenameFileH : integer;
 259     Section : TSection;
 260     Element : TElement;
 261     FileLoadError, FileTypeSet, Finished : boolean;
 262
 263 begin
 264     ForenameOpenDialog.Execute;
 265     FileLoadError := TRUE;
 266     if FileExists(ForenameOpenDialog.FileName) then
 267         begin
 268             ForenameNPreNo := 0;
 269             ForenameNAMidNo := 0;
 270             ForenameASufNo := 0;
 271             ForenameFileH := FileOpen(ForenameOpenDialog.FileName, fmOpenRead or fmShareDenyWrite);
 272             FileLoadError := FALSE;
 273             FileTypeSet := FALSE;
 274             Finished := FALSE;
 275             Section := None;
 276             while (not Finished) and MyReadLn(ForenameFileH, Element) do {!!! SIDE EFFECT !!!}
 277                 begin
 278                     if (Length(Element) > 1) and (Element[1] = '#') then
 279                         begin
 280                             if FileTypeSet then
 281                                 begin
 282                                     if (Element = '#PRE') and (not ForenameNADJ) then
 283                                         Section := NPre
 284                                     else if (Element = '#MID') and (not ForenameNADJ) then
 285                                         Section := NAMid
 286                                     else if (Element = '#SUF') and (not ForenameNADJ) then
 287                                         Section := ASuf
 288                                     else if (Element = '#NOUN') and ForenameNADJ then
 289                                         Section := NPre
 290                                     else if (Element = '#NADJ') and ForenameNADJ then
 291                                         Section := NAMid
 292                                     else if (Element = '#ADJ') and ForenameNADJ then
 293                                         Section := ASuf
 294                                     else if Element = '#END' then
 295                                         Finished := TRUE
 296                                     else
 297                                         begin
 298                                             Finished := TRUE;
 299                                             FileLoadError := TRUE;
 300                                         end;
 301                                 end {if filetype set}
 302                             else
 303                                 begin
 304                                     if Element = '#PRE' then
 305                                         begin
 306                                             Section := NPre;
 307                                             FileTypeSet := TRUE;
 308                                             ForenameNADJ := FALSE;
 309                                         end
 310                                     else if Element = '#MID' then
 311                                         begin
 312                                             Section := NAMid;
 313                                             FileTypeSet := TRUE;
 314                                             ForenameNADJ := FALSE;
 315                                         end
 316                                     else if Element = '#SUF' then
 317                                         begin
 318                                             Section := ASuf;
 319                                             FileTypeSet := TRUE;
 320                                             ForenameNADJ := FALSE;
 321                                         end
 322                                     else if Element = '#NOUN' then
 323                                          begin
 324                                             Section := NPre;
 325                                             FileTypeSet := TRUE;
 326                                             ForenameNADJ := TRUE;
 327                                         end
 328                                     else if Element = '#NADJ' then
 329                                         begin
 330                                             Section := NAMid;
 331                                             FileTypeSet := TRUE;
 332                                             ForenameNADJ := TRUE;
 333                                         end
 334                                     else if Element = '#ADJ' then
 335                                         begin
 336                                             Section := ASuf;
 337                                             FileTypeSet := TRUE;
 338                                             ForenameNADJ := TRUE;
 339                                         end
 340                                     else if Element = '#END' then
 341                                         Finished := TRUE
 342                                     else
 343                                         begin
 344                                             Finished := TRUE;
 345                                             FileLoadError := TRUE;
 346                                         end;
 347                                 end; {else filetype not set}
 348                         end {if Control code}
 349                     else if FileTypeSet then
 350                         begin
 351                             case Section of
 352                                 NPre :
 353                                     begin
 354                                         inc(ForenameNPreNo);
 355                                         ForenameNPre^[ForenameNPreNo] := Element;
 356                                     end;
 357                                 NAMid :
 358                                     begin
 359                                         inc(ForenameNAMidNo);
 360                                         ForenameNAMid^[ForenameNAMidNo] := Element;
 361                                     end;
 362                                 ASuf :
 363                                     begin
 364                                         inc(ForenameASufNo);
 365                                         ForenameASuf^[ForenameASufNo] := Element;
 366                                     end;
 367                             end; {case}
 368                         end; {elseif data}
 369                 end; {while}
 370             if FileLoadError then
 371                 begin
 372                     Application.MessageBox('Error in file', 'Namegen', MB_OK + MB_ICONEXCLAMATION);
 373                     ForenameLoaded := FALSE;
 374                     Forename.Caption := '';
 375                     GenerateButton.Enabled := FALSE;
 376                     Generate1.Enabled := FALSE;
 377                     CopyButton.Enabled := FALSE;
 378                     Copy1.Enabled := FALSE;
 379                     if ListLoaded then
 380                         begin
 381                             SaveButton.Enabled := TRUE;
 382                             Save1.Enabled := TRUE;
 383                             MassGenButton.Enabled := FALSE;
 384                             Massgenerate1.Enabled := FALSE;
 385                         end;
 386                 end
 387             else
 388                 begin
 389                     ForenameLoaded := TRUE;
 390                     Forename.Caption := LowerCase(ExtractFileName(ForenameOpenDialog.Filename));
 391                     if ForenameOnly.Checked or
 392                         (ForenameAndSurname.Checked and SurnameLoaded) then
 393                         begin
 394                             GenerateButton.Enabled := TRUE;
 395                             Generate1.Enabled := TRUE;
 396                             CopyButton.Enabled := TRUE;
 397                             Copy1.Enabled := TRUE;
 398                             if ListLoaded then
 399                                 begin
 400                                     SaveButton.Enabled := TRUE;
 401                                     Save1.Enabled := TRUE;
 402                                     MassGenButton.Enabled := TRUE;
 403                                     Massgenerate1.Enabled := TRUE;
 404                                 end;
 405                         end;
 406                 end;
 407             FileClose(ForenameFileH);
 408         end {if FileExists}
 409     else
 410         Application.MessageBox('File does not exist', 'Namegen', MB_OK + MB_ICONEXCLAMATION);
 411 end;
 412
 413 procedure TNameGenerator.LoadSurnameFile;
 414
 415 type
 416     TSection = (None, NPre, NAMid, ASuf);
 417
 418 var
 419     SurnameFileH : integer;
 420     Section : TSection;
 421     Element : TElement;
 422     FileLoadError, FileTypeSet, Finished : boolean;
 423
 424 begin
 425     SurnameOpenDialog.Execute;
 426     FileLoadError := TRUE;
 427     if FileExists(SurnameOpenDialog.FileName) then
 428         begin
 429             SurnameNPreNo := 0;
 430             SurnameNAMidNo := 0;
 431             SurnameASufNo := 0;
 432             SurnameFileH := FileOpen(SurnameOpenDialog.FileName, fmOpenRead or fmShareDenyWrite);
 433             FileLoadError := FALSE;
 434             FileTypeSet := FALSE;
 435             Finished := FALSE;
 436             Section := None;
 437             while (not Finished) and MyReadLn(SurnameFileH, Element) do {!!! SIDE EFFECT !!!}
 438                 begin
 439                     if (Length(Element) > 1) and (Element[1] = '#') then
 440                         begin
 441                             if FileTypeSet then
 442                                 begin
 443                                     if (Element = '#PRE') and (not SurnameNADJ) then
 444                                         Section := NPre
 445                                     else if (Element = '#MID') and (not SurnameNADJ) then
 446                                         Section := NAMid
 447                                     else if (Element = '#SUF') and (not SurnameNADJ) then
 448                                         Section := ASuf
 449                                     else if (Element = '#NOUN') and SurnameNADJ then
 450                                         Section := NPre
 451                                     else if (Element = '#NADJ') and SurnameNADJ then
 452                                         Section := NAMid
 453                                     else if (Element = '#ADJ') and SurnameNADJ then
 454                                         Section := ASuf
 455                                     else if Element = '#END' then
 456                                         Finished := TRUE
 457                                     else
 458                                         begin
 459                                             Finished := TRUE;
 460                                             FileLoadError := TRUE;
 461                                         end;
 462                                 end {if filetype set}
 463                             else
 464                                 begin
 465                                     if Element = '#PRE' then
 466                                         begin
 467                                             Section := NPre;
 468                                             FileTypeSet := TRUE;
 469                                             SurnameNADJ := FALSE;
 470                                         end
 471                                     else if Element = '#MID' then
 472                                         begin
 473                                             Section := NAMid;
 474                                             FileTypeSet := TRUE;
 475                                             SurnameNADJ := FALSE;
 476                                         end
 477                                     else if Element = '#SUF' then
 478                                         begin
 479                                             Section := ASuf;
 480                                             FileTypeSet := TRUE;
 481                                             SurnameNADJ := FALSE;
 482                                         end
 483                                     else if Element = '#NOUN' then
 484                                          begin
 485                                             Section := NPre;
 486                                             FileTypeSet := TRUE;
 487                                             SurnameNADJ := TRUE;
 488                                         end
 489                                     else if Element = '#NADJ' then
 490                                         begin
 491                                             Section := NAMid;
 492                                             FileTypeSet := TRUE;
 493                                             SurnameNADJ := TRUE;
 494                                         end
 495                                     else if Element = '#ADJ' then
 496                                         begin
 497                                             Section := ASuf;
 498                                             FileTypeSet := TRUE;
 499                                             SurnameNADJ := TRUE;
 500                                         end
 501                                     else if Element = '#END' then
 502                                         Finished := TRUE
 503                                     else
 504                                         begin
 505                                             Finished := TRUE;
 506                                             FileLoadError := TRUE;
 507                                         end;
 508                                 end {else filetype not set}
 509                         end {if Control code}
 510                     else if FileTypeSet then
 511                         begin
 512                             case Section of
 513                                 NPre :
 514                                     begin
 515                                         inc(SurnameNPreNo);
 516                                         SurnameNPre^[SurnameNPreNo] := Element;
 517                                     end;
 518                                 NAMid :
 519                                     begin
 520                                         inc(SurnameNAMidNo);
 521                                         SurnameNAMid^[SurnameNAMidNo] := Element;
 522                                     end;
 523                                 ASuf :
 524                                     begin
 525                                         inc(SurnameASufNo);
 526                                         SurnameASuf^[SurnameASufNo] := Element;
 527                                     end;
 528                             end; {case}
 529                         end; {elseif data}
 530                 end; {while}
 531             if FileLoadError then
 532                 begin
 533                     Application.MessageBox('Error in file', 'Namegen', MB_OK + MB_ICONEXCLAMATION);
 534                     SurnameLoaded := FALSE;
 535                     Surname.Caption := '';
 536                     ForenameAndSurname.Enabled := FALSE;
 537                     if ForenameAndSurname.Checked then
 538                         begin
 539                             GenerateButton.Enabled := FALSE;
 540                             Generate1.Enabled := FALSE;
 541                             CopyButton.Enabled := FALSE;
 542                             Copy1.Enabled := TRUE;
 543                             if ListLoaded then
 544                                 begin
 545                                     SaveButton.Enabled := TRUE;
 546                                     Save1.Enabled := TRUE;
 547                                     MassGenButton.Enabled := FALSE;
 548                                     Massgenerate1.Enabled := FALSE;
 549                                 end;
 550                         end;
 551                 end
 552             else
 553                 begin
 554                     SurnameLoaded := TRUE;
 555                     Surname.Caption := LowerCase(ExtractFileName(SurnameOpenDialog.Filename));
 556                     ForenameAndSurname.Enabled := TRUE;
 557                     ForenameAndSurname.Checked := TRUE;
 558                     if ForenameLoaded then
 559                         begin
 560                             GenerateButton.Enabled := TRUE;
 561                             Generate1.Enabled := TRUE;
 562                             CopyButton.Enabled := TRUE;
 563                             Copy1.Enabled := TRUE;
 564                             if ListLoaded then
 565                                 begin
 566                                     SaveButton.Enabled := TRUE;
 567                                     Save1.Enabled := TRUE;
 568                                     MassGenButton.Enabled := TRUE;
 569                                     Massgenerate1.Enabled := TRUE;
 570                                 end;
 571                         end;
 572                 end;
 573             FileClose(SurnameFileH);
 574         end {if FileExists}
 575     else
 576         Application.MessageBox('File does not exist', 'Namegen', MB_OK + MB_ICONEXCLAMATION);
 577 end;
 578
 579
 580 procedure TNameGenerator.MakeListFile;
 581 begin
 582     SaveDialog.Execute;
 583     ListFile.Caption := Lowercase(ExtractFileName(SaveDialog.FileName));
 584     if GenerateButton.Enabled then
 585         begin
 586             SaveButton.Enabled := TRUE;
 587             Save1.Enabled := TRUE;
 588             MassGenButton.Enabled := TRUE;
 589             Massgenerate1.Enabled := TRUE;
 590         end;
 591 end;
 592
 593
 594 procedure TNameGenerator.GenerateNames;
 595
 596 var
 597     i : integer;
 598
 599 begin
 600     Randomize;
 601     NameList.Clear;
 602     for i := 1 to ListLines do
 603         begin
 604             NameList.Items.Add(MakeName);
 605         end;
 606 end;
 607
 608
 609 procedure TNameGenerator.CopySelection;
 610
 611 var
 612     i : integer;
 613     ItemString, TempString : PChar;
 614
 615 begin
 616     if NameList.ItemIndex <> 0 then
 617         begin
 618             Clipboard.Clear;
 619             Clipboard.Open;
 620             ItemString := StrAlloc(258 * ListLines);
 621             StrPCopy(ItemString, '');
 622             TempString := StrAlloc(258);
 623             for i := 0 to ListLines - 1 do
 624                 begin
 625                     if NameList.Selected[i] then
 626                         begin
 627                             StrPCopy(TempString,(NameList.Items[i] + #13 + #10));
 628                             StrCat(ItemString, TempString);
 629                         end;
 630                 end;
 631             Clipboard.SetTextBuf(ItemString);
 632             StrDispose(TempString);
 633             StrDispose(ItemString);
 634             Clipboard.Close;
 635         end;
 636 end;
 637
 638
 639 procedure TNameGenerator.SaveSelection;
 640
 641 var
 642     OutputFile : TextFile;
 643     i : integer;
 644
 645 begin
 646     AssignFile(OutputFile, ExtractFileName(SaveDialog.FileName));
 647     if FileExists(ExtractFileName(SaveDialog.FileName)) then
 648         Append(OutputFile)
 649     else
 650         Rewrite(OutputFile);
 651     for i := 0 to ListLines - 1 do
 652         begin
 653             if NameList.Selected[i] then
 654                 begin
 655                     WriteLn(OutputFile, NameList.Items[i]);
 656                 end;
 657         end;
 658     CloseFile(OutputFile);
 659 end;
 660
 661
 662 procedure TNameGenerator.MassGenerate;
 663
 664 var
 665     OutputFile : TextFile;
 666     i : integer;
 667
 668 begin
 669     Randomize;
 670     AssignFile(OutputFile, ExtractFileName(SaveDialog.FileName));
 671     if FileExists(ExtractFileName(SaveDialog.FileName)) then
 672         Append(OutputFile)
 673     else
 674         Rewrite(OutputFile);
 675     for i := 1 to MassGenNumber.Value do
 676         begin
 677             WriteLn(OutputFile, MakeName);
 678         end;
 679     CloseFile(OutputFile);
 680 end;
 681
 682
 683 function MyReadLn(FileHandle : integer; var ThisElement : string) : boolean;
 684
 685 var
 686     Eric : char;
 687     ReadResult : longint;
 688     i : integer;
 689
 690 begin
 691     ThisElement := '';
 692     ReadResult := FileRead(FileHandle, Eric, 1);
 693     i := 0;
 694     while (ReadResult = 1) and (Ord(Eric) <> 10) and (i <= High(ThisElement)) do
 695         begin
 696             if (Ord(Eric) <> 10) and (Ord(Eric) <> 13) then
 697                 begin
 698                     ThisElement := ThisElement + Eric;
 699                     inc(i);
 700                 end; {if}
 701             ReadResult := FileRead(FileHandle, Eric, 1);
 702         end; {while}
 703     if ReadResult = 1 then
 704         MyReadLn := TRUE
 705     else
 706         MyReadLn := FALSE;
 707 end;
 708
 709
 710 function MakeName : string;
 711
 712 var
 713     TempString : string;
 714
 715 begin
 716     TempString := MakeNameString(ForenameNPre, ForenameNAMid, ForenameASuf,
 717                     ForenameNPreNo, ForenameNAMidNo, ForenameASufNo, ForenameNADJ);
 718     if NameGenerator.ForenameAndSurname.Checked and SurnameLoaded then
 719         TempString := TempString + ' ' + MakeNameString(SurnameNPre, SurnameNAMid, SurnameASuf,
 720                         SurnameNPreNo, SurnameNAMidNo, SurnameASufNo, SurnameNADJ);
 721     MakeName := TempString;
 722 end;
 723
 724
 725 function MakeNameString(NPre, NAMid, ASuf : PElementArray; NPreNo, NAMidNo, ASufNo : integer; IsNADJ : boolean) : string;
 726
 727 var
 728     Part1, Part2, Part3, Combined : string;
 729     NounSelectionArray : array[1..5] of char;
 730     NSANo : integer;
 731
 732 begin
 733     if IsNADJ then
 734         begin
 735 {            Application.MessageBox('NADJ generation not yet implemented', 'Name generator', 0);}
 736             NSANo := 0;
 737             if NPreNo > 0 then
 738                 begin
 739                     inc(NSANo);
 740                     NounSelectionArray[NSANo] := 'N';   {noun noun}
 741                 end;
 742             if NAMidNo > 0 then
 743                 begin
 744                     inc(NSANo);
 745                     NounSelectionArray[NSANo] := 'X';   {nadj nadj}
 746                 end;
 747             if (NPreNo > 0) and (ASufNo > 0) then
 748                 begin
 749                     inc(NSANo);
 750                     NounSelectionArray[NSANo] := 'A';   {noun adj}
 751                 end;
 752             if (NPreNo > 0) and (NAMidNo > 0) then
 753                 begin
 754                     inc(NSANo);
 755                     NounSelectionArray[NSANo] := 'Y';   {noun nadj}
 756                 end;
 757             if (NAMidNo > 0) and (ASufNo > 0) then
 758                 begin
 759                     inc(NSANo);
 760                     NounSelectionArray[NSANo] := 'Z';   {nadj adj}
 761                 end;
 762             case NounSelectionArray[Random(NSANo) + 1] of
 763                 'N' :   begin
 764                             Part1 := NPre^[Random(NPreNo) + 1];
 765                             Part2 := NPre^[Random(NPreNo) + 1];
 766                             Combined := NNName(Part1, Part2);
 767                         end;
 768                 'X' :   begin
 769                             Part1 := NAMid^[Random(NAMidNo) + 1];
 770                             Part2 := NAMid^[Random(NAMidNo) + 1];
 771                             Combined := NNName(Part1, Part2);
 772                         end;
 773                 'A' :   begin
 774                             Part1 := NPre^[Random(NPreNo) + 1];
 775                             Part2 := ASuf^[Random(ASufNo) + 1];
 776                             Combined := NAName(Part1, Part2);
 777                         end;
 778                 'Y' :   begin
 779                             Part1 := NPre^[Random(NPreNo) + 1];
 780                             if Random(2) = 0 then
 781                                 Part2 := NAMid^[Random(NAMidNo) + 1]
 782                             else
 783                                 Part2 := ASuf^[Random(ASufNo) + 1];
 784                             Combined := NAName(Part1, Part2);
 785                         end;
 786                 'Z' :   begin
 787                             if Random(2) = 0 then
 788                                 Part1 := NAMid^[Random(NAMidNo) + 1]
 789                             else
 790                                 Part1 := NPre^[Random(NPreNo) + 1];
 791                             Part2 := ASuf^[Random(ASufNo) + 1];
 792                             Combined := NAName(Part1, Part2);
 793                         end;
 794             end; {case}
 795         end { if block }
 796     else
 797         begin
 798             if NPreNo > 0 then
 799                 Part1 := NPre^[Random(NPreNo) + 1]
 800             else
 801                 Part1 := '';
 802             if NAMidNo > 0 then
 803                 Part2 := NAMid^[Random(NAMidNo)+1]
 804             else
 805                 Part2 := '';
 806             if ASufNo > 0 then
 807                 Part3 := ASuf^[Random(ASufNo)+1]
 808             else
 809                 Part3 := '';
 810 {            Combined := Part1 + Part2 + Part3;
 811             Part1 := Combined;
 812             Combined := Capitalise(Part1); }
 813             Combined := Capitalise(Part1 + Part2 + Part3);
 814         end;
 815         MakeNameString := Combined;
 816 end;
 817
 818
 819 function Capitalise(Item :string) : string;
 820
 821 begin
 822     if (Item[1] >= 'a') and (Item[1] <= 'z') then
 823         Item[1] := Chr(Ord(Item[1]) + Ord('A') - Ord('a'))
 824     else if (Item[1] >= 'à') and (Item[1] <= 'þ') then
 825         Item[1] := Chr(Ord(Item[1]) + Ord('Þ') - Ord('þ'));
 826     Capitalise := Item;
 827 end;
 828
 829
 830 function Plural(Item : string) : string;
 831 var
 832     i : integer;
 833
 834 begin
 835     i := Length(Item);
 836     case Item[i] of
 837         'a', 'e', 'i', 'o', 'u' :
 838             Plural := Item + 's';
 839         'y' :
 840             case Item[i-1] of
 841                 'a', 'e', 'i', 'o', 'u' :
 842                     Plural := Item + 's';
 843                 else
 844                     Plural := Copy(Item, 1, i-1) + 'ies';
 845                 end;
 846         's' :
 847             if Item[i-1] = 's' then
 848                 Plural := Item + 'es'
 849             else
 850                 Plural := Item;
 851         'h' :
 852             case Item[i-1] of
 853                 't', 's', 'c', 'r', 'z' :
 854                     Plural := Item + 'es';
 855                 else
 856                     Plural := Item + 's';
 857             end;
 858         'f' :
 859             if Copy(Item, i-3, 3) = 'aff' then
 860                 Plural := Copy(Item, 1, i-3) + 'aves'
 861             else if Copy(Item, i-3, 3) = 'arf' then
 862                 Plural := Copy(Item, 1, i-3) + 'arves'
 863             else if Copy(Item, i-3, 3) = 'elf' then
 864                 Plural := Copy(Item, 1, i-3) + 'elves'
 865             else
 866                 Plural := Item + 's';
 867         'c', 'j', 'x', 'v', 'z' :
 868             Plural := Item;
 869         else
 870             Plural := Item + 's';
 871     end;
 872 end;
 873
 874
 875 function Number(Item : string) : string;
 876 begin
 877     case Random(17) of
 878         0  : Number := 'No ' + Plural(Item);
 879         1  : Number := 'One ' + Item;
 880         2  : Number := 'Two ' + Plural(Item);
 881         3  : Number := 'Three ' + Plural(Item);
 882         4  : Number := 'Four ' + Plural(Item);
 883         5  : Number := 'Five ' + Plural(Item);
 884         6  : Number := 'Six ' + Plural(Item);
 885         7  : Number := 'Seven ' + Plural(Item);
 886         8  : Number := 'Eight ' + Plural(Item);
 887         9  : Number := 'Nine ' + Plural(Item);
 888         10 : Number := 'Ten ' + Plural(Item);
 889         11 : Number := 'Eleven ' + Plural(Item);
 890         12 : Number := 'Twelve ' + Plural(Item);
 891
 892         13 : Number := 'Hundred ' + Plural(Item);
 893         14 : Number := 'Lone ' + Item;
 894         15 : Number := 'Many ' + Plural(Item);
 895         16 : Number := 'Few ' + Plural(Item);
 896     end;
 897 end;
 898
 899
 900 function NNName(Part1, Part2 : string) : string;
 901
 902 var
 903     i : integer;
 904
 905 begin
 906     if NameGenerator.EnhancedNADJ.Checked then
 907         i := Random(4)
 908     else
 909         i := 0;
 910     case i of
 911 {        0 : NNName := Capitalise(Part1 + Part2);}
 912         0 : NNName := Capitalise(Part1 + 's' + Part2);
 913         1 : begin
 914                 if Random(2) = 0 then
 915                     NNName := Capitalise(Plural(Part1)) + ' of ' + Capitalise(Part2)
 916                 else
 917                     NNName := Capitalise(Part1) + ' of ' + Capitalise(Plural(Part2));
 918             end;
 919         2 : begin
 920                 case Random(3) of
 921                     0 : NNName := Capitalise(Plural(Part1)) + ' of the ' + Capitalise(Part2);
 922                     1 : NNName := Capitalise(Part1) + ' of the ' + Capitalise(Plural(Part2));
 923                     2 : NNName := Capitalise(Plural(Part1)) + ' of the ' + Capitalise(Plural(Part2));
 924                 end;
 925             end;
 926         3 : NNName := Number(Capitalise(Part1));
 927     end;
 928 end;
 929
 930
 931 function NAName(Noun, Adj : string) : string;
 932
 933 var
 934     i : integer;
 935     Temp : string;
 936
 937 begin
 938     if NameGenerator.EnhancedNADJ.Checked then
 939         i := Random(3)
 940     else
 941         i := Random(2);
 942     case i of
 943         0 : NAName := Capitalise(Adj + Noun);
 944         1 : NAName := Capitalise(Adj) + ' ' + Capitalise(Noun);
 945         2 : begin
 946                 Temp := Capitalise(Adj) + ' ' + Capitalise(Noun);
 947                 NAName := Number(Temp);
 948             end;
 949     end;
 950 end;
 951
 952 procedure TNameGenerator.EnhancedNounCreation1Click(Sender: TObject);
 953 begin
 954     if EnhancedNounCreation1.Checked then
 955         begin
 956             EnhancedNounCreation1.Checked := FALSE;
 957             EnhancedNADJ.Checked := FALSE;
 958         end
 959     else
 960         begin
 961             EnhancedNounCreation1.Checked := TRUE;
 962             EnhancedNADJ.Checked := TRUE;
 963         end;
 964 end;
 965
 966 procedure TNameGenerator.EnhancedNADJClick(Sender: TObject);
 967 begin
 968     if EnhancedNADJ.Checked then
 969         begin
 970             EnhancedNounCreation1.Checked := TRUE;
 971         end
 972     else
 973         begin
 974             EnhancedNounCreation1.Checked := FALSE;
 975         end;
 976 end;
 977
 978 end.