File Coverage

blib/lib/Music/BachChoralHarmony.pm

Criterion	Covered	Total	%
statement	151	153	98.6
branch	77	86	89.5
condition	18	23	78.2
subroutine	13	13	100.0
pod	3	3	100.0
total	262	278	94.2

package Music::BachChoralHarmony;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Parse the UCI Bach choral harmony data set

our $VERSION = '0.0412';

use Moo;
use strictures 2;

use Text::CSV ();
use File::ShareDir qw/ dist_dir /;
use List::Util qw/ any /;

use namespace::clean;


has data_file => (
    is      => 'ro',
    default => sub { dist_dir('Music-BachChoralHarmony') . '/jsbach_chorals_harmony.data' },
);


has key_title => (
    is      => 'ro',
    default => sub { dist_dir('Music-BachChoralHarmony') . '/jsbach_BWV_keys_titles.txt' },
);


has data => (
    is       => 'rw',
    init_arg => undef,
    default  => sub { {} },
);


sub parse {
    my ($self) = @_;

    # Collect the key signatures and titles
    my %data;

    open my $fh, '<', $self->key_title
        or die "Can't read ", $self->key_title, ": $!";

    while ( my $line = readline($fh) ) {
        chomp $line;
        next if $line =~ /^\s*$/ || $line =~ /^#/;
        my @parts = split /\s+/, $line, 4;
        $data{ $parts[0] } = {
            bwv   => $parts[1],
            key   => $parts[2],
            title => $parts[3],
        };
    }

    close $fh;

    # Collect the events
    my $csv = Text::CSV->new( { binary => 1 } )
        or die "Can't use CSV: ", Text::CSV->error_diag;

    open $fh, '<', $self->data_file
        or die "Can't read ", $self->data_file, ": $!";

    my $progression;

    # 000106b_ 2 YES  NO  NO  NO YES  NO  NO YES  NO  NO  NO  NO E 5  C_M
    while ( my $row = $csv->getline($fh) ) {

        ( my $id = $row->[0] ) =~ s/\s*//g;

        my $notes = '';

        for my $note ( 2 .. 13 ) {
            $notes .= $row->[$note] eq 'YES' ? 1 : 0;
        }

        ( my $bass   = $row->[14] ) =~ s/\s*//g;
        ( my $accent = $row->[15] ) =~ s/\s*//g;
        ( my $chord  = $row->[16] ) =~ s/\s*//g;

        $progression->{$id}{key}   ||= $data{$id}{key};
        $progression->{$id}{bwv}   ||= $data{$id}{bwv};
        $progression->{$id}{title} ||= $data{$id}{title};

        my $struct = {
            notes  => $notes,
            bass   => $bass,
            accent => $accent,
            chord  => $chord,
        };

        push @{ $progression->{$id}{events} }, $struct;
    }

    $csv->eof or die $csv->error_diag;
    close $fh;

    $self->data($progression);

    return $self->data;
}


