bitstring-fitness

#!/usr/bin/env perl

=head1 NAME

bitstring-fitness - Pitch alteration and rhythmic variation

=head1 SYNOPSIS

 perl bitstring-fitness [--options]

=head2 EXAMPLE

 perl bitstring-fitness --alteration=3 --rhythm --velocity --diatonic
 perl bitstring-fitness --diatonic --rhythm --velocity --bits 32 --durations 'qn tqn'

=head1 DESCRIPTION

Mutate bitstrings representing pitch, duration, and velocity.

=cut

use strict;
use warnings;

use Algorithm::Evolutionary::Individual::BitString;
use Getopt::Long;
use Pod::Usage;
use List::Util qw( shuffle );
use Music::AtonalUtil;
use MIDI::Simple;

my $HELP       = 0;
my $MAN        = 0;
my $BEATS      = 15;        # Maximum possible durations
my $BITS       = 11;        # Possible pitches
my $DEGREES    = 7;         # Constraining scale
my $ALTERATION = 0;         # Post mutation phrase alteration factor
my $PHRASES    = 2;         # Number of times to play the "melody"
my $RHYTHM     = 0;         # Use rhythmic variations
my $VELOCITY   = 0;         # Use velocity variation
my $TEMPO      = 600_000;   # Miliseconds
my $PATCH      = 0;         # The MIDI patch to use
my $DIATONIC   = 0;         # Use diatonic notes, rather than chromatic
my $DURATIONS  = 'tsn sn ten dsn en tqn den qn thn dqn hn dhn wn';
GetOptions (
    'help|?'       => \$HELP,
    'man'          => \$MAN,
    'beats=i'      => \$BEATS,
    'bits=i'       => \$BITS,
    'degrees=i'    => \$DEGREES,
    'alteration=i' => \$ALTERATION,
    'phrases=i'    => \$PHRASES,
    'rhythm'       => \$RHYTHM,
    'velocity'     => \$VELOCITY,
    'tempo=i'      => \$TEMPO,
    'patch=i'      => \$PATCH,
    'diatonic'     => \$DIATONIC,
    'durations=s'  => \$DURATIONS,
) or die( "Error in command line arguments\n" );

pod2usage(1)
    if $HELP;
pod2usage( -exitval => 0, -verbose => 2 )
    if $MAN;

$DURATIONS = [ split /(?:\s+|\s*,\s*)/, $DURATIONS ];

# Evolve a pitch bitstring.
my $ae_str = ae( type => 'pitch', bits => $BITS );

# Turn the bitstring into a proper pitch set
my $pitches = bits2pitches($ae_str);

# Pass the pitches through alteration
my $altered = alteration($pitches);

$pitches = [ @$pitches, @$altered ];

# What have we now?
print '(', join( ',', @$pitches ), ')', "\n";

my $rhythms;

if ( $RHYTHM ) {
    # Evolve a rhythm bitstring.
    $ae_str = ae( type => 'rhythm', bits => $BEATS );

    # Turn the bitstring into a proper duration set
    $rhythms = bits2rhythms( $ae_str, $pitches );
}

my $velocities;
if ( $VELOCITY ) {
    $velocities = bits2velocities($pitches);
}

process_midi( $pitches, $rhythms, $velocities );

=head1 FUNCTIONS

=head2 process_midi()

Convert a given pitch set into MIDI note names (e.g. A Ds E) and a given
rhythm set into MIDI durations (e.g. qn, sn, den), then write the score to an
*.mid file.

=cut

sub process_midi {
    my ( $pitches, $rhythms, $velocities ) = @_;

    # Convert the pitch-set to MIDI note names
    my %name  = int2name();
    # Setup the MIDI score
    my $score = set_score();

    # Repeat!
    for ( 1 .. $PHRASES ) {
        # Add a note to the score for each pitch
        my $i = 0;
        for my $pitch ( @$pitches ) {
            # Add a duration from the given rhythms or default
            my $duration = $RHYTHM ? $rhythms->[$i] : 'en';

            # Add a velocity from the given velocities or default
            my $velocity = $VELOCITY ? $velocities->[$i] : 'V96';

            # Add the note!
            $score->n( $duration, $name{$pitch} );

            # Increment the phrase counter
            $i++;
        }
    }

    $score->write_score( $0 . '.mid' );
}

