File Coverage

blib/lib/Coy.pm

Criterion	Covered	Total	%
statement	93	247	37.6
branch	11	70	15.7
condition	1	55	1.8
subroutine	16	46	34.7
pod	0	24	0.0
total	121	442	27.3

package Coy;

BEGIN
{
require Exporter;
@ISA = ('Exporter');
@EXPORT = qw(transcend enlighten);
$VERSION = '0.06';

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 tree
{
	push @Coy::tree, @_;
	1;
}

sub fruit_tree
{
	push @Coy::fruit_tree, @_;
	1;
}

sub place
{
	push @Coy::place, @_;
	1;
}

sub personage
{
	push @Coy::personage, @_;
	1;
}

sub noun
{
	my $hashref = shift;
	Carp::croak "Usage: noun " unless ref($hashref) eq 'HASH';
	$Coy::agent = { %$Coy::agent, %$hashref };
	# print STDERR "Added ", scalar keys %$hashref, " to agent\n";
	1;
}

sub categories
{
	my $hashref = shift;
	Carp::croak "Usage: categories " unless ref($hashref) eq 'HASH';
	$Coy::agent_categories = { %$Coy::agent_categories, %$hashref };
	# print STDERR "Added ", scalar keys %$hashref, " to agent_categories\n";
	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(?= )/a/;
	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 <

	-----
	$haiku
	-----

		${personage}'s commentary...

		$message

			$where
MU
}

sub associate
{
	%Coy::associations = ();
	my ($message) = @_;
	$message =~ s/[^A-Za-z]+/ /g;
	my @words = split /\s+/, $message;
	$Coy::associations = join "|", grep {$_} @words;
	# $Coy::associations = qr/$Coy::associations/;
}

# LOAD STANDARD DATA

syllable_counter "Lingua::EN::Hyphenate::syllables";

noun
{
	duck =>
	{
		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__