#!/usr/bin/perl

use v5.12;
use warnings;

# Default configuration

my %fmt;
$fmt{r} = '%a {(%y)}.  {\fI%t\fR}.  {\*Q%q\*U}.  %n, %d.  %c: %p.  {Available: %w}';
$fmt{f} = "\n(%A %y)";
$fmt{x} = "\n(%y)";

# Internal variables

my @lines;
my @refs;

# First pass (process formats)

while (<>) {
	chomp;

	# Format specification
	if (/^\.F([rfx])(\\?) +(.*)/) {
		my ($type, $join, $rest) = ($1, $2, $3);
		$rest = "\n$rest" if not $join;
		while (not eof()) {
			last if not $rest =~ s/\\$//;
			$rest .= "\n" . <>;
			chomp $rest;
		}
		chomp $rest;
		$fmt{$type} = $rest;
		next;
	}

	push @lines, $_;
}

# Second (backwards) pass (process reference definitions and inline citations)

my $inlref = 0;
my @r = ();
my $refblock = 0;
my $refi = -1;
for (my $i = $#lines; $i >= 0; $i--) {
	$_ = $lines[$i];
	chomp;

	# Reference definition
	if (/^\.R([acdmnpqtwy]) +(.*)/) {
		my ($fld, $rest) = ($1, $2);

		$refi++ if not $refblock; # new reference
		$refblock = 1;

		if ($fld eq 'a') {
			push @{$refs[$refi]{a}}, $rest;
		} else {
			$refs[$refi]{$fld} = $rest;
		}
		next;
	} elsif ($refblock) {
		# print formatted reference definition
		push @r, fmt($fmt{r}, $refi) . "\n";
	}

	# Inline citation
	if (/^\.R([fx]) +(.*)/) {
		my ($fld, $rest) = ($1, $2, $3);

		$inlref = 1;

		# find potential prefix/suffix
		my ($suffix, $prefix);
		if ($rest =~ s/ ([.,?!:;\])]) ?([\[(])?$//) {
			($suffix, $prefix) = ($1, $2);
		}

		my @words = split /\s/, $rest;

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

		# find matching definition
		my $winner = 0;
		my @points;
		for (my $i = 0; $i < scalar @refs; $i++) {
			my $a = join '; ', @{$refs[$i]{a}} if exists $refs[$i]{a};
			$points[$i] = 0 if not defined $points[$i];
			$points[$i] += 100 if likeness($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 '$rest' could not be resolved.\n";
			exit 1;
		}

		if ($points[$winner] < 150) {
			my $f = fmt("%a, %y", $winner);
			print STDERR "Warning: Guessing that reference '$rest' refers to $f; ";
			if ($points[$winner] >= 100) {
				print STDERR "only author matches.\n";
			} elsif ($points[$winner] >= 50) {
				print STDERR "only date matches.\n";
			} else {
				print STDERR "only title matches (level = $points[$winner]).\n";
			}
		}

		# format reference
		my $fmt;
		if ($fld eq 'f') {
			$fmt = fmt($fmt{f}, $winner);
		} else {
			$fmt = fmt($fmt{x}, $winner);
		}

		# print formatted reference
		my $n = index($fmt, "\n");
		$prefix = '' if not $prefix;
		$suffix = '' if not $suffix;
		push @r, "\n";
		if ($n != 0) {
			push @r, substr($fmt, index($fmt, "\n"));
			push @r, $prefix . substr($fmt, 0, index($fmt, "\n")) . "$suffix";
		} else {
			push @r, "$prefix$fmt$suffix";
		}
		next;
	}

	# non-rf line

	# whether or not to include a final newline depends on the
	# format of the inline reference on the line below
	if (!$inlref) {
		push @r, "\n";
	}

	push @r, $_;

	$refblock = 0;
	$inlref = 0;
}

# Third pass (print the result)
for (my $i = $#r; $i >= 0; $i--) {
	print $r[$i];
}

# Format reference at $i after $fmt
sub fmt {
	my ($fmt, $i) = @_;
	my %ref = %{$refs[$i]};
	for my $fld (split //, 'Aacdmnpqtwy') {
		if ($ref{lc $fld}) { # interpolate
			no warnings;
			my $val = $ref{lc $fld};
			$val = join '; ', @$val if lc $fld eq 'a';
			$val = fmtl($val) if $fld eq 'A';
			if ($val =~ /[.,?!]$/) { # fix double punctuation
				next if $fmt =~ s/\{([^{}%]*)%\Q$fld\E[.,?!]?([^{}]*)}/$1$val$2/g;
				$fmt =~ s/%\Q$fld\E[.,?!]?/$val/g
			} else {
				next if $fmt =~ s/\{([^{}%]*)%\Q$fld\E([^{}]*)}/$1$val$2/g;
				$fmt =~ s/%\Q$fld\E/$val/g
			}
		} else { # remove escape syntax after failed interpolation
			no warnings;
			next if $fmt =~ s/\{([^{}%]*)%\Q$fld\E([^{}]*)}[.,?!:;]?//g;
			$fmt =~ s/%\Q$fld\E[.,?!:;]?//g;
		}
	}

	# strip superfluous spaces
	$fmt =~ s/^ *//;
	$fmt =~ s/ *$//;
	$fmt =~ s/([^.]) +/$1 /g;
	$fmt =~ s/([[(]) /$1/g;
	$fmt =~ s/ ([\])])/$1/g;
	$fmt =~ s/ ([.,])/$1/g;
	# fix superfluous period after quote
	$fmt =~ s/([.,?!]")\./$1/g;
	$fmt =~ s/([.,?!]\\\*U)\./$1/g;
	return $fmt;
}

# Remove forenames from a given string of authors
sub fmtl {
	my ($a) = @_;
	my $r;
	for my $name (split /; /, $a) {
		if ($name =~ /(.*?),/) {
			$r .= ", $1";
		} else {
			$name =~ s/(.*?)\s/$1/;
			return ", $name";
		}
	}
	$r =~ s/^, //;
	return $r;
}

# Calculate a basic likeness value a string and a list of strings
sub likeness {
	my ($string, @strings) = @_;
	my $r = 0;
	return 0 if not defined $string;
	for (@strings) {
		$r += 1 if index(lc $string, lc $_) != -1;
	}
	return $r;
}