#!/usr/bin/perl
#
# https://toroid.org/ioc-vs-clements
# Copyright 2007 Abhijit Menon-Sen <ams@toroid.org>
#
# This program takes a CSV file containing the IOC common and scientific
# names, the Clements common and scientific names, and (though it is not
# currently used) the first two characters of the range, and produces a
# genus-wise summary of the changes between the two checklists.
#
# Many thanks to Dave Sargeant and David Matson for cross-referencing
# the two source checklists. (Their spreadsheet is now available for
# download on worldbirdnames.org.)

%G = ();

# First, we build a genus-wise list of changes from the CSV input.

while (<>) {
    chomp;
    next if /^#/ || /^\s*$/;

    # Fields: IOC scientific name, IOC common name, Clements scientific
    # name, Clements common name, Range.
    my ( $is, $ic, $cs, $cc, $ra ) =
        map { y/"//d; $_ }
            split /\s*,\s*/, $_, 5;

    # Separate the genus from the specific name.
    my ( $isg, $iss ) = split / /, $is;
    my ( $csg, $css ) = split / /, $cs;

    # If the IOC and Clements list both have the same entry, then we
    # just count the species under its genus and do nothing else.

    if ( $is eq $cs and $ic eq $cc ) {
        $G{$isg}->{species}++;
    }

    # If the IOC list contains an entry that has no corresponding entry
    # in the Clements list, then we count that species in the total for
    # the genus, and note that it was only in the IOC list.

    elsif ( $cs eq "" ) {
        $G{$isg}->{species}++;
        $G{$isg}->{i_species}++;
    }

    # If the IOC list is missing an entry that is in the Clements list,
    # we count that as a new species in the Clements list, leaving the
    # total for the genus unchanged.

    elsif ( $is eq "" ) {
        $G{$csg}->{c_species}++;
    }

    # Otherwise we'll identify the changes to each individual component
    # of the entry (genus, specific name, common name).

    else {
        $G{$isg}->{species}++;

        my $a = [];
        my @c = ();

        # If the genus changes, we need to remember that, and also
        # increase the "Clements count" for the new genus. For any
        # other changes, we just need to record the change.

        if ( $isg ne $csg ) {
            push @c, 'g';
            push @$a, $csg;
            $G{$csg}->{c_species}++;
        }

        if ( $iss ne $css ) {
            # We should identify and tag gender changes
            # (e.g. pennatus->pennata) here.
            push @c, 's';
        }

        if ( $ic ne $cc ) {
            # We should identify and tag "trivial" renames
            # (e.g. Grey->Gray) here.
            push @c, 'c';
        }

        # We'll identify changes by tags like g_c for a change to genus
        # and common name, g_s for a change to genus and specific name,
        # and so on. The rest of @$a consists of relevant arguments for
        # each change in the tag.

        unshift @$a, join "_", @c;
        push @{$G{$isg}->{changes}}, $a;
    }
}

# Now we walk through the list, summarising changes for each genus.

foreach my $g ( sort keys %G ) {
    my $r = $G{$g};
    my @changes = @{$r->{changes}};

    next if @changes == 0 && $r->{i_species} == 0 && $r->{c_species} == 0;

    print $g, ":\n";

    $r->{species} ||= 0;
    if ( $r->{species} != 0 ) {
        print "    ", $r->{species}, " species in IOC list.\n";
    }

    my $i_species = $r->{i_species};
    if ( $i_species != 0 ) {
        print "    ", $i_species, " species not in Clements list.\n";
    }

    my $c_species = $r->{c_species};
    if ( $c_species != 0 ) {
        print "    ", $c_species, " species only in Clements list.\n";
    }

    foreach my $c ( 'g', 'g_c', 'g_s', 'g_s_c' ) {
        my %changes;
        foreach my $x ( grep { $_->[0] eq $c } @changes ) {
            $changes{$x->[1]}++;
        }
        foreach my $k ( keys %changes ) {
            print "    ", $changes{$k}, " species reassigned to genus $k";
            if ( $c =~ /_/ ) {
                my @x;
                push @x, 'specific' if $c =~ /_s/;
                push @x, 'common' if $c =~ /_c/;
                print " with new ", join( " and ", @x ), " name";
                print "s" if @x > 1 || $changes{$k} > 1;
            }
            print ".\n";
        }
    }

    foreach my $c ( 's', 'c', 's_c' ) {
        my $changes = grep { $_->[0] eq $c } @changes;
        next if $changes == 0;

        my @x;
        push @x, 'specific' if $c =~ /^s/;
        push @x, 'common' if $c =~ /c$/;

        print "    ", $changes, " species given new ",
              join( " and ", @x ), " name";
        print "s" if @x > 1 || $changes > 1;
        print ".\n";
    }

    print "\n";
}