=head2 mutate()

Toggle a single bit at a time, of a bitstring, until a fit is found.

=cut

sub mutate {
    my $species = shift;
    my %args    = @_;

    my $mutation = 0;
    # Find a fit...
    while ( not is_fit( $species->{_str}, %args ) ) {
        $mutation++;

        # Get a bit to twiddle
        my $n = int rand $BITS;
        warn "\t$mutation. N:$n\n";

        # Toggle the bit in the string
        $species->Atom( $n, ($species->Atom($n) ? 0 : 1) );
    }
}

=head2 alteration()

Apply randomized L<Music::AtonalUtil> thematic variations to pitches.

=cut

sub alteration {
    my $pitches = shift;

    # Apply pitch set rules:
    @$pitches = shuffle( @$pitches );

    my $atu = Music::AtonalUtil->new;
    my $altered = $atu->transpose( 0, $pitches );

    # Post mutation, phrase alterations
    my $funct = {
        invert     => sub { my $x = shift; $atu->invert( $x, $altered ) },
        retrograde => sub { $atu->retrograde( @$pitches ) },
        rotate     => sub { my $x = shift; $atu->rotate( $x, $altered ) },
        transpose  => sub { my $x = shift; $atu->transpose( $x, $altered ) },
    };

    # Choose a random function and execute it with the given alteration factor
    my $x = $ALTERATION
        ? $ALTERATION
        : int( rand 3 ) + 2;
    my $alteration = ( keys %$funct )[ rand keys %$funct ];
    print "Alteration: $alteration by $x\n";
    $altered = $funct->{$alteration}->($x);

    # Constrain to the DEGREES
    for my $alt ( @$altered )
    {
        $alt %= $DEGREES;
    }

    return $altered;
}

=head2 is_fit()

Construct a fitness profile for a given bitstring and return 1 if it is fit or
0 if not.

=cut

sub is_fit {
    my $str  = shift;
    my %args = @_;

    my $is_fit = 0;

    if ( $args{type} eq 'pitch' ) {
        # Count the number of zeros and ones
        my $zeros =()= $str =~ /0/g;
        my $ones  =()= $str =~ /1/g;
    #    warn "Z,O:$zeros,$ones\n";
        # There should be more pitches (ones) than zeros
        $is_fit = $zeros < (2 * $args{bits} / 3) && $ones > ($args{bits} / 2)
            ? 1 : 0;
        return 0 unless $is_fit;

        # Include consonant pitches
    #    $is_fit = substr( $str, 0, 1 ) ? 1 : 0;
        $is_fit = substr( $str, 4, 1 )  || substr( $str, 5, 1 )
               || substr( $str, 7, 1 )  || substr( $str, 9, 1 )  || substr( $str, 11, 1 )
               || substr( $str, 12, 1 ) || substr( $str, 16, 1 ) || substr( $str, 17, 1 )
               || substr( $str, 19, 1 ) || substr( $str, 21, 1 ) || substr( $str, 23, 1 )
            ? 1 : 0;
        return 0 unless $is_fit;

        # Do not allow clusters of more than three pitches
        $is_fit = $str =~ /1{3,}/ ? 0 : 1;
    }
    else { # Rhythmic fitness profile
        # Count the number of ones
        my $ones =()= $str =~ /1/g;
        # There should be at least 1/2 durations
        $is_fit = $ones > ($args{bits} / 2) ? 1 : 0;
        return 0 unless $is_fit;

        # Include common durations (e.g. sn, en, qn)
        $is_fit = substr( $str, 1, 1 ) || substr( $str, 5, 1 ) || substr( $str, 9, 1 )
            ? 1 : 0;
        return 0 unless $is_fit;

        # Do not allow clusters of more than three durations
        $is_fit = $str =~ /1{3,}/ ? 0 : 1;
    }

    return $is_fit;
}

