Re: Seeking Perl poetry code that writes poems

Ok, I have implemented a little random text/poem/haiku generator. I bumped into Julie Zelenski's webpage when I was searching for some perl poetry material. I had a look at the grammar, thought it was fun, and easy to parse. So I implemented a perl version of the grammar parser and random text/poem generator. It was pretty fun to play with, especially with a Star Trek episode generator (yeah you can tell I am a big star trek fan ;-)). Here it goes...

#!/usr/local/bin/perl -w
use strict;
use Data::Dumper;

=pod

#
# ok, the following is the location of the grammar files at
# Julie Zelenski's webpage at stanford's computer science faculty.
# I was thinking about using WWW::Mechanize or LWP::Agent to
# fetch the grammar files, but couldn't be bothered.
#
my $rsg_grammar_url
  = "http://www-cs-faculty.stanford.edu/~zelenski/rsg/grammars/";

=cut

# load the grammar definition file
my $grammar = do { local $/; <DATA> };

my %grammar = %{parse_grammar($grammar)};
# print Dumper(\%grammar);

my $text = random_text_from_grammar("start");
$text =~ s/(.{50,60}(?<=\s\b))/$1\n/mg;
print "$text\n";

# parse the simple grammar and build a hash table
sub parse_grammar
{
    my $grammar = shift;
    my %grammar = $grammar =~ /^{\s*<([^>]+)>\s*([^}]+)}/mg;

    foreach (keys %grammar) {
        $grammar{$_} = [ map { s/[^\S\n]+/ /g;
                               s/\s([.?,;!])/$1/g;
                               $_ }
                         split /\s*;\s*/, $grammar{$_} ];
    }

    return \%grammar;
}

# generate the text recursively
sub random_text_from_grammar
{
    my $token = shift;
    my $selection = $grammar{$token};
    my $phrase = $selection->[rand ($#$selection+1)];
    $phrase =~ s/<([^>]+)>/random_text_from_grammar($1)/ge;
    return $phrase;
}

__DATA__
[download]

The haiku grammar.
by Garret B. Kaminaga
scorpio@leland.Stanford.EDU

{
<start> 
<5-line> /  <7-line> / <5-line> - <OrientalName>    ;
}

{
<5-line> 
<1> <4>    ;
<1> <3> <1>    ;
<1> <1> <3>    ;
<1> <2> <2>    ;
<1> <2> <1> <1>    ;
<1> <1> <2> <1>    ;
<1> <1> <1> <2>    ;
<1> <1> <1> <1> <1>    ;
<2> <3>    ;
<2> <2> <1>    ;
<2> <1> <2>    ;
<2> <1> <1> <1>    ;
<3> <2>    ;
<3> <1> <1>    ;
<4> <1>    ;
<5>    ;
}

{
<7-line>
<1> <1> <5-line>    ;
<2> <5-line>    ;
<5-line> <1> <1>    ;
<5-line> <2>    ;
}

{
<OrientalName> 
Basho    ;
Hokusai    ;
Makimoto    ;
Toshiba    ;
Matsushida    ;
Yamaha    ;
}

{
<1> 
red    ;
white    ;
black    ;
sky    ;
dawns    ;
breaks    ;
falls    ;
leaf    ;
rain    ;
pool    ;
my    ;
your    ;
sun    ;
clouds    ;
blue    ;
green    ;
night    ;
day    ;
dawn    ;
dusk    ;
birds    ;
fly    ;
grass    ;
tree    ;
branch    ;
through    ;
hell    ;
Ada    ;
Nick    ;
smile    ;
grey    ;
wave    ;
sea    ;
to    ;
through    ;
in    ;
no    ;
sound    ;
mind    ;
smoke    ;
cranes    ;
Zen    ;
}

{
<2> 
drifting    ;
purple    ;
mountains    ;
skyline    ;
city    ;
subway    ;
faces    ;
empty    ;
Buddhist    ;
temple    ;
Japan    ;
ocean    ;
thinking    ;
zooming    ;
rushing    ;
over    ;
rice fields    ;
rising    ;
falling    ;
hard disk    ;
sushi    ;
sparkling    ;
Tokyo    ;
Kyushu    ;
Kyoto    ;
}

{
<3> 
Parlante    ;
sunrises    ;
peasant farms    ;
computer    ;
sashimi    ;
juniper    ;
fishing boats    ;
far away    ;
ethernet    ;
Mac IP    ;
kimonos    ;
samurai    ;
}

{
<4> 
CD Player    ;
Aluminum    ;
yakitori    ;
Mitsukoshi    ;
pampas grass    ;
chrysanthemums    ;
cherry blossoms    ;
}

{
<5> 
resolutional    ;
non-elemental    ;
rolling foothills rise    ;
toward mountains higher    ;
}
[download]

When I ran it, I got some pretty interesting text -

Kyoto smile Nick through / day Kyoto drifting subway /
temple my ocean - Hokusai

rising computer / dusk Mitsukoshi day Nick / hell samurai
tree - Toshiba

wave white Tokyo wave / toward mountains higher empty /
computer faces - Hokusai

Mitsukoshi pool / sushi wave dusk Parlante / white subway
sound birds - Toshiba

Buddhist cranes cranes fly / Kyushu sun rice fields sea
through / temple white thinking - Basho
[download]

Comment on Re: Seeking Perl poetry code that writes poems Select or Download Code

Replies are listed 'Best First'.
Re: Re: Seeking Perl poetry code that writes poems by Roger (Parson) on Dec 04, 2003 at 03:30 UTC
Ok, this is a tribute to the wonderful perlmonks site - a grammar I am working on that describes an event that could/might/had happened at perlmonks. I thought it was quite fun to play with, so I am posting it here. Please feel free to add to the grammar or give suggestions. ;-) The perlmonks grammar: Read more... (4 kB) And when I ran the text generator in the previous post, I got some quite funny results - Thursday this week, some monk encountered an idea on how to do networking and wish to inform other monks at Perlmonks. bad luck no monks gave any response. he was up voted. once upon a time, intermediate monk bumped into a need some pointers using Expect.pm problem. bad luck no monks gave any response. he was down voted because it was too simple. Monday last week, bishop monk encountered a problem on need some pointers using Expect.pm. it stired some responses from monks. she was up voted because it gave a good challenge. ... [download] Have fun. ;-)	[reply] [d/l] [select]

Replies are listed 'Best First'.

Re: Re: Seeking Perl poetry code that writes poems
by Roger (Parson) on Dec 04, 2003 at 03:30 UTC