#!/usr/bin/perl

use v5.12;
use warnings;

# Default configuration

my $format_full = '(%a %y)';
my $format_extra = '(%y)';
my $format_list = '%a (%y). %t. %q. %n, %d. %c: %p.';

# Internal variables

my $author_last = 0; # whether the previous reference field was Ra
my @lines;
my $i = -1;
my @refs;

while (<>) {
	# Formats
	if (/^\.Ff +(.*)/) { $format_full = $1; next; }
	if (/^\.Fx +(.*)/) { $format_extra = $1; next; }
	if (/^\.Fl +(.*)/) { $format_list = $1; next; }

	# Reference definitions
	if (/^\.R([a-z]) +(.*)/) {
		my ($fld, $def) = ($1, $2);
		if ($fld eq 'a') {
			$i++ if not $author_last;
			push @lines, ".R! $i";
			$refs[$i]{$fld} = $def;
			$author_last = 1;
			next;
		} elsif ($fld =~ /[cdnpqtwy]/) {
			$refs[$i]{$fld} = $def;
			$author_last = 0;
			next;
		}
	}

	# Non-rf line
	push @lines, $_;
}

for (@lines) {
	# Inline reference
	if (/^\.R([fx]) +(.*)/) {
		my ($fld, $def) = ($1, $2);
		$def =~ s/ ([.,:;\])]) ?([\[(])?$//;
		my ($suffix, $prefix) = ($1, $2);
		my $winner = 0;
		my @words = split /\s/, $def;
		my @points;
		for (my $i = 0; $i < scalar @refs; $i++) {
			$points[$i] = 0 if not defined $points[$i];
			$points[$i] += 7 if likeness($refs[$i]{a}, @words);
			$points[$i] += 4 if likeness($refs[$i]{y}, @words);
			$points[$i] += 1 if likeness($refs[$i]{t}, @words);
			$points[$i] += 1 if likeness($refs[$i]{q}, @words);
			$winner = $i if $points[$i] > $points[$winner];
		}
		if (not defined $winner) {
			print STDERR "Reference '$def' could not be resolved.\n";
			exit 1;
		}
		if ($fld eq 'f') {
			no warnings;
			print $prefix . fmt($format_full, $winner) . "$suffix\n";
		} else {
			no warnings;
			print $prefix . fmt($format_extra, $winner) . "$suffix\n";
		}
		next;
	}

	# Reference definition
	if (/^\.R! (\d+)/) {
		print fmt($format_list, $1) . "\n";

		next;
	}

	# Non-rf line
	print "$_";
}

sub fmt {
	my ($fmt, $i) = @_;
	my %ref = %{$refs[$i]};
	for my $fld (split //, 'acdnpqtwy') {
		if ($ref{$fld}) {
			no warnings;
			my $val = $ref{$fld};
			$val = fmta($val) if $fld eq 'a';
			$fmt =~ s/\{(.*?)%$fld(.*?)}/$1$val$3/g;
			$fmt =~ s/%$fld/$val/g;
		} else {
			no warnings;
			$fmt =~ s/\{(.*?)%$fld(.*?)}//g;
			$fmt =~ s/[.(]?%$fld[.,:;)]?//g;
		}
	}
	$fmt =~ s/ +/ /g;
	$fmt =~ s/^ *//;
	$fmt =~ s/ *$//;
	return $fmt;
}

sub fmta {
	my ($name) = @_;
	if ($name =~ /(.*?),/) {
		return $1;
	} else {
		$name =~ s/(.*?)\s/$1/;
		return $name;
	}
}

sub likeness {
	my ($string, @strings) = @_;
	return 0 if not defined $string;
	for (@strings) {
		return 1 if index($string, $_) != -1;
	}
	return 0;
}