Coy-0.06/000755 122212 003717 00000000000 07154053740 012576 5ustar00damianstaff000000 000000 Coy-0.06/Changes000755 122212 003717 00000001113 07154053740 014070 0ustar00damianstaff000000 000000 Revision history for Perl extension Coy. 0.01 Sat May 30 15:06:38 1998 - original version; created by h2xs 1.18 0.05 Thu Sep 9 17:39:02 1999 - Added user-configurable vocabulary - Added user-configurable syllable checker - Improved documentation 0.06 Sat Sep 2 12:28:57 2000 - Fixed minor documentation glitch (thanks Elaine) - Fixed a/an on singular nouns (thanks Abigail) - Fixed another minor doc typo (thanks Marcus) - Added RESET sub to allow vocab to be removed within .coyrc (thanks Marcus) - Fixed bug with nesting checker (thanks Soren and Abigail) original version; created by h2xs 1.18 0.05 Thu Sep 9 17:39:02 1999 - Added user-configurable vocabulary - Added user-configurable syllable checker - Improved documentation 0.06 Sat Sep 2 12:28:57 2000 - Fixed minor documentation glitch (thanks Elaine) - Fixed a/an on singular nouns (thanks Abigail) - Fixed another minor doc typo (thanks Marcus) - Added RESET sub to allow vocab to be removed within .coyrc (thCoy-0.06/MANIFEST000755 122212 003717 00000000165 07154053715 013736 0ustar00damianstaff000000 000000 MANIFEST README Changes Makefile.PL lib/Coy.pm lib/Lingua/EN/Hyphenate.pm lib/Lingua/EN/Inflect.pm demo/demo.pl ToDo 0.05 Thu Sep 9 17:39:02 1999 - Added user-configurable vocabulary - Added user-configurable syllable checker - Improved documentation 0.06 Sat Sep 2 12:28:57 2000 - Fixed minor documentation glitch (thanks Elaine) - Fixed a/an on singular nouns (thanks Abigail) - Fixed another minor doc typo (thanks Marcus) - Added RESET sub to allow vocab to be removed wµ„€£°Äoyrc (thCoy-0.06/Makefile.PL000755 122212 003717 00000000131 07154053737 014554 0ustar00damianstaff000000 000000 use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Coy', VERSION => '0.06', ); nflect.pm demo/demo.pl ToDo 0.05 Thu Sep 9 17:39:02 1999 - Added user-configurable vocabulary - Added user-configurable syllable checker - Improved documentation 0.06 Sat Sep 2 12:28:57 2000 - Fixed minor documentation glitch (thanks Elaine) - Fixed a/an on singular nouns (thanks Abigail) - Fixed another minor doc typo (thanks Marcus) - Added RESET sub to allow vocab to be removed wµ„€£°Äoyrc (thCoy-0.06/README000755 122212 003717 00000003374 07154053740 013470 0ustar00damianstaff000000 000000 ============================================================================== Release of version 0.06 of Coy ============================================================================== Error messages strewn across my terminal. A vein starts to throb. Their reproof adds the injury of insult to the shame of failure. When a program dies what you need is a moment of serenity. The Coy.pm module brings tranquillity to your debugging. The module alters the behaviour of C and C (and C and C). It also provides C and C -- two Zen alternatives. Like Carp.pm, Coy reports errors from the caller's point-of-view. But it prefaces the bad news of failure with a soothing haiku. The haiku are not "canned", but are generated freshly every time. Once the haiku is complete, it's prepended to the error message. Execution of the original call to C or C resumes. Haiku and error message strew across my screen. A smile starts to form. ============================================================================== CHANGES IN VERSION 0.06 - Fixed minor documentation glitch (thanks Elaine) - Fixed a/an on singular nouns (thanks Abigail) - Fixed another minor doc typo (thanks Marcus) - Added RESET sub to allow vocab to be removed within .coyrc (thanks Marcus) - Fixed bug with nesting checker (thanks Soren and Abigail) ============================================================================== AVAILABILITY Coy has been uploaded to the CPAN and is also available from: http://www.csse.monash.edu.au/~damian/CPAN/Coy.tar.gz ============================================================================== r nouns (thanks Abigail) - Fixed another minor doc typo (thanks Marcus) - Added RESET sub to allow vocab to be removed within .coyrc (thanks Marcus) - Fixed bug with nesting checker (thanks Soren and Abigail) ========================================Coy-0.06/ToDo000755 122212 003717 00000005155 07051671136 013400 0ustar00damianstaff000000 000000 * Add more vocabulary * Add more grammar rules * General clean and tighten :-) -----------cut-----------cut-----------cut-----------cut-----------cut---------- > * A way to _completely_ disable the built in database, so only .coyrc is used. Can do. Will do. Did do. Will be in the next release. -----------cut-----------cut-----------cut-----------cut-----------cut---------- > * Even better, instead .coyrc, specifying the database inline in the script > that uses Coy. Err, that's tricky, since Coy needs to set things up as it loads. Hmmmm. I suppose you could pass a hash with the inline data to "use Coy": use Coy { noun => { wookie => { category => [ Sentient ], sound => [ "roars", "grunts", "bellows" ], act => { sits => { location => Arborial }, fights => { minimum => 2, association => "argument", }, }, }, }, }; I'll see what I can do. -----------cut-----------cut-----------cut-----------cut-----------cut---------- > * If they are missing (can't tell currently), associations for other > entities beside verbs. Yes, this is needed and not too hard to add. -----------cut-----------cut-----------cut-----------cut-----------cut---------- > * An option to always use the determined article "the" instead "a" with > a noun to stress it. Always? How about randomly sometimes? -----------cut-----------cut-----------cut-----------cut-----------cut---------- > * A way to associate objects with verbs. Currently, Coy produces sentences > like: > would be great. This is especially useful for objects that can't do > much beside lying around (books). I certainly agree. Objects are *high* on the ToDo list. -----------cut-----------cut-----------cut-----------cut-----------cut---------- > * A way to extend the set of locations would also fit in nicely. > Always using terrestrial is a bit boring. I tried to let philosophers > think in trees, but although it leads to humourous haikus, it's a bit > irritating. Yes, this is also on the ToDo list. > * A small sub to extend @aquatic, > so you can add The Big Pond or whatever. (Some seas, etc). Yes, this would be part of allowing new locations (see below). ---cut-----------cut-----------cut-----------cut---------- > * A way to extend the set of locations would also fit in nicely. > Always using terrestrial is a bit boring. I tried to let philosophers > think in trees, but although it leads to humourous haikus, it's a bit > irritating. Yes, this is also on the ToDo list. > * A small sub to extend @aquatic, > so you can add TCoy-0.06/demo/000755 122212 003717 00000000000 07154053740 013522 5ustar00damianstaff000000 000000 Coy-0.06/demo/demo.pl000755 122212 003717 00000000764 06765642056 015030 0ustar00damianstaff000000 000000 #!/usr/local/bin/perl -ws use Coy; @data = map { chomp; $_ } ; print "Let 1000 haiku bloom....\n\n"; for (1..100) { warn $_ foreach @data; } __DATA__ Fatal error - failed to allocate the requested memory. Maybe resize the heap? Missing semicolon. Bad argument No such file: dummy.txt Missing operator near "while" Can't open input file Syntax error near line 4 Connection timed out - aborting Too many arguments to subroutine &print. Can't generate new lines to match regular expression. Ârµ„€@b„Coy-0.06/lib/000755 122212 003717 00000000000 07154053740 013344 5ustar00damianstaff000000 000000 Coy-0.06/lib/Coy.pm000755 122212 003717 00000055506 07154053740 014452 0ustar00damianstaff000000 000000 package Coy; $VERSION = '0.06'; BEGIN { require Exporter; @ISA = ('Exporter'); @EXPORT = qw(transcend enlighten); my $USER_CONFIG_FILE = "$ENV{HOME}/.coyrc"; use Carp (); sub transcend { &Carp::croak } sub enlighten { &Carp::carp } # THE REAL WORK STARTS HERE use Lingua::EN::Inflect qw(PL_N PL_V NO inflect NUM A PART_PRES NUMWORDS); use Lingua::EN::Hyphenate; sub random { for (1..100) { my $choice = $_[int rand @_]; my $selection = (ref($choice) eq 'CODE') ? $choice->() : $choice; return $selection if defined $selection; } die "couldn't randomize: " . join(", ", @_) . "at " . (caller)[2]; } sub syl_count { my $count = 0; my $word; foreach $word (split / /, $_[0]) { $word =~ /^\d+$/ and $word = NUMWORDS($word); my @syllables = syllables($word); $count += @syllables; } return $count; } # Personages @Coy::personage = ( "The Jade Emperor", "Master Po", "Mumon", "The Seventh Sage", "the Master", "Alan Watts", "Tor Kin Tun", "Tom See", "Or Wunt", "Homer Simpson", "Lao Tse", "The Buddha", "Gautama", "Swordmaster Mushashi", "Con Wei", "Joshu", "Bankei", "Ryokan", "Ryonen", "Eshun", ); # EXCLAMATIONS my @exclamation = ( 'Oh!', 'See!', ' Look!' ); # LOCATIONS my @aquatic = qw( pond river pool dam stream lake ); sub Aquatic::atRandom { random "in the " . random(@aquatic), "in " . A(random @aquatic) ; } sub Exoaquatic::atRandom { random "out of the " . random(@aquatic), "from " . A(random @aquatic) ; } sub Suraquatic::atRandom { random "on the " . random(@aquatic), "on " . A(random @aquatic) ; } sub Aerial::atRandom { random "over the " . random(@aquatic), "above the " . random(@aquatic), "over " . random(@Coy::place), "above " . random(@Coy::place), "near " . random(@Coy::place) } sub Arborial::atRandom { random "in " . A(random @Coy::tree), "in the branches of " . A(random @Coy::tree), "in " . A(random @Coy::tree, @Coy::fruit_tree) . " tree", "in the branches of " . A(random @Coy::tree, @Coy::fruit_tree) . " tree"; } sub Terrestrial::atRandom { random "under " . A(random @Coy::tree) . random(" tree", ""), "near " . random(@Coy::place), "beside " . A(random @aquatic); } # DIRECTIONS my @horizontalNS = qw( north south ); my @horizontalEW = qw( east west ); my @vertical = qw( up upwards down downwards ); my @general_dir = qw( away ); my @to_dir_prep = ( "towards" ); my @from_dir_prep = ( "away from", ); sub Horizontal::atRandom { my $compass = random @horizontalNS, @horizontalEW, random(@horizontalNS).'-'.random(@horizontalEW) ; return random ($compass x 8, @general_dir), random(@to_dir_prep)." the ".$compass, random(@to_dir_prep, @from_dir_prep)." ".random(@Coy::place); } sub Any::atRandom { my $compass = random @horizontalNS, @horizontalEW, random(@horizontalNS).'-'.random(@horizontalEW) ; return random $compass, @general_dir, random(@to_dir_prep)." the ".$compass, random(@to_dir_prep, @from_dir_prep)." ".random(@Coy::place); @vertical; } # DATABASE $Coy::agent = {}; $Coy::agent_categories = {}; @Coy::nouns = (); $Coy::associations = ""; my $nonassoc = 0; sub RESET { '__RESET__' } sub tree { if ($_[0] eq '__RESET__') { @Coy::tree = () } else { push @Coy::tree, @_; } 1; } sub fruit_tree { if ($_[0] eq '__RESET__') { @Coy::fruit_tree = () } else { push @Coy::fruit_tree, @_; } 1; } sub place { if ($_[0] eq '__RESET__') { @Coy::place = () } else { push @Coy::place, @_; } 1; } sub personage { if ($_[0] eq '__RESET__') { @Coy::personage = () } else { push @Coy::personage, @_; } 1; } sub noun { my $hashref = shift; if (!ref($hashref) && $hashref eq '__RESET__') { $Coy::agent = {} } else { Carp::croak "Usage: noun " unless ref($hashref) eq 'HASH'; $Coy::agent = { %$Coy::agent, %$hashref }; } 1; } sub categories { my $hashref = shift; if (!ref($hashref) && $hashref eq '__RESET__') { $Coy::agent_categories = {} } else { Carp::croak "Usage: categories " unless ref($hashref) eq 'HASH'; $Coy::agent_categories = { %$Coy::agent_categories, %$hashref }; } 1; } sub syllable_counter { my $sub = shift; $sub = \&$sub unless ref $sub; no strict; undef &syllables; local $SIG{__WARN__} = sub {}; *syllables = $sub; } my @count_prob = ((0)x1,(1)x90,(2)x40,(3..5)x2,(6..12)x1); sub get_Noun_Verb { my ($count, $sound, $noun_only) = @_; my ($noun, $verb, $min, $max); my $tries = 0; $nonassoc = 0; while (++$tries) { $noun = random @Coy::nouns; return $noun if $noun_only; my @verbs = keys %{$Coy::agent->{$noun}{act}}; # print STDERR "noun = $noun\n"; # print STDERR "verbs = @verbs\n"; push @verbs, @{$Coy::agent->{$noun}{sound}} if $sound && $Coy::agent->{$noun}{sound}; $verb = random @verbs; # print STDERR "[trying $noun/$verb for $count"; # print STDERR " (non-assoc)" if $nonassoc; # print STDERR "]\n"; if ($tries>20) { $nonassoc = 1 } if ($Coy::associations && !$nonassoc) { my $assoc = $Coy::agent->{$noun}{act}{$verb}{associations}||""; # print "$noun/$verb: [$assoc]->[$Coy::associations]\n"; next unless $assoc && ($assoc =~ /$Coy::associations/i); # print "[$assoc]\n"; } if ($tries>50) { $_[0] = $Coy::agent->{$noun}{act}{$verb}{minimum} || $Coy::agent->{$noun}{minimum}; last; } $min = $Coy::agent->{$noun}{act}{$verb}{minimum}; $min = $Coy::agent->{$noun}{minimum} if !defined ($min) || defined($Coy::agent->{$noun}{minimum}) && $min < $Coy::agent->{$noun}{minimum}; $max = $Coy::agent->{$noun}{act}{$verb}{maximum}; $max = $Coy::agent->{$noun}{maximum} if !defined ($max) || defined($Coy::agent->{$noun}{maximum}) && $max > $Coy::agent->{$noun}{maximum}; # print STDERR "trying $noun/$verb [$min<=$count<=$max]\n"; last unless (defined($min) && $count < $min || defined($max) && $count > $max); } # print STDERR "[accepted $noun/$verb]\n"; return ($noun, $verb, PART_PRES($verb), $Coy::agent->{$noun}{act}{$verb}{non_adjectival}); } sub Noun { my $count = random @count_prob; my ($noun,@verb) = get_Noun_Verb($count,'SOUND','NOUN_ONLY'); return $noun if $Coy::agent->{$noun}{personage};; return inflect "NO($noun,$count)"; } sub Noun_Verb { my $count = random @count_prob; my ($noun,@verb) = get_Noun_Verb($count,'SOUND'); my $verb = random @verb[0..1]; return inflect "$noun PL_V($verb,$count)" if $Coy::agent->{$noun}{personage}; return inflect "NO($noun,$count) PL_V($verb,$count)"; } sub Participle_Noun { my $count = random @count_prob; my ($noun,$verb,$participle,$non_adjectival) = get_Noun_Verb($count,'SOUND'); return if $non_adjectival or $Coy::agent->{$noun}{personage}; return inflect "NO($participle $noun,$count)"; } sub Noun_Location { my $count = random @count_prob; my ($noun,@verb) = get_Noun_Verb($count,'NOUN_ONLY'); my $verb = random @verb[0..1]; return undef unless $Coy::agent->{$noun}{act}{$verb[0]}{location}; my $location = $Coy::agent->{$noun}{act}{$verb[0]}{location}->atRandom(); return inflect "$noun $location" if $Coy::agent->{$noun}{personage}; return inflect "NO($noun,$count) $location"; } sub Noun_Verb_Location { my $count = random @count_prob; my ($noun,@verb) = get_Noun_Verb($count); my $verb = random @verb[0..1]; return undef unless $Coy::agent->{$noun}{act}{$verb[0]}{location}; my $location = $Coy::agent->{$noun}{act}{$verb[0]}{location}->atRandom(); return inflect "$noun PL_V($verb,$count) $location" if $Coy::agent->{$noun}{personage}; return inflect "NO($noun,$count) PL_V($verb,$count) $location"; } sub Noun_Verb_Direction { my $count = random @count_prob; my ($noun,@verb) = get_Noun_Verb($count); my $verb = random @verb[0..1]; return undef unless $Coy::agent->{$noun}{act}{$verb[0]}{direction}; my $direction = $Coy::agent->{$noun}{act}{$verb[0]}{direction}->atRandom(); return inflect "$noun PL_V($verb,$count) $direction" if $Coy::agent->{$noun}{personage}; return inflect "NO($noun,$count) PL_V($verb,$count) $direction"; } sub expand_synonyms { foreach my $noun ( @Coy::nouns ) { my %act = %{$Coy::agent->{$noun}{act}}; foreach my $verb ( keys %act ) { if (exists $act{$verb}{synonyms}) { foreach my $syn ( @{$act{$verb}{synonyms}} ) { $Coy::agent->{$noun}{act}{$syn} = $act{$verb}; } } } } } sub expand_categories { foreach my $noun ( @Coy::nouns ) { my $categories = $Coy::agent->{$noun}{category} or next; my %generic_acts = (); foreach my $category ( @$categories ) { next unless $Coy::agent_categories->{$category}; %generic_acts = ( %{$Coy::agent_categories->{$category}{act}||{}}, %generic_acts ); } # print STDERR "expanding $noun with", keys(%generic_acts), "\n"; %{$Coy::agent->{$noun}{act}} = ( %generic_acts, %{$Coy::agent->{$noun}{act}||{}} ); } foreach my $noun ( @Coy::personage ) { push @Coy::nouns, $noun; $Coy::agent->{$noun}{category} = [ "Human" ]; $Coy::agent->{$noun}{maximum} = 1; $Coy::agent->{$noun}{minimum} = 1; $Coy::agent->{$noun}{personage} = 1; $Coy::agent->{$noun}{act} = $Coy::agent_categories->{Human}{act}||{}; } } sub Generate { local $_ = random ( (sub { Noun }) x 1, (sub { Noun_Location }) x 6, (sub { Noun_Verb }) x 3, (sub { Noun_Verb_Direction }) x 13, (sub { Noun_Verb_Location }) x 13, (sub { Participle_Noun }) x 5, ); ; s/^1\s+(\S+)/A($1)/e; s/^2(?= )/random "a pair of", "two"/e; s/^(\d+)(?= )/NUMWORDS($1)/e; $Coy::associations = "" unless $nonassoc; return ucfirst $_; } sub Generate_Sized { my ($size) = @_; my $fulltext = ""; my $fullcount = 0; while ($fullcount != $size) { my $text = Generate; my $count = $fullcount + syl_count($text); if ($count < $size-1 || $count == $size) { $fulltext .= ($fulltext?". ":"").$text; $fullcount = $count; } } return $fulltext; } use Text::Wrap; sub with_haiku { my $message = join("",@_); my $file = "Mysterious Compiler"; my $line = "???"; if ($message =~ s/(.*)at\s(\S+)\sline\s(\d+.*?)\s*\Z/$1/s) { $file = $2||$file; $line = $3||$line; } elsif ($message =~ s/(.*)File\s'([^']+)';\s+Line\s+(\d+.*)/$1/s) { $file = $2||$file; $line = $3||$line; chomp $line; $file =~ s/^.*://; } associate($message); my @words = (); foreach my $word (split /\s+/, Generate_Sized(17)) { push @words, [$word, syl_count($word)]; } my $haiku = ""; my $count = 0; while ($count<5) { my $word = shift @words; $haiku .= "$word->[0] "; $count+=$word->[1]; } $haiku .= "\n\t"; while ($count<12) { my $word = shift @words; $haiku .= "$word->[0] "; $count+=$word->[1]; } $haiku .= "\n\t"; $haiku .= join(" ",map {$_->[0]} @words) . "."; $message = wrap("\t\t","\t\t",$message); $message =~ s/\t\t//; my @book = ('Analects of %s', 'Sayings of %s', 'The Wisdom of %s', '"%s Speaks"', '"The Way of %s"', ); my $book = sprintf(random(@book),$file); $where = wrap("\t\t\t","\t\t\t ","($book: line $line)"); $where =~ s/\t\t\t//; my $personage = ucfirst random @Coy::personage; return < { category => [ Bird ], act => { swims => { location => Suraquatic, direction => Horizontal, }, }, sound => [ "quacks", ] }, swallow => { category => [ Bird ], act => { swoops => { location => Aerial, } }, }, raven => { category => [ Bird ] }, thrush => { category => [ Bird ], sound => [ "sings" ]}, songbird => { category => [ Bird ], sound => [ "sings" ]}, lark => { category => [ Bird ], sound => [ "sings" ]}, gannet => { category => [ Bird ] }, dove => { category => [ Bird ], sound => [ "coos" ] }, kingfisher => { category => [ Bird ] }, woodpecker => { category => [ Bird ] }, 'carp' => { category => [ Fish ] }, goldfish => { category => [ Fish ] }, salmon => { category => [ Fish, Leaper ] }, pike => { category => [ Fish, Leaper ] }, trout => { category => [ Fish, Leaper ] }, fox => { category => [ Animal, Hunter ], sound => [ "barks" ], act => { trots => { location => Terrestrial }, }, }, bear => { category => [ Animal ], sound => [ "howls" ], act => { fishes => { location => Aquatic }, }, }, wolf => { category => [ Animal, Hunter ], sound => [ "howls" ], }, cat => { category => [ Animal, Hunter ], sound => [ "purrs", "yowls" ], act => { washes => { location => Terrestrial }, sits => { location => Terrestrial }, }, }, rabbit => { category => [ Animal ], act => { sniffs => { location => Terrestrial }, grazes => { location => Terrestrial }, }, }, "young girl" => { category => [ Human ], act => { skips => { location => Terrestrial, non_adjectival => 1, } }, }, "old man" => { category => [ Human ], act => { swims => { location => Aquatic, non_adjectival => 1, } }, }, lover => { category => [ Human ], minimum => 2, maximum => 2, act => { kisses => { location => Terrestrial, }, cuddles => { location => Terrestrial, }, touch => { location => Terrestrial, }, whisper => { location => Terrestrial, }, dance => { location => Terrestrial, }, }, }, }; categories { Human => { act => { dies => { associations => "die depart exit", location => Terrestrial, }, quarrels => { associations => "argument", location => Terrestrial, minimum => 2, synonyms => [qw(bickers argues banters fights)], }, contends => { associations => "argument", location => Terrestrial, minimum => 2, synonyms => [qw(debates)], non_adjectival => 1, }, sits => { associations => "rest static stop", location => Terrestrial, non_adjectival => 1, }, meets => { associations => "join together", location => Terrestrial, minimum => 2, non_adjectival => 1, synonyms => [qw(encounters)], }, laughs => { associations => "happy", location => Terrestrial, non_adjectival => 1, }, parts => { associations => "leave left miss", location => Terrestrial, minimum => 2, }, departs => { associations => "leave left miss", location => Terrestrial, }, weeps => { associations => "NEG", location => Terrestrial, }, sighs => { associations => "NEG", location => Terrestrial, }, embraces => { associations => "join together with", location => Terrestrial, minimum => 2, maximum => 2, }, }, }, Animal => { act => { sits => { associations => "static", location => Terrestrial, }, walks => { associations => "gone", location => Terrestrial, non_adjectival => 1, }, watches => { associations => "see", location => Terrestrial, non_adjectival => 1, }, waits => { associations => "wait", location => Terrestrial, non_adjectival => 1, }, eats => { associations => 'eat consume use', location => Terrestrial, non_adjectival => 1, } }, }, Hunter => { act => { crouches => { location => Terrestrial }, prowls => { location => Terrestrial }, stalks => { location => Terrestrial }, leaps => { location => Terrestrial }, }, }, Fish => { act => { darts => { location => Aquatic, }, swims => { location => Aquatic, non_adjectival => 1, }, }, }, Leaper => { act => { leaps => { location => Exoaquatic } }, }, Bird => { act => { flies => { location => Aerial, direction => Any, }, nests => { location => Arborial, }, }, }, }; tree qw( oak elm willow maple she-oak ); fruit_tree qw( cherry apple lemon ); place ( "Mount Fuji", "a temple", "the Emperor's palace", "a dojo", "the Shaolin temple", "a farmer's cottage", "the village", "the town square", "the harbor", "Bill Clinton's office", "a monastry", "the market-place", ); # LOAD USER-DEFINED DATA if (-f $USER_CONFIG_FILE) { no strict; do $USER_CONFIG_FILE; } @Coy::nouns = keys %$Coy::agent; expand_categories; expand_synonyms; # print STDERR "Nouns: ", scalar @Coy::nouns, "\n"; } # AND FINALLY, INSTALL IT ALL... my $nested = -1; $SIG{__WARN__} = sub { local $SIG{__WARN__}; $nested++; warn with_haiku(@_) unless $nested; warn @_ if $nested; $nested--; }; $SIG{__DIE__} = sub { local $SIG{__DIE__}; $nested++; die with_haiku(@_) unless $nested; die @_ if $nested; $nested--; }; 1; __END__ =head1 NAME Coy - like Carp only prettier =head1 SYNOPSIS # In your application: # ==================== use Coy; warn "There seems to be a problem"; die "Looks like it might be fatal"; # You can add vocab in the $HOME/.coyrc file: # =========================================== noun RESET; # REMOVE EXISTING noun VOCAB # WORKS FOR OTHER SPECIFIERS TOO noun { wookie => { category => [ Sentient ], sound => [ "roars", "grunts", "bellows" ], act => { sits => { location => Arborial }, fights => { minimum => 2, association => "argument", }, }, }, }; category { Sentient => { act => { quarrels => { associations => "argument", location => Terrestrial, minimum => 2, synonyms => [qw(bickers argues)], }, laughs => { associations => "happy", location => Terrestrial, non_adjectival => 1, }, }, } }; personage "R2D2"; personage "Darth Vader"; place "Mos Eisley"; place "the Death Star"; tree "Alderaan mangrove"; fruit_tree "Wookie-oak"; # You can also select a different syllable counter via .coyrc # =========================================================== use Lingua::EN::Syllables::syllable; syllable_counter "Lingua::EN::Syllables::syllable"; # or use Lingua::EN::Syllables::syllable; syllable_counter \&Lingua::EN::Syllables::syllable; # or syllable_counter sub { return 1 }; # FAST BUT INACCURATE =head1 DESCRIPTION Error messages strewn across my terminal. A vein starts to throb. Their reproof adds the injury of insult to the shame of failure. When a program dies what you need is a moment of serenity. The Coy.pm module brings tranquillity to your debugging. The module alters the behaviour of C and C (and C and C). It also provides C and C -- two Zen alternatives. Like Carp.pm, Coy reports errors from the caller's point-of-view. But it prefaces the bad news of failure with a soothing haiku. The haiku are not "canned", but are generated freshly every time. Once the haiku is complete, it's prepended to the error message. Execution of the original call to C or C resumes. Haiku and error message strew across my screen. A smile starts to form. =head1 EXTENDING THE VOCABULARY Any code placed in "$ENV{HOME}/.coyrc" runs at compile-time. You can use that file to extend Coy.pm's vocabulary. The "SYNOPSIS" at the start of this POD shows how you might set it up. (Eventually this section will detail the full mechanism.) =head1 CHANGING THE SYLLABLE COUNTER Real haiku often
have imperfect syllable
counts. The deficiencies of
Coy's inbuilt counter are thus
artistic virtues. But some connoisseurs
demand their syllable counts
be always exact. So if you don't like
the syllable counter, Coy
let's you replace it. Coy provides a sub called C for that very purpose. It is passed a sub reference. That sub is then used to count syllables. You can also pass the sub's I (that is, pass a symbolic reference). The new counter sub should take a string and return its syllable count. C can be called from your code, or from .coyrc. =head1 BUGS AND LIMITATIONS In its current form, the module has four problems and limitations: * Vocabulary: The list of nouns and verbs is too small at present. This limits the range of topics that the haiku produced can cover. That in turn leads to tell-tale repetition (which fails the Turing test). Extending the range of words Coy.pm can use is no problem (though finding the time and the creativity required may be :-). Users of Coy are encouraged to add their own vocabulary. (See the "SYNOPSIS", and also "EXTENDING THE VOCABULARY"). * Associations: The vocabulary has too few topic links. Hence it's often not able to find relevant words for a message. This leads to haiku utterly unrelated to the error text. Again, there is no technical difficulty in adding more links: Defining enough associations isn't hard, just tedious. User-specified vocabularies can solve this problem as well. * Limited grammar: The number of syntactic templates is too small. This leads to haiku that are (structurally, at least) monotonous. Yet again, this needs no technical solution, just time and effort. Of course, such enhanced templates might require richer vocabulary. For example, verb predicates would need extra database structure: Each verb entry would have to be extended with links to object nouns. * Syllable counting: This is perhaps the major problem at present. The algorithmic syllable counter is still being developed. It is currently around 96% accurate (per word). This means that correct syllable counts for haiku can't be guaranteed. Syllable counts for single words are correct to plus-or-minus 1. In a multi-word haiku these errors cancel out in most cases. Thus, the haiku tend to be correct within one or two syllables. As the syllable counter slowly improves, this problem will abate. Alteratively, you can choose to use your own syllable counter. (See above in the section titled "CHANGING THE SYLLABLE COUNTER".) =head1 AUTHOR The Coy.pm module was developed by Damian Conway. =head1 COPYRIGHT Copyright (c) 1998-2000, Damian Conway. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the terms of the Perl Artistic License (see http://www.perl.com/perl/misc/Artistic.html) =cut Alteratively, you can choose to use your own syllable counter. (See above in the section titled "CHANGING THE SYLLABLE COUNTER".) =head1 AUTHOR The Coy.pm modulCoy-0.06/lib/Lingua/000755 122212 003717 00000000000 07154053740 014563 5ustar00damianstaff000000 000000 Coy-0.06/lib/Lingua/EN/000755 122212 003717 00000000000 07154053740 015065 5ustar00damianstaff000000 000000 Coy-0.06/lib/Lingua/EN/Hyphenate.pm000755 122212 003717 00000025245 07154053731 017363 0ustar00damianstaff000000 000000 package Lingua::EN::Hyphenate; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw( hyphenate syllables def_syl def_hyph ); $VERSION = '0.01'; sub debug { print @_ if $::debug } my @diphthong = qw { ao ia io ii iu oe uo ue }; my @diphthong1 = map { substr($_,0,1)."(?=".substr($_,1,1).")" } @diphthong; my $diphthong = "(" . join('|', @diphthong1) . ")(.)"; my $vowels = '(?:[aeiou]+y?|y)'; my $precons = '( str |sch |sph |squ |thr |b[r] |d[rw] |f[lr] |g[nr] |k[n] |p[nr] |r[h] |s[lmnw] |t[w] |qu )'; my $ppcons1 = '( b[l] |c[hlr] |g[hl] |m[n] |p[l] |t[h](?!r) |s[chpt](?!r) |s[k] |tr )'; my $ppcons2 = '((?=[a-z])[^aeiouy])'; my $postcons = '( ght |nst |rst |tch |rth |bb |c[ckt] |d[dlz] |f[ft] |g[gt] |l[bcdfgklmnptv] |m[mp] |n[cdgknstx] |pp |r[bcdfgklmnprtv] |ss |t[tz] |vv |wn |x[tx] )'; my @paircons = qw { ph tl n't }; my $paircons = "(" . join('|', @paircons) . ")"; my @dblcons = qw { c~tr n~th n~c[th] n~s[th] ns~d l~pr s~tl n~c n~s c~t r~t }; my @dblcons1 = map { /(.+)~(.+)/; "$1(?=$2)" } @dblcons; my @dblcons2 = map { /(.+)~(.+)/; "$2" } @dblcons; my $dblcons = "(" . join('|', @dblcons1) . ")(" . join('|', @dblcons2) . ")"; my @repcons = map { "$_(?=$_)" } qw { b c g h j k m n p q r t v w x z }; my $repcons = "(" . join('|', @repcons) . ")"; my $pprecons = "($ppcons1|$precons|$ppcons2)"; my $ppostcons = "($ppcons1|$postcons|$ppcons2)"; sub abstract { no strict; sub C_ { debug "C_($_[0])\n"; return { type => 'C_', val => $_[0] } } sub _C { debug "_C($_[0])\n"; return { type => '_C', val => $_[0] } } sub _S { debug "_S($_[0])\n"; return { type => '_S', val => $_[0] } } sub _C_ { debug "_C_($_[0])\n"; return { type => '_C_', val => $_[0] } } sub V { debug "V($_[0])\n"; return { type => 'V', val => $_[0] } } sub E { debug "E($_[0])\n"; return { type => 'E', val => $_[0] } } local $_ = shift; local @head = (); sub app { push @head, @_ if defined $_[0]; '' } local @tail = (); sub prep { unshift @tail, @_ if defined $_[0]; '' } #debug "\A${pprecons}${diphthong}${postcons}\Z\n"; s/\A${pprecons}${diphthong}${ppostcons}\Z/app C_($1),V("$5$6"),_C($7)/eix; s/\Ay/app C_("y")/ei or s/\Aex/app V("e"),_C("x")/ei or s/\Ai([nmg])/app V("i"),_C($1)/ei or s/\A([eu])([nm])/app V($1),_C($2)/ei or s/\Airr/app V("i"),_C("r"),C_("r")/ei or s/\Aill/app V("i"),_C("l"),C_("l")/ei or s/\Acon/app C_("c"), V("o"), _C("n")/ei or s/\Aant([ie])/app V("a"),_C("n"),C_("t"),V($1),_C('')/ei or s/\A(w[hr])/app C_("$1")/ei or s/\Amay/app C_("m"), V("a"), _C("y")/ei ; s/([bd])le\Z/prep C_($1), V(''), _C("le")/ei or s/sm\Z/prep C_("s"), V(''), _C("m")/ei or s/${repcons}\1e\Z/do{prep _C("$1$1e")}/eix or s/(?=..e)${dblcons}e\Z/do{prep _C("$1$2e")}/eix or s/(${vowels})${ppcons2}es\Z/do{prep _C("$2es");$1}/eix or s/(${vowels})(ples?)\Z/do{prep C_($2);$1}/eix or s/([td])ed\Z/prep C_($1),V("e"), _C("d")/eix or s/([^aeiou])\1ed\Z/prep _C("$1$1ed")/eix or s/${pprecons}ed\Z/prep _C("$1ed")/eix or s/${ppostcons}ed\Z/prep _C("$1ed")/eix or s/([aeou])ic(s?)\Z/prep V($1), V("i"),_C("c$2")/ei or s/([sct])ion(s?)\Z/prep _C_($1),V("io"),_C("n$2")/ei or s/([cts])ia([nl]s?)\Z/prep _C_($1),V("ia"),_C($2)/ei or s/([ts])ia(s?)\Z/prep _C_($1),V("ia$2")/ei or s/t(i?ou)s\Z/prep _C_("t"),V($1),_C("s")/ei or s/cious\Z/prep _C_("c"),V("iou"),_C("s")/ei or s/${ppostcons}(e?s)\Z/prep _C("$1$5")/eix ; 1 while s/${dblcons}\Z/do{prep _C("$1$2")}/eix; while (/[a-z]/i) { debug "=====[$_]=====\n"; s/\A(s'|'s)\Z/app _S($1)/eix and next; s/\A${dblcons}/app _C($1),C_($2)/eix and next; s/\A${dblcons}/app _C($1),C_($2)/eix and next; s/\A${repcons}/app _C($1)/eix and next; s/\A${paircons}/app _C($1)/eix and next; s/\A${ppcons1}e(?![aeiouy])/app _C_($1),E("e")/eix and next; s/\A${precons}e(?![aeiouy])/app C_($1),E("e")/eix and next; s/\A${postcons}e(?![aeiouy])/app _C($1),E("e")/eix and next; s/\A${ppcons2}e(?![aeiouy])/app _C_($1),E("e")/eix and next; s/\A${postcons}?([sct])ion/app C_(($1||'').$2),V("io"),_C("n")/eix and next; s/\A${postcons}?tial/app C_(($1||'')."t"),V("ia"),_C("l")/eix and next; s/\A${postcons}?([ct])ia([nl])/app C_(($1||'').$2),V("ia"),_C($3)/eix and next; s/\A${postcons}?t(i?ou)s/app C_(($1||'')."t"),V($1),_C("s")/eix and next; s/\Aience/app V("i"),V("e"),_C("nc"),E('e')/eix and next; s/\Acious/app C_(($1||'')."c"),V("iou"),_C("s")/eix and next; s/\A$diphthong/app V($1),V($2)/ei and next; s/\A$ppcons1/app _C_($1)/eix and next; s/\A$precons/app C_($1)/eix and next; s/\A$postcons/app _C($1)/eix and next; s/\A$ppcons2/app _C_($1)/eix and next; s/\A($vowels)/app V($1)/ei and next; } return (@head, @tail); } sub partition { no strict; local @list = @_; local @syls = (); sub is_S { @list > 1 && $list[$#list]->{val} =~ /'?s'?/ } sub isR { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type}=~'C' && $list[$i]->{val} eq 'r' } sub isC { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type}=~'C' } sub is_C { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type}=~'_C' } sub isC_ { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type}=~'C_' } sub isV { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type}=~/V|E/ } sub isVnE { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type} eq 'V' && $list[$i]->{val} !~ /\Ae/ } sub isE { my $i = $#list+$_[0]; $i >= 0 && $list[$i]->{type} eq 'E' } sub syl { my $syl = ""; for (1..$_[0]) { $syl = pop(@list)->{val}.$syl } unshift @syls, $syl; 1} is_S(0) && do { my $val = pop @list; $list[$#list]->{val} .= $val->{val} }; while (@list) { print "\t[@syls]\n" if $::debug; isE(-2) && isR(-1) && isVnE(0) && syl(1) && next; isC(-1) && is_C(0) && syl(1) && next; isC_(-3) && isV(-2) && isC(-1) && isE(0) && syl(4) && next; isC_(-2) && isV(-1) && is_C(0) && syl(3) && next; isV(-2) && isC(-1) && isE(0) && syl(3) && next; isC_(-1) && isV(0) && syl(2) && next; isV(-1) && is_C(0) && syl(2) && next; isC(0) && syl(1) && next; isV(0) && syl(1) && next; } return @syls; } my %user_def_syl = (); my %user_def_hyph = (); sub def_syl($) { my $word = $_[0]; $word =~ tr/~//d; $user_def_syl{$word} = [split /\~/, $_[0]]; } sub def_hyph($) { my $word = $_[0]; $word =~ tr/~//d; $user_def_hyph{$word} = [split /\~/, $_[0]]; } sub syllables($) # ($word) { return ($_[0]) unless $_[0] =~ /[A-Za-z]/; my $word = $_[0]; $word =~ s/\A([^a-zA-Z]+)//; my $leader = $1||''; $word =~ s/([^a-zA-Z]+)\Z//; my $trailer = $1||''; my @syls = @{$user_def_syl{$word}||[]}; unless (@syls) { my @part = split /((?:\s|'(?![ts]\b)|'[^A-Za-z]|[^A-Za-z'])+)/, $word; for (my $p = 0; $p < @part; $p++) { if ($p & 1) { $syls[$#syls] .= $part[$p] } else { push @syls, partition(abstract($part[$p])) } } } $syls[0] = $leader . $syls[0]; $syls[$#syls] .= $trailer; return @syls if wantarray; return join '~', @syls; } sub hyphenate($$;$) # ($word, $width; $hyphen) { my $word = shift; my @syls = @{$user_def_hyph{$word}||[]}; @syls = syllables($word) unless @syls; my ($width, $hyphen) = (@_,'-'); my $hlen = length $hyphen; my $first = ''; while (@syls) { if ($#syls) { last if length($first) + length($syls[0]) + $hlen > $width } else { last if length($first) + length($syls[0]) > $width } $first .= shift @syls; } $first .= $hyphen if $first && @syls && $first !~ /$hyphen\Z/; return ("$first",join '',@syls); } 1; __END__ =head1 NAME Lingua::EN::Hyphenate - Perl extension for syllable-based hyphenation =head1 SYNOPSIS use Lingua::EN::Hyphenate qw( hyphenate syllables def_syl def_hyph ); my $word = 'intromission'; my $syllables = syllables($word); # 'in~tro~mis~sion' my @syllables = syllables($word); # ('in','tro','mis','sion') ($end_of_line_1, $start_of_line_2) # ('intro-','mission') = hyphenate($word, 6); # Break word at or before 6th char ($end_of_line_1, $start_of_line_2) # ('intromis-','sion') = hyphenate($word, 8); # Break word at or before 8th char my $hyphen = '...'; ($end_of_line_1, $start_of_line_2) # ('intro...','mission') = hyphenate($word, 8, $hyphen); # Use specified hyphen (not '-') def_syl('here~say'); # Where the syllables are def_syl('he~re~sy'); # Where the syllables are def_hyph('here~say'); # Where the word may be broken def_hyph('her~esy'); # Where the word may be broken =head1 DESCRIPTION The exportable subroutines of Lingua::EN::Hyphenate provide a mechanism to break words into syllables, to hyphenate words at syllable boundaries, and to redefine the syllables or hyphenation of specific words. =head2 syllables This subroutine takes a single string argument and breaks it into syllables. In a scalar context it returns a string with the syllables separated by '~' characters. In a list context it returns a list of the syllables. =head2 hyphenate This subroutine takes a word to be broken, and an integer indicating the maximum number of characters allowed before the break. An optional third argument specifies the hyphenation marker ('-' by default). The subroutine returns a list of two elements: the characters before the break (including the hyphenation marker), and the rest of the word. The first element is guaranteed to be no longer than the length specified by the second argument. =head2 def_syl and def_hyph These subroutines specify a specific syllablic decomposition or hyphenation pattern (respectively) to be used for the specified word. The syllables or hyphenation fragments are separated by '~' characters. See the examples above. =head1 AUTHOR Damian Conway (damian@conway.org) =head1 BUGS AND IRRITATIONS The syllable extraction is algorithmic, not table-driven. That means the module is very short, but also that it can be *very* inaccurate. It's okay for haiku, but shouldn't be used for serious work. Consider Lingua::EN::Syllable or TeX::Hyphen instead. There are undoubtedly serious bugs lurking somewhere in this code, if only because it gives the impression of understanding a great deal more about English than it actually does. Bug reports and other feedback are most welcome. =head1 COPYRIGHT Copyright (c) 1997-2000, Damian Conway. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the terms of the Perl Artistic License (see http://www.perl.com/perl/misc/Artistic.html) =cut :Hyphen instead. There are undoubtedly serious bugs lurking somewhere in this code, if only because it gives the impression of understanding a great deal more about English than it actually does. Bug reports and other feedback are most welcome. =head1 COPYRIGHT Copyright (c) 1997-2000, Damian Conway. All Rights Reserved. This module is frCoy-0.06/lib/Lingua/EN/Inflect.pm000755 122212 003717 00000073401 07154053732 017020 0ustar00damianstaff000000 000000 package Lingua::EN::Inflect; use strict; use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @ISA); use Env; require Exporter; @ISA = qw(Exporter); $VERSION = '1.86'; %EXPORT_TAGS = ( ALL => [ qw( classical inflect PL PL_N PL_V PL_ADJ NO NUM A AN PL_eq PL_N_eq PL_V_eq PL_ADJ_eq PART_PRES ORD NUMWORDS def_noun def_verb def_adj def_a def_an )], INFLECTIONS => [ qw( classical inflect PL PL_N PL_V PL_ADJ PL_eq NO NUM A AN PART_PRES )], PLURALS => [ qw( classical inflect PL PL_N PL_V PL_ADJ NO NUM PL_eq PL_N_eq PL_V_eq PL_ADJ_eq )], COMPARISONS => [ qw( classical PL_eq PL_N_eq PL_V_eq PL_ADJ_eq )], ARTICLES => [ qw( classical inflect NUM A AN )], NUMERICAL => [ qw( ORD NUMWORDS )], USER_DEFINED => [ qw( def_noun def_verb def_adj def_a def_an )], ); Exporter::export_ok_tags(qw( ALL )); # SUPPORT CLASSICAL PLURALIZATIONS my $classical = 0; sub classical { $classical = (!@_ || $_[0]); } my $persistent_count; sub NUM # (;$count,$show) { if (defined $_[0]) { $persistent_count = $_[0]; return $_[0] if !defined($_[1]) || $_[1]; } else { $persistent_count = undef; } return ''; } # 0. PERFORM GENERAL INFLECTIONS IN A STRING sub inflect { my $save_persistent_count = $persistent_count; my @sections = split /(NUM\([^)]*\))/, $_[0]; my $inflection = ""; foreach ( @sections ) { unless (s/NUM\(\s*?(?:([^),]*)(?:,([^)]*))?)?\)/ NUM($1,$2) /xe) { 1 while s/\bPL \( ([^),]*) (, ([^)]*) )? \) / PL($1,$3) /xeg || s/\bPL_N \( ([^),]*) (, ([^)]*) )? \) / PL_N($1,$3) /xeg || s/\bPL_V \( ([^),]*) (, ([^)]*) )? \) / PL_V($1,$3) /xeg || s/\bPL_ADJ \( ([^),]*) (, ([^)]*) )? \) / PL_ADJ($1,$3) /xeg || s/\bAN? \( ([^),]*) (, ([^)]*) )? \) / A($1,$3) /xeg || s/\bNO \( ([^),]*) (, ([^)]*) )? \) / NO($1,$3) /xeg || s/\bORD \( ([^)]*) \) / ORD($1) /xeg || s/\bNUMWORDS \( ([^)]*) \) / NUMWORDS($1) /xeg } $inflection .= $_; } $persistent_count = $save_persistent_count; return $inflection; } # 1. PLURALS my %PL_sb_irregular_s = ( "ephemeris" => "ephemerides", "iris" => "irises|irides", "clitoris" => "clitorises|clitorides", "corpus" => "corpuses|corpora", "opus" => "opuses|opera", "genus" => "genera", "mythos" => "mythoi", "penis" => "penises|penes", "testis" => "testes", ); my %PL_sb_irregular = ( "child" => "children", "brother" => "brothers|brethren", "loaf" => "loaves", "hoof" => "hoofs|hooves", "beef" => "beefs|beeves", "money" => "monies", "mongoose" => "mongooses", "ox" => "oxen", "cow" => "cows|kine", "soliloquy" => "soliloquies", "graffito" => "graffiti", "prima donna" => "prima donnas|prime donne", "octopus" => "octopuses|octopodes", "genie" => "genies|genii", "ganglion" => "ganglions|ganglia", "trilby" => "trilbys", "turf" => "turfs|turves", %PL_sb_irregular_s, ); my $PL_sb_irregular = join '|', keys %PL_sb_irregular; # CLASSICAL "..a" -> "..ata" my @PL_sb_C_a_ata = ( "anathema", "bema", "carcinoma", "charisma", "diploma", "dogma", "drama", "edema", "enema", "enigma", "lemma", "lymphoma", "magma", "melisma", "miasma", "oedema", "sarcoma", "schema", "soma", "stigma", "stoma", "trauma", "gumma", "pragma", ); my $PL_sb_C_a_ata = join "|", map { substr($_,0,-1) } @PL_sb_C_a_ata; # UNCONDITIONAL "..a" -> "..ae" my $PL_sb_U_a_ae = join "|", ( "alumna", "alga", "vertebra", ); # CLASSICAL "..a" -> "..ae" my $PL_sb_C_a_ae = join "|", ( "amoeba", "antenna", "formula", "hyperbola", "medusa", "nebula", "parabola", "abscissa", "hydra", "nova", "lacuna", "aurora", ".*umbra", ); # CLASSICAL "..en" -> "..ina" my $PL_sb_C_en_ina = join "|", map { substr($_,0,-2) } ( "stamen", "foramen", "lumen", ); # UNCONDITIONAL "..um" -> "..a" my $PL_sb_U_um_a = join "|", map { substr($_,0,-2) } ( "bacterium", "agendum", "desideratum", "erratum", "stratum", "datum", "ovum", "extremum", "candelabrum", ); # CLASSICAL "..um" -> "..a" my $PL_sb_C_um_a = join "|", map { substr($_,0,-2) } ( "maximum", "minimum", "momentum", "optimum", "quantum", "cranium", "curriculum", "dictum", "phylum", "aquarium", "compendium", "emporium", "enconium", "gymnasium", "honorarium", "interregnum", "lustrum", "memorandum", "millenium", "rostrum", "spectrum", "speculum", "stadium", "trapezium", "ultimatum", "medium", "vacuum", "velum", "consortium", ); # UNCONDITIONAL "..us" -> "i" my $PL_sb_U_us_i = join "|", map { substr($_,0,-2) } ( "alumnus", "alveolus", "bacillus", "bronchus", "locus", "nucleus", "stimulus", "meniscus", ); # CLASSICAL "..us" -> "..i" my $PL_sb_C_us_i = join "|", map { substr($_,0,-2) } ( "focus", "radius", "genius", "incubus", "succubus", "nimbus", "fungus", "nucleolus", "stylus", "torus", "umbilicus", "uterus", ); # CLASSICAL "..us" -> "..us" (ASSIMILATED 4TH DECLENSION LATIN NOUNS) my $PL_sb_C_us_us = join "|", ( "status", "apparatus", "prospectus", "sinus", "hiatus", "impetus", "plexus", ); # UNCONDITIONAL "..on" -> "a" my $PL_sb_U_on_a = join "|", map { substr($_,0,-2) } ( "criterion", "perihelion", "aphelion", "phenomenon", "prolegomenon", "noumenon", "organon", "asyndeton", "hyperbaton", ); # CLASSICAL "..on" -> "..a" my $PL_sb_C_on_a = join "|", map { substr($_,0,-2) } ( "oxymoron", ); # CLASSICAL "..o" -> "..i" (BUT NORMALLY -> "..os") my @PL_sb_C_o_i = ( "solo", "soprano", "basso", "alto", "contralto", "tempo", ); my $PL_sb_C_o_i = join "|", map { substr($_,0,-1) } @PL_sb_C_o_i; # ALWAYS "..o" -> "..os" my $PL_sb_U_o_os = join "|", ( "albino", "archipelago", "armadillo", "commando", "crescendo", "fiasco", "ditto", "dynamo", "embryo", "ghetto", "guano", "inferno", "jumbo", "lumbago", "magneto", "manifesto", "medico", "octavo", "photo", "pro", "quarto", "canto", "lingo", "generalissimo", "stylo", "rhino", @PL_sb_C_o_i, ); # UNCONDITIONAL "..ex" -> "..ices" my $PL_sb_U_ex_ices = join "|", map { substr($_,0,-2) } ( "codex", "murex", "silex", ); # CLASSICAL "..ex" -> "..ices" my $PL_sb_C_ex_ices = join "|", map { substr($_,0,-2) } ( "vortex", "vertex", "cortex", "latex", "pontifex", "apex", "index", "simplex", ); # ARABIC: ".." -> "..i" my $PL_sb_C_i = join "|", ( "afrit", "afreet", "efreet", ); # HEBREW: ".." -> "..im" my $PL_sb_C_im = join "|", ( "goy", "seraph", "cherub", ); # UNCONDITIONAL "..man" -> "..mans" my $PL_sb_U_man_mans = join "|", qw( human Alabaman Bahaman Burman German Hiroshiman Liman Nakayaman Oklahoman Panaman Selman Sonaman Tacoman Yakiman Yokohaman Yuman ); my @PL_sb_uninflected_s = ( # PAIRS OR GROUPS SUBSUMED TO A SINGULAR... "breeches", "britches", "clippers", "gallows", "hijinks", "headquarters", "pliers", "scissors", "testes", "herpes", "pincers", "shears", "proceedings", # UNASSIMILATED LATIN 4th DECLENSION "cantus", "coitus", "nexus", # RECENT IMPORTS... "contretemps", "corps", "debris", ".*ois", # DISEASES ".*measles", "mumps", # MISCELLANEOUS OTHERS... "diabetes", "jackanapes", "series", "species", "rabies", "chassis", "innings", "news", "mews", ); my $PL_sb_uninflected = join "|", ( # SOME FISH AND HERD ANIMALS ".*fish", "tuna", "salmon", "mackerel", "trout", "bream", "sea[- ]bass", "carp", "cod", "flounder", "whiting", ".*deer", ".*sheep", "wildebeest", "swine", "eland", "bison", "elk", # ALL NATIONALS ENDING IN -ese "Portuguese", "Japanese", "Chinese", "Vietnamese", "Burmese", "Lebanese", "Siamese", "Senegalese", "Bhutanese", "Sinhalese", # SOME WORDS ENDING IN ...s (OFTEN PAIRS TAKEN AS A WHOLE) @PL_sb_uninflected_s, # DISEASES ".*pox", # OTHER ODDITIES "graffiti", "djinn" ); # SINGULAR WORDS ENDING IN ...s (ALL INFLECT WITH ...es) my $PL_sb_singular_s = join '|', ( ".*ss", "acropolis", "aegis", "alias", "arthritis", "asbestos", "atlas", "bathos", "bias", "bronchitis", "bursitis", "caddis", "cannabis", "canvas", "chaos", "cosmos", "dais", "digitalis", "encephalitis", "epidermis", "ethos", "gas", "glottis", "hepatitis", "hubris", "ibis", "lens", "mantis", "marquis", "metropolis", "neuritis", "pathos", "pelvis", "polis", "rhinoceros", "sassafras", "tonsillitis", "trellis", ".*us", ); my $PL_v_special_s = join '|', ( $PL_sb_singular_s, @PL_sb_uninflected_s, keys %PL_sb_irregular_s, '(.*[csx])is', '(.*)ceps', '[A-Z].*s', ); my $PL_sb_military = 'major|lieutenant|brigadier|adjutant|quartermaster'; my $PL_sb_general = '((?!'.$PL_sb_military.').*?)((-|\s+)general)'; my $PL_prep = join '|', qw ( about above across after among around at athwart before behind below beneath beside besides between betwixt beyond but by during except for from in into near of off on onto out over since till to under until unto upon with ); my $PL_sb_prep_compound = '(.*?)((-|\s+)('.$PL_prep.'|d[eu])((-|\s+)(.*))?)'; my %PL_pron_nom = ( # NOMINATIVE REFLEXIVE "i" => "we", "myself" => "ourselves", "you" => "you", "yourself" => "yourselves", "she" => "they", "herself" => "themselves", "he" => "they", "himself" => "themselves", "it" => "they", "itself" => "themselves", "they" => "they", "themself" => "themselves", # POSSESSIVE "mine" => "ours", "yours" => "yours", "hers" => "theirs", "his" => "theirs", "its" => "theirs", "theirs" => "theirs", ); my %PL_pron_acc = ( # ACCUSATIVE REFLEXIVE "me" => "us", "myself" => "ourselves", "you" => "you", "yourself" => "yourselves", "her" => "them", "herself" => "themselves", "him" => "them", "himself" => "themselves", "it" => "them", "itself" => "themselves", "them" => "them", "themself" => "themselves", ); my $PL_pron_acc = join '|', keys %PL_pron_acc; my %PL_v_irregular_pres = ( # 1st PERS. SING. 2ND PERS. SING. 3RD PERS. SINGULAR # 3RD PERS. (INDET.) "am" => "are", "are" => "are", "is" => "are", "was" => "were", "were" => "were", "was" => "were", "have" => "have", "have" => "have", "has" => "have", ); my $PL_v_irregular_pres = join '|', keys %PL_v_irregular_pres; my %PL_v_ambiguous_pres = ( # 1st PERS. SING. 2ND PERS. SING. 3RD PERS. SINGULAR # 3RD PERS. (INDET.) "act" => "act", "act" => "act", "acts" => "act", "blame" => "blame", "blame" => "blame", "blames" => "blame", "can" => "can", "can" => "can", "can" => "can", "must" => "must", "must" => "must", "must" => "must", "fly" => "fly", "fly" => "fly", "flies" => "fly", "copy" => "copy", "copy" => "copy", "copies" => "copy", "drink" => "drink", "drink" => "drink", "drinks" => "drink", "fight" => "fight", "fight" => "fight", "fights" => "fight", "fire" => "fire", "fire" => "fire", "fires" => "fire", "like" => "like", "like" => "like", "likes" => "like", "look" => "look", "look" => "look", "looks" => "look", "make" => "make", "make" => "make", "makes" => "make", "reach" => "reach", "reach" => "reach", "reaches" => "reach", "run" => "run", "run" => "run", "runs" => "run", "sink" => "sink", "sink" => "sink", "sinks" => "sink", "sleep" => "sleep", "sleep" => "sleep", "sleeps" => "sleep", "view" => "view", "view" => "view", "views" => "view", ); my $PL_v_ambiguous_pres = join '|', keys %PL_v_ambiguous_pres; my $PL_v_irregular_non_pres = join '|', ( "did", "had", "ate", "made", "put", "spent", "fought", "sank", "gave", "sought", "shall", "could", "ought", "should", ); my $PL_v_ambiguous_non_pres = join '|', ( "thought", "saw", "bent", "will", "might", "cut", ); my $PL_count_zero = join '|', ( 0, "no", "zero", "nil" ); my $PL_count_one = join '|', ( 1, "a", "an", "one", "each", "every", "this", "that", ); my %PL_adj_special = ( "a" => "some", "an" => "some", "this" => "these", "that" => "those", ); my $PL_adj_special = join '|', keys %PL_adj_special; my %PL_adj_poss = ( "my" => "our", "your" => "your", "its" => "their", "her" => "their", "his" => "their", "their" => "their", ); my $PL_adj_poss = join '|', keys %PL_adj_poss; sub checkpat { local $SIG{__WARN__} = sub {0}; do {$@ =~ s/at.*?$//; die "\nBad user-defined singular pattern:\n\t$@\n"} if (!eval "'' =~ m/$_[0]/; 1;" or $@); return @_; } sub checkpatsubs { checkpat($_[0]); if (defined $_[1]) { local $SIG{__WARN__} = sub {0}; do {$@ =~ s/at.*?$//; die "\nBad user-defined plural string: '$_[1]'\n\t$@\n"} if (!eval "qq{$_[1]}; 1;" or $@); } return @_; } my @PL_sb_user_defined = (); my @PL_v_user_defined = (); my @PL_adj_user_defined = (); my @A_a_user_defined = (); sub def_noun { unshift @PL_sb_user_defined, checkpatsubs(@_); return 1; } sub def_verb { unshift @PL_v_user_defined, checkpatsubs(@_[4,5]); unshift @PL_v_user_defined, checkpatsubs(@_[2,3]); unshift @PL_v_user_defined, checkpatsubs(@_[0,1]); return 1; } sub def_adj { unshift @PL_adj_user_defined, checkpatsubs(@_); return 1; } sub def_a { unshift @A_a_user_defined, checkpat(@_,'a'); return 1; } sub def_an { unshift @A_a_user_defined, checkpat(@_,'an'); return 1; } sub ud_match { my $word = shift; for (my $i=0; $i < @_; $i+=2) { if ($word =~ /^(?:$_[$i])$/i) { last unless defined $_[$i+1]; return eval '"'.$_[$i+1].'"'; } } return undef; } do { local $SIG{__WARN__} = sub {0}; my $rcfile; $rcfile = $INC{'Lingua//EN/Inflect.pm'} || ''; $rcfile =~ s/Inflect.pm$/.inflectrc/; do $rcfile or die "\nBad .inflectrc file ($rcfile):\n\t$@\n" if $rcfile && -r $rcfile && -s $rcfile; $rcfile = "$ENV{HOME}/.inflectrc" || ''; do $rcfile or die "\nBad .inflectrc file ($rcfile):\n\t$@\n" if $rcfile && -r $rcfile && -s $rcfile; }; sub postprocess # FIX PEDANTRY AND CAPITALIZATION :-) { my ($orig, $inflected) = @_; $inflected =~ s/([^|]+)\|(.+)/ $classical?$2:$1 /e; return $orig =~ /^I$/ ? $inflected : $orig =~ /^[A-Z]+$/ ? uc $inflected : $orig =~ /^[A-Z]/ ? ucfirst $inflected : $inflected; } sub PL # PL($word,$number) { my ($str, $count) = @_; my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/); return $str unless $word; my $plural = postprocess $word, _PL_special_adjective($word,$count) || _PL_special_verb($word,$count) || _PL_noun($word,$count); return $pre.$plural.$post; } sub PL_N # PL_N($word,$number) { my ($str, $count) = @_; my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/); return $str unless $word; my $plural = postprocess $word, _PL_noun($word,$count); return $pre.$plural.$post; } sub PL_V # PL_V($word,$number) { my ($str, $count) = @_; my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/); return $str unless $word; my $plural = postprocess $word, _PL_special_verb($word,$count) || _PL_general_verb($word,$count); return $pre.$plural.$post; } sub PL_ADJ # PL_ADJ($word,$number) { my ($str, $count) = @_; my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/); return $str unless $word; my $plural = postprocess $word, _PL_special_adjective($word,$count) || $word; return $pre.$plural.$post; } sub PL_eq { _PL_eq(@_, \&PL); } sub PL_N_eq { _PL_eq(@_, \&PL_N); } sub PL_V_eq { _PL_eq(@_, \&PL_V); } sub PL_ADJ_eq { _PL_eq(@_, \&PL_ADJ); } sub _PL_eq { my ( $word1, $word2, $PL ) = @_; my $classval = $classical; my $result = ""; $result = "eq" if !$result && $word1 eq $word2; $result = "p:s" if !$result && $word1 eq &$PL($word2); $result = "s:p" if !$result && &$PL($word1) eq $word2; $classical = !$classval; $result = "p:s" if !$result && $word1 eq &$PL($word2); $result = "s:p" if !$result && &$PL($word1) eq $word2; $classical = $classval; if ($PL == \&PL || $PL == \&PL_N) { $result = "p:p" if !$result && _PL_check_plurals_N($word1,$word2); $result = "p:p" if !$result && _PL_check_plurals_N($word2,$word1); } if ($PL == \&PL || $PL == \&PL_ADJ) { $result = "p:p" if !$result && _PL_check_plurals_ADJ($word1,$word2,$PL); } return $result; } sub _PL_reg_plurals { $_[0] =~ /($_[1])($_[2]\|\1$_[3]|$_[3]\|\1$_[2])/ } sub _PL_check_plurals_N { my $pair = "$_[0]|$_[1]"; foreach ( values %PL_sb_irregular_s ) { return 1 if $_ eq $pair; } foreach ( values %PL_sb_irregular ) { return 1 if $_ eq $pair; } return 1 if _PL_reg_plurals($pair, $PL_sb_C_a_ata, "as","ata") || _PL_reg_plurals($pair, $PL_sb_C_a_ae, "s","e") || _PL_reg_plurals($pair, $PL_sb_C_en_ina, "ens","ina") || _PL_reg_plurals($pair, $PL_sb_C_um_a, "ums","a") || _PL_reg_plurals($pair, $PL_sb_C_us_i, "uses","i") || _PL_reg_plurals($pair, $PL_sb_C_on_a, "ons","a") || _PL_reg_plurals($pair, $PL_sb_C_o_i, "os","i") || _PL_reg_plurals($pair, $PL_sb_C_ex_ices, "exes","ices") || _PL_reg_plurals($pair, $PL_sb_C_i, "s","i") || _PL_reg_plurals($pair, $PL_sb_C_im, "s","im") || _PL_reg_plurals($pair, '.*eau', "s","x") || _PL_reg_plurals($pair, '.*ieu', "s","x") || _PL_reg_plurals($pair, '.*tri', "xes","ces") || _PL_reg_plurals($pair, '.{2,}[yia]n', "xes","ges"); return 0; } sub _PL_check_plurals_ADJ { my ( $word1a, $word2a ) = @_; my ( $word1b, $word2b ) = @_; $word1a = '' unless $word1a =~ s/'s?$//; $word2a = '' unless $word2a =~ s/'s?$//; $word1b = '' unless $word1b =~ s/s'$//; $word2b = '' unless $word2b =~ s/s'$//; if ($word1a) { return 1 if $word2a && ( _PL_check_plurals_N($word1a, $word2a) || _PL_check_plurals_N($word2a, $word1a) ); return 1 if $word2b && ( _PL_check_plurals_N($word1a, $word2b) || _PL_check_plurals_N($word2b, $word1a) ); } if ($word1b) { return 1 if $word2a && ( _PL_check_plurals_N($word1b, $word2a) || _PL_check_plurals_N($word2a, $word1b) ); return 1 if $word2b && ( _PL_check_plurals_N($word1b, $word2b) || _PL_check_plurals_N($word2b, $word1b) ); } return ""; } sub _PL_noun { my ( $word, $count ) = @_; my $value; # UTILITY VARIABLE # DEFAULT TO PLURAL $count = $persistent_count if !defined($count) && defined($persistent_count); $count = (defined $count and $count=~/^($PL_count_one)$/io or defined $count and $classical and $count=~/^($PL_count_zero)$/io) ? 1 : 2; return $word if $count==1; # HANDLE USER-DEFINED NOUNS return $value if defined($value = ud_match($word, @PL_sb_user_defined)); # HANDLE EMPTY WORD, SINGULAR COUNT AND UNINFLECTED PLURALS $word eq '' and return $word; $word =~ /^($PL_sb_uninflected)$/i and return $word; # HANDLE PRONOUNS $word =~ /^((?:$PL_prep)\s+)($PL_pron_acc)$/i and return $1.$PL_pron_acc{lc($2)}; $value = $PL_pron_nom{lc($word)} and return $value; $word =~ /^($PL_pron_acc)$/i and return $PL_pron_acc{lc($1)}; # HANDLE ISOLATED IRREGULAR PLURALS $word =~ /(.*)\b($PL_sb_irregular)$/i and return $1 . $PL_sb_irregular{lc $2}; $word =~ /($PL_sb_U_man_mans)$/i and return "$1s"; # HANDLE FAMILIES OF IRREGULAR PLURALS $word =~ /(.*)man$/i and return "$1men"; $word =~ /(.*[ml])ouse$/i and return "$1ice"; $word =~ /(.*)goose$/i and return "$1geese"; $word =~ /(.*)tooth$/i and return "$1teeth"; $word =~ /(.*)foot$/i and return "$1feet"; # HANDLE UNASSIMILATED IMPORTS $word =~ /(.*)ceps$/i and return $word; $word =~ /(.*)zoon$/i and return "$1zoa"; $word =~ /(.*[csx])is$/i and return "$1es"; $word =~ /($PL_sb_U_ex_ices)ex$/i and return "$1ices"; $word =~ /($PL_sb_U_um_a)um$/i and return "$1a"; $word =~ /($PL_sb_U_us_i)us$/i and return "$1i"; $word =~ /($PL_sb_U_on_a)on$/i and return "$1a"; $word =~ /($PL_sb_U_a_ae)$/i and return "$1e"; # HANDLE INCOMPLETELY ASSIMILATED IMPORTS if ($classical) { $word =~ /(.*)trix$/i and return "$1trices"; $word =~ /(.*)eau$/i and return "$1eaux"; $word =~ /(.*)ieu$/i and return "$1ieux"; $word =~ /(.{2,}[yia])nx$/i and return "$1nges"; $word =~ /($PL_sb_C_en_ina)en$/i and return "$1ina"; $word =~ /($PL_sb_C_ex_ices)ex$/i and return "$1ices"; $word =~ /($PL_sb_C_um_a)um$/i and return "$1a"; $word =~ /($PL_sb_C_us_i)us$/i and return "$1i"; $word =~ /($PL_sb_C_us_us)$/i and return "$1"; $word =~ /($PL_sb_C_a_ae)$/i and return "$1e"; $word =~ /($PL_sb_C_a_ata)a$/i and return "$1ata"; $word =~ /($PL_sb_C_o_i)o$/i and return "$1i"; $word =~ /($PL_sb_C_on_a)on$/i and return "$1a"; $word =~ /$PL_sb_C_im$/i and return "${word}im"; $word =~ /$PL_sb_C_i$/i and return "${word}i"; } # HANDLE SINGULAR NOUNS ENDING IN ...s OR OTHER SILIBANTS $word =~ /^($PL_sb_singular_s)$/i and return "$1es"; $word =~ /^([A-Z].*s)$/ and return "$1es"; $word =~ /(.*)([cs]h|[zx])$/i and return "$1$2es"; $word =~ /(.*)(us)$/i and return "$1$2es"; # HANDLE ...f -> ...ves $word =~ /(.*[eao])lf$/i and return "$1lves"; $word =~ /(.*[^d])eaf$/i and return "$1eaves"; $word =~ /(.*[nlw])ife$/i and return "$1ives"; $word =~ /(.*)arf$/i and return "$1arves"; # HANDLE ...y $word =~ /(.*[aeiou])y$/i and return "$1ys"; $word =~ /([A-Z].*y)$/ and return "$1s"; $word =~ /(.*)y$/i and return "$1ies"; # HANDLE ...o $word =~ /$PL_sb_U_o_os$/i and return "${word}s"; $word =~ /[aeiou]o$/i and return "${word}s"; $word =~ /o$/i and return "${word}es"; # HANDLE COMPOUNDS ("Governor General", "mother-in-law", "aide-de-camp", ETC.) $word =~ /^(?:$PL_sb_general)$/i and $value = $2 and return _PL_noun($1,2,"$1s") . $value; $word =~ /^(?:$PL_sb_prep_compound)$/i and $value = $2 and return _PL_noun($1,2) . $value; # OTHERWISE JUST ADD ...s return "${word}s"; } sub _PL_special_verb { my ( $word, $count ) = @_; $count = $persistent_count if !defined($count) && defined($persistent_count); $count = (defined $count and $count=~/^($PL_count_one)$/io or defined $count and $classical and $count=~/^($PL_count_zero)$/io) ? 1 : 2; return undef if $count=~/^($PL_count_one)$/io; my $value; # UTILITY VARIABLE # HANDLE USER-DEFINED VERBS return $value if defined($value = ud_match($word, @PL_v_user_defined)); # HANDLE IRREGULAR PRESENT TENSE (SIMPLE AND COMPOUND) $word =~ /^($PL_v_irregular_pres)((\s.*)?)$/i and return $PL_v_irregular_pres{lc $1}.$2; # HANDLE IRREGULAR FUTURE, PRETERITE AND PERFECT TENSES $word =~ /^($PL_v_irregular_non_pres)((\s.*)?)$/i and return $word; # HANDLE SPECIAL CASES $word =~ /^($PL_v_special_s)$/ and return undef; $word =~ /\s/ and return undef; # HANDLE STANDARD 3RD PERSON (CHOP THE ...(e)s OFF SINGLE WORDS) $word =~ /^(.*)([cs]h|[x]|zz|ss)es$/i and return "$1$2"; $word =~ /^(..+)ies$/i and return "$1y"; $word =~ /^(.+)oes$/i and return "$1o"; $word =~ /^(.*[^s])s$/i and return $1; # OTHERWISE, A REGULAR VERB (HANDLE ELSEWHERE) return undef; } sub _PL_general_verb { my ( $word, $count ) = @_; $count = $persistent_count if !defined($count) && defined($persistent_count); $count = (defined $count and $count=~/^($PL_count_one)$/io or defined $count and $classical and $count=~/^($PL_count_zero)$/io) ? 1 : 2; return $word if $count=~/^($PL_count_one)$/io; # HANDLE AMBIGUOUS PRESENT TENSES (SIMPLE AND COMPOUND) $word =~ /^($PL_v_ambiguous_pres)((\s.*)?)$/i and return $PL_v_ambiguous_pres{lc $1}.$2; # HANDLE AMBIGUOUS PRETERITE AND PERFECT TENSES $word =~ /^($PL_v_ambiguous_non_pres)((\s.*)?)$/i and return $word; # OTHERWISE, 1st OR 2ND PERSON IS UNINFLECTED return $word; } sub _PL_special_adjective { my ( $word, $count ) = @_; $count = $persistent_count if !defined($count) && defined($persistent_count); $count = (defined $count and $count=~/^($PL_count_one)$/io or defined $count and $classical and $count=~/^($PL_count_zero)$/io) ? 1 : 2; return $word if $count=~/^($PL_count_one)$/io; # HANDLE USER-DEFINED ADJECTIVES my $value; return $value if defined($value = ud_match($word, @PL_adj_user_defined)); # HANDLE KNOWN CASES $word =~ /^($PL_adj_special)$/i and return $PL_adj_special{lc $1}; # HANDLE POSSESSIVES $word =~ /^($PL_adj_poss)$/i and return $PL_adj_poss{lc $1}; $word =~ /^(.*)'s?$/ and do { my $pl = PL_N($1); return "$pl'" . ($pl =~ m/s$/ ? "" : "s"); }; # OTHERWISE, NO IDEA return undef; } # 2. INDEFINITE ARTICLES # THIS PATTERN MATCHES STRINGS OF CAPITALS STARTING WITH A "VOWEL-SOUND" # CONSONANT FOLLOWED BY ANOTHER CONSONANT, AND WHICH ARE NOT LIKELY # TO BE REAL WORDS (OH, ALL RIGHT THEN, IT'S JUST MAGIC!) my $A_abbrev = q{ (?! FJO | [HLMNS]Y. | RY[EO] | SQU | ( F[LR]? | [HL] | MN? | N | RH? | S[CHKLMNPTVW]? | X(YL)?) [AEIOU]) [FHLMNRSX][A-Z] }; # THIS PATTERN CODES THE BEGINNINGS OF ALL ENGLISH WORDS BEGINING WITH A # 'y' FOLLOWED BY A CONSONANT. ANY OTHER Y-CONSONANT PREFIX THEREFORE # IMPLIES AN ABBREVIATION. my $A_y_cons = 'y(b[lor]|cl[ea]|fere|gg|p[ios]|rou|tt)'; # EXCEPTIONS TO EXCEPTIONS my $A_explicit_an = join '|', ( "euler", "hour(?!i)", "heir", "honest", "hono", ); sub A { my ($str, $count) = @_; my ($pre, $word, $post) = ( $str =~ m/\A(\s*)(.+?)(\s*)\Z/ ); return $str unless $word; my $result = _indef_article($word,$count); return $pre.$result.$post; } sub AN { goto &A } sub _indef_article { my ( $word, $count ) = @_; $count = $persistent_count if !defined($count) && defined($persistent_count); return "$count $word" if defined $count && $count!~/^($PL_count_one)$/io; # HANDLE USER-DEFINED VARIANTS my $value; return $value if defined($value = ud_match($word, @A_a_user_defined)); # HANDLE SPECIAL CASES $word =~ /^($A_explicit_an)/i and return "an $word"; # HANDLE ABBREVIATIONS $word =~ /^($A_abbrev)/ox and return "an $word"; $word =~ /^[aefhilmnorsx][.-]/i and return "an $word"; $word =~ /^[a-z][.-]/i and return "a $word"; # HANDLE CONSONANTS $word =~ /^[^aeiouy]/i and return "a $word"; # HANDLE SPECIAL VOWEL-FORMS $word =~ /^e[uw]/i and return "a $word"; $word =~ /^onc?e\b/i and return "a $word"; $word =~ /^uni([^nmd]|mo)/i and return "a $word"; $word =~ /^u[bcfhjkqrst][aeiou]/i and return "a $word"; # HANDLE VOWELS $word =~ /^[aeiou]/i and return "an $word"; # HANDLE y... (BEFORE CERTAIN CONSONANTS IMPLIES (UNNATURALIZED) "i.." SOUND) $word =~ /^($A_y_cons)/io and return "an $word"; # OTHERWISE, GUESS "a" return "a $word"; } # 2. TRANSLATE ZERO-QUANTIFIED $word TO "no PL($word)" sub NO { my ($str, $count) = @_; my ($pre, $word, $post) = ($str =~ m/\A(\s*)(.+?)(\s*)\Z/); $count = $persistent_count if !defined($count) && defined($persistent_count); $count = 0 unless $count; return "$pre$count " . PL($word,$count) . $post unless $count =~ /^$PL_count_zero$/; return "${pre}no ". PL($word,0) . $post ; } # PARTICIPLES sub PART_PRES { local $_ = PL_V(shift,2); s/ie$/y/ or s/ue$/u/ or s/([auy])e$/$1/ or s/i$// or s/([^e])e$/$1/ or m/er$/ or s/([^aeiou][aeiouy]([bdgmnprst]))$/$1$2/; return "${_}ing"; } # NUMERICAL INFLECTIONS my %nth = ( 0 => 'th', 1 => 'st', 2 => 'nd', 3 => 'rd', 4 => 'th', 5 => 'th', 6 => 'th', 7 => 'th', 8 => 'th', 9 => 'th', 11 => 'th', 12 => 'th', 13 => 'th', ); sub ORD { $_[0] . ($nth{$_[0]%100} || $nth{$_[0]%10}); } my %default_args = ( 'group' => 0, 'comma' => ',', 'and' => 'and', 'zero' => 'zero', 'decimal' => 'point', ); my @unit = ('',qw(one two three four five six seven eight nine)); my @teen = qw(ten eleven twelve thirteen fourteen fifteen sixteen seventeen eighteen nineteen); my @ten = ('','',qw(twenty thirty forty fifty sixty seventy eighty ninety)); my @mill = map { (my $val=$_) =~ s/_/illion/; " $val" } ('',qw(thousand m_ b_ tr_ quadr_ quint_ sext_ sept_ oct_ non_ dec_)); sub mill { my $ind = $_[0]||0; die "Number out of range\n" if $ind > $#mill; return $ind<@mill ? $mill[$ind] : ' ???illion'; } sub unit { return $unit[$_[0]]. mill($_[1]); } sub ten { return $ten[$_[0]] . ($_[0]&&$_[1]?'-':'') . $unit[$_[1]] . mill($_[2]) if $_[0] ne '1'; return $teen[$_[1]]. $mill[$_[2]||0]; } sub hund { return unit($_[0]) . " hundred" . ($_[1] || $_[2] ? " $_[4] " : '') . ten($_[1],$_[2]) . mill($_[3]) . ', ' if $_[0]; return ten($_[1],$_[2]) . mill($_[3]) . ', ' if $_[1] || $_[2]; return ''; } sub enword { my ($num,$group,$zero,$comma,$and) = @_; if ($group==1) { $num =~ s/(\d)/ ($1 ? unit($1) :" $zero")."$comma " /eg; } elsif ($group==2) { $num =~ s/(\d)(\d)/ ($1 ? ten($1,$2) : $2 ? " $zero " . unit($2) : " $zero $zero") . "$comma " /eg; $num =~ s/(\d)/ ($1 ? unit($1) :" $zero")."$comma " /e; } elsif ($group==3) { $num =~ s/(\d)(\d)(\d)/ ($1 ? unit($1) :" $zero")." ".($2 ? ten($2,$3) : $3 ? " $zero " . unit($3) : " $zero $zero") . "$comma " /eg; $num =~ s/(\d)(\d)/ ($1 ? ten($1,$2) : $2 ? " $zero " . unit($2) : " $zero $zero") . "$comma " /e; $num =~ s/(\d)/ ($1 ? unit($1) :" $zero")."$comma " /e; } elsif ($num+0==0) { $num = $zero; } else { $num =~ s/\A\s*0+//; my $mill = 0; 1 while $num =~ s/(\d)(\d)(\d)(?=\D*\Z)/ hund($1,$2,$3,$mill++,$and) /e; $num =~ s/(\d)(\d)(?=\D*\Z)/ ten($1,$2,$mill)."$comma " /e; $num =~ s/(\d)(?=\D*\Z)/ unit($1,$mill) . "$comma "/e; } return $num; } sub NUMWORDS { my $num = shift; my %arg = ( %default_args, @_ ); my $group = $arg{group}; die "Bad chunking option: $group\n" unless $group =~ /\A[0-3]\Z/; my $sign = ($num =~ /\A\s*\+/) ? "plus" : ($num =~ /\A\s*\-/) ? "minus" : ''; my $zero = $arg{zero}; my $comma = $arg{comma}; my $and = $arg{'and'}; my @chunks = ($arg{decimal}) ? $group ? split(/\./, $num) : split(/\./, $num, 2) : ($num); my $first = 1; if ($chunks[0] eq '') { $first=0; shift @chunks; } foreach ( @chunks ) { s/\D//g; $_ = '0' unless $_; if (!$group && !$first) { $_ = enword($_,1,$zero,$comma,$and) } else { $_ = enword($_,$group,$zero,$comma,$and) } s/, \Z//; s/\s+,/,/g; s/, (\S+)\s+\Z/ $and $1/ if !$group and $first; s/\s+/ /g; s/(\A\s|\s\Z)//g; $first = '' if $first; } my @numchunks = (); if ($first =~ /0/) { unshift @chunks, ''; } else { @numchunks = split /\Q$comma /, $chunks[0]; } foreach (@chunks[1..$#chunks]) { push @numchunks, $arg{decimal}; push @numchunks, split /\Q$comma /; } if (wantarray) { unshift @numchunks, $sign if $sign; return @numchunks } elsif ($group) { return ($sign?"$sign ":'') . join ", ", @numchunks; } else { $num = ($sign?"$sign ":'') . shift @numchunks; $first = ($num !~ /$arg{decimal}\Z/); foreach ( @numchunks ) { if (/\A$arg{decimal}\Z/) { $num .= " $_"; $first = 0; } elsif ($first) { $num .= "$comma $_"; } else { $num .= " $_"; } } return $num; } } 1; __END__ nks, split /\Q$comma /; } if (wantarray) { unshift @numchunks, $sign if $sign; return @numchunks } elsif ($group) { return ($sign?"$sign ":'') . join ", ", @numchunks; } else { $num = ($sign?"$sign ":'') . shift @numchunks; $first = (