sub search {
    my ( $self, %args ) = @_;

    my %results = ();

    if ( $args{id} ) {
        my @ids = split /\s+/, $args{id};

        for my $id ( @ids ) {
            $results{$id} = $self->data->{$id};
        }
    }

    if ( $args{key} ) {
        my @iter = keys %results ? keys %results : keys %{ $self->data };

        my @keys = split /\s+/, $args{key};

        for my $id ( @iter ) {
            if ( $results{$id} ) {
                delete $results{$id}
                    unless any { $_ eq $results{$id}{key} } @keys;
            }
            else {
                $results{$id} = $self->data->{$id}
                    if any { $_ eq $self->data->{$id}{key} } @keys;
            }
        }
    }

    if ( $args{bass} ) {
        %results = $self->_search_param( bass => $args{bass}, \%results );
    }

    if ( $args{chord} ) {
        %results = $self->_search_param( chord => $args{chord}, \%results );
    }

    if ( $args{notes} ) {
        my @iter = keys %results ? keys %results : keys %{ $self->data };

        my $and = $args{notes} =~ /&/ ? 1 : 0;
        my $re  = $and ? qr/\s*&\s*/ : qr/\s+/;

        my @notes = split $re, $args{notes};

        my %index = (
            'C'  => 0,
            'C#' => 1,
            'Db' => 1,
            'D'  => 2,
            'D#' => 3,
            'Eb' => 3,
            'E'  => 4,
            'F'  => 5,
            'F#' => 6,
            'Gb' => 6,
            'G'  => 7,
            'G#' => 8,
            'Ab' => 8,
            'A'  => 9,
            'A#' => 10,
            'Bb' => 10,
            'B'  => 11,
        );

        ID: for my $id ( @iter ) {
            my %and_notes = ();

            my $match = 0;

            for my $event ( @{ $self->data->{$id}{events} } ) {
                my @bitstring = split //, $event->{notes};

                my $i = 0;

                for my $bit ( @bitstring ) {
                    if ( $bit ) {
                        for my $note ( sort @notes ) {
                            if ( defined $index{$note} && $i == $index{$note} ) {
                                if ( $and ) {
                                    $and_notes{$note}++;
                                }
                                else {
                                    $match++;
                                }
                            }
                        }
                    }

                    $i++;
                }
            }

            if ( $and ) {
                if ( keys %and_notes ) {
                    my %notes;
                    @notes{@notes} = undef;

                    my $i = 0;

                    for my $n ( keys %and_notes ) {
                        $i++
                            if exists $notes{$n};
                    }

                    if ( $i == scalar keys %notes ) {
                        $results{$id} = $self->data->{$id};
                    }
                    else {
                        delete $results{$id}
                            if $results{$id};
                    }
                }
            }
            else {
                if ( $results{$id} && $match <= 0 ) {
                    delete $results{$id};
                }
                elsif ( $match > 0 ) {
                    $results{$id} = $self->data->{$id};
                }
            }
        }
    }

    return \%results;
}


sub bits2notes {
    my ( $self, $string, $accidental ) = @_;

    $accidental ||= 'b';

    my @notes = ();

    no warnings 'qw';
    my @positions = qw( C C#|Db D D#|Eb E F F#|Gb G G#|Ab A A#|Bb B );

    my @bits = split //, $string;

    my $i = 0;

    for my $bit ( @bits ) {
        if ( $bit ) {
            my @note = split /\|/, $positions[$i];
            my $note = '';

            if ( @note > 1 ) {
                $note = $accidental eq '#' ? $note[0] : $note[1];
            }
            else {
                $note = $note[0];
            }

            push @notes, $note;
        }

        $i++;
    }

    return \@notes;
}

sub _search_param {
    my ( $self, $name, $param, $seen ) = @_;

    my @iter = keys %$seen ? keys %$seen : keys %{ $self->data };

    my %results = ();

    my $and = $param =~ /&/ ? 1 : 0;
    my $re  = $and ? qr/\s*&\s*/ : qr/\s+/;

    my %notes = ();
    @notes{ split $re, $param } = undef;

    ID: for my $id ( @iter ) {
        my %and_notes = ();

        my $match = 0;

        for my $event ( @{ $self->data->{$id}{events} } ) {
            for my $note ( keys %notes ) {
                if ( $note eq $event->{$name} ) {
                    if ( $and ) {
                        $and_notes{$note}++;
                    }
                    else {
                        $match++;
                    }
                }
            }
        }

        if ( $and ) {
            if ( keys %and_notes ) {
                my $i = 0;

                for my $n ( keys %and_notes ) {
                    $i++
                        if exists $notes{$n};
                }

                if ( $i == scalar keys %notes ) {
                    $results{$id} = $self->data->{$id};
                }
                else {
                    delete $results{$id}
                        if $results{$id};
                }
            }
        }
        else {
            if ( $results{$id} && $match <= 0 ) {
                delete $results{$id};
            }
            elsif ( $match > 0 ) {
                $results{$id} = $self->data->{$id};
            }
        }
    }

    return %results;
}

1;

__END__