#!/usr/bin/perl

use v5.12;
use warnings;

# Default configuration

my $format_full = '(%a %y)';
my $format_extra = '(%y)';
my $format_list = '%a (%y). {\fI%t\fR}. {\*Q%q\*U}. %n, %d. %c: %p. {Available: %w.}';

# 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";
			if (defined $refs[$i]{a}) {
				$refs[$i]{a} = "; $def";
			} else {
				$refs[$i]{a} = $def;
			}
			$author_last = 1;
			next;
		} elsif ($fld =~ /[cdnpqtwy]/) {
			$refs[$i]{$fld} = $def;
			$author_last = 0;
			next;
		}
	}

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

$i = -1;
for (@lines) {
	$i++;
	# 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;

		# replace '' with preceding word
		for (@words) {
			if ($_ eq "''") {
				$_ = $lines[$i-1];
				$_ =~ s/^.*\s(\S+)\s*$/$1/;
			}
		}

		for (my $i = 0; $i < scalar @refs; $i++) {
			$points[$i] = 0 if not defined $points[$i];
			$points[$i] += 100 if likeness($refs[$i]{a}, @words);
			$points[$i] += 50 if likeness($refs[$i]{y}, @words);
			$points[$i] += 1 * likeness($refs[$i]{t}, @words);
			$points[$i] += 1 * likeness($refs[$i]{q}, @words);
			$winner = $i if $points[$i] > $points[$winner];
		}

		if (not defined $winner) {
			print STDERR "Error: Reference '$def' could not be resolved.\n";
			exit 1;
		}
		if ($points[$winner] < 11) {
			print STDERR "Warning: Guessing that reference '$def' refers to " . fmt($format_full, $winner) . ".\n";
		}

		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, 1) . "\n";

		next;
	}

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

sub fmt {
	my ($fmt, $i, $full) = @_;
	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' and not $full;
			$fmt =~ s/\{([^{}%]*)%\Q$fld\E([^{}]*)}/$1$val$2/g;
			$fmt =~ s/%\Q$fld\E/$val/g;
		} else {
			no warnings;
			$fmt =~ s/[.(]?\{([^{}%]*)%\Q$fld\E([^{}]*)}[.,:;)]?//g;
			$fmt =~ s/[.(]?%\Q$fld\E[.,:;)]?//g;
		}
	}
	$fmt =~ s/ +/ /g;
	#$fmt =~ s/([(]) +/$1/;
	#$fmt =~ s/ +([.,)])/$1/;
	$fmt =~ s/^ *//;
	$fmt =~ s/ *$//;
	return $fmt;
}

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

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