=head2 bits2rhythms()

For each bit, select a corresponding MIDI duration as the rhythm set.  Then
select a random element from this list for each pitch.

=cut

sub bits2rhythms {
    # Convert 1001001000101 form to [tsn dsn tqn thn ddqn] set form
    my $bitstring = shift;
    my $pitches   = shift;

    my @bitrhythms;
    my $i = 0;
    for my $bit ( split //, $bitstring ) {
        push @bitrhythms, $DURATIONS->[ $i % @$DURATIONS ] if $bit;
        $i++;
    }

    my @rhythms;
    for ( @$pitches ) {
        # TODO Be more clever.
        push @rhythms, $bitrhythms[ int rand @bitrhythms ];
    }

    return \@rhythms;
}

=head2 bits2pitches()

For each bit, select a pitch integer.

=cut

sub bits2pitches {
    # Convert 1001001000101000 form to [0,3,6,10,12] set form
    my $bitstring = shift;

    my $pitches = [];

    my $i = 0;
    for my $bit ( split //, $bitstring ) {
        push @$pitches, $i % $DEGREES if $bit;
        $i++;
    }

    return $pitches;
}

=head2 bits2velocities()

For each pitch, select a velocity.

=cut

sub bits2velocities {
    my $pitches = shift;

    my $velocities = [];
    my $velo = 96;

    for my $p (@$pitches) {
        # Velocity is randomly up-down or stationary
        if ( int( rand 3 ) == 1 ) {
            # Decrease
            $velo--;
        }
        elsif ( int( rand 3 ) == 2 ) {
            # Increase
            $velo++;
        }

        push @$velocities, 'V' . $velo;
    }

    return $velocities;
}

=head2 int2name()

Convert pitch integers into MIDI note names.

=cut

sub int2name {
    # Convert integer pitch notation into MIDI note names
    my %name;
    my @notes;

    # Use the diatonic scale notes if requested
    if ($DIATONIC) {
        @notes = qw( C D E F G A B );
    }
    else {
        @notes = qw( C Cs D Ds E F G Gs A As B );
    }

    my $int = -@notes;

    for my $octave ( 3, 4, 5, 6 ) {
        for my $note (@notes) {
            $name{$int} = $note . $octave;
#warn "N:$int $name{$int} = $note . $octave\n";
            $int++;
        }
    }

    return %name;
}

=head2 set_score()

Set up the MIDI score.

=cut

sub set_score {
    my %conf = (
        tempo     => $TEMPO,
        volume    => 100,
        signature => 4,
        channel   => 1,
        patch     => $PATCH,
        octave    => 4,
        kit       => 9,
        pad       => 38,
    );

    my $score = MIDI::Simple->new_score();

    $score->Volume($conf{volume});
    $score->set_tempo($conf{tempo});

    # Lead-in
#    $score->Channel($conf{kit});
#    $score->n($conf{unit}, $conf{pad}) for 1 .. $conf{signature};

    $score->patch_change($conf{channel}, $conf{patch});
    $score->Channel($conf{channel});
    $score->Octave($conf{octave});

    return $score;
}

=head2 ae()

Mutate a bitstring!

=cut

sub ae {
    my %args = @_;

    my $ae = Algorithm::Evolutionary::Individual::BitString->new( $args{bits} );

    print ucfirst( $args{type} ), " seed: $ae->{_str}\n";

    mutate( $ae, %args );

    print "Final: $ae->{_str}\n";

    return $ae->{_str};
}

__END__
# Use 11 bits to mutate into a melody
# Set tempo in milliseconds
# Use MIDI patch 1 (Acoustic Grand Piano)
# Use rhythmic variation
# Constrain the rhythmic variation to a subset
# Use the diatonic (as opposed to the chromatic) notes

> perl bitstring-fitness --bits=11 --tempo=300_000 --patch=1 --rhythm --diatonic