gramm

   1 #!/usr/bin/perl
   2
   3 readgram( <<EOF
   4 name -> male | 300#female | 500#expobj COMMA Experimental object
   5 male -> title first mid last post
   6 female -> titlef firstf mid lastf post
   7 expobj -> firstf mid lastf | first mid last
   8 first -> Joachim | Maledictus | Octavianus | Marcus | Greebo | Graham | John | Stanislaw | Bastian Baltazar | Pedro | Alfred | Gonzales 'Speedy' | Karl | Anthony | Lobsang | Niemand | Siegfried | Magdulan | Ulthen | Siricitan | Quido | Vasilij | Diabetes
   9 firstf -> Jacquelinne | Melinda | Pythia | Catherine | Magrat | Granny | Esmeralda | Mona
  10 last -> 5000#lastu | Trestivec | Larva | Sodny | Draselny | Melitus | Hydrogenes
  11 lastf -> 5000#lastu | Trestivcova | Larvova | Sodna | Draselna | Melita | Hydrogena | Ogg | Weatherwax | Lisa
  12 lastu -> Aurelius | Woshtepp | von Draczek | Portius | Simon | de Ath | Faust | Bux | Jimenez | de la Cruz | Mosquitto | Thorndyke | Smith | Marx | Crowley | O'Body | Rondevald | Umwald | Sleedill | Morbispictus
  13 title -> 3000#Mgr. | 2000#Dr. | Prof. | 2000#Mg. | Sir | PUDr. | 3000#
  14 titlef -> 3000#Mgr. | 2000#Dr. | Prof. | 2000#Mg. | Lady | JUDr. | 3000#
  15 post -> COMMA Dr. h. c. | COMMA Laureate of Nobel Prize | COMMA Certified Idiot | COMMA Archmage | COMMA Polyhistor | 3000#
  16 secretary -> firstf mid lastf sec | 100#first mid last sec
  17 sec -> COMMA Secretary
  18 chief -> Prof. first mid last COMMA Director of the Laboratory
  19 mid -> A. | B. | C. | D. | E. | F. | G. | H. | I. | J. | K. | L. | M. | N. | O. | P. | Q. | R. | S. | T. | U. | V. | W. | X. | Y. | Z. | 26000#
  20 EOF
  21 );
  22
  23 print generate('chief'), "\n";
  24 $ee = 1+rrr(3);
  25 for($e=0; $e<$ee; $e++) { print generate('secretary'), "\n"; }
  26 $ee = 5+rrr(20);
  27 for($e=0; $e<$ee; $e++) { print generate('name'), "\n"; }
  28 exit 0;
  29
  30 sub rrr {
  31         my $l = shift @_;
  32         return int($l*rand);
  33 }
  34
  35 sub readgram {
  36         my $l = shift @_;
  37         my $a;
  38         for $a (split(/\n/, $l)) {
  39                 ($a =~ /^(\w+) -> (.*)$/) || die "Invalid rule: $a";
  40                 $gr{$1} = $2;
  41         }
  42 }
  43
  44 sub generate {
  45         my $w = shift @_;
  46         my $f='';
  47         my $t, $z, $r, $a, $i;
  48         for(;;) {
  49                 if ($w !~ /^\s*([.'a-zA-Z0-9_-]+)(.*)$/) {
  50 #                       print "DONE\n";
  51                         last;
  52                 }
  53                 $w = $2;
  54                 $t = $1;
  55                 if (!defined $gr{$t}) {
  56 #                       print "Terminal <$t>\n";
  57                         $f="$f $t";
  58                 } else {
  59                         $z=0;
  60                         $r=$gr{$t};
  61                         foreach $a (split(/\|/,$r)) {
  62                                 $z += ($a =~ /^(.*)#/) ? $1 : 1000;
  63                         }
  64                         $i=int($z*rand);
  65                         $z=0;
  66                         foreach $a (split(/\|/,$r)) {
  67                                 $z += ($a =~ /^(.*)#/) ? $1 : 1000;
  68                                 if ($i < $z) { $A=$a; last; }
  69                         }
  70                         $A =~ s/.*\#//;
  71 #                       print "Expanding <$t> -> <$A>\n";
  72                         $w = "$A $w";
  73                 }
  74         }
  75         $f =~ s/^\s+//;
  76         $f =~ s/\s*COMMA/,/g;
  77         return $f;
  78 }