ai-genetic-pro

#!/usr/bin/env perl
use strict;
use warnings;

# Evolve a set of pitches where adjacents must be between 2 and 5 half-steps.
# These pitches are then fed into contrapuntal transformations
# and the results are appended to this "melody."


use AI::Genetic::Pro ();
use Data::Dumper::Compact qw(ddc);
use MIDI::Util qw(setup_score);
use Music::AtonalUtil ();
use Music::Scales qw(get_scale_MIDI);

my @notes = get_scale_MIDI('C', 4, 'major'); # 60, 62...
my $base = 60;

my $ga = AI::Genetic::Pro->new(
    -fitness         => \&fitness,        # fitness function
    -terminate       => \&terminate,      # terminate function
    -type            => 'combination',    # type of chromosomes
    -population      => 100,              # population
    -crossover       => 0.9,              # probab. of crossover
    -mutation        => 0.05,             # probab. of mutation
    -parents         => 2,                # number  of parents
    -selection       => ['Roulette'],     # selection strategy
    -strategy        => ['PMX'],          # crossover strategy
    -cache           => 1,                # cache results
    -history         => 1,                # remember best results
    -preserve        => 1,                # remember the bests
    -variable_length => 0,                # turn variable length OFF
);

$ga->init(\@notes);

$ga->evolve(0);

# Perform gymnastics with the pitches
my $pitches = $ga->as_array($ga->getFittest);
my $altered = [ map { $_ + $base } @{ alteration( [ map { $_ - $base } @$pitches ] ) } ];
$pitches = [ @$pitches, @$altered ];
print ddc($pitches);
#exit;

process_midi($pitches);

sub calc {
    my ($ar) = @_;
warn(__PACKAGE__,' ',__LINE__," MARK: @$ar\n");
    my $calc = 0;
    # Adjacent elements must be within ...
    for my $n ( 0 .. @$ar - 2 ) {
        my $v = abs( $ar->[$n] - $ar->[$n + 1] );
        $calc++ if $v < 2 || $v > 5;
    }
warn "\t = $calc\n";
    return $calc;
}

my $i = 0;
sub fitness {
    my ($ga, $chromosome) = @_;
warn(__PACKAGE__,' ',__LINE__," MARK: fitness() ",$i++,"\n");
#warn(__PACKAGE__,' ',__LINE__," MARK: ",ddc([$ga->as_array($chromosome)]));
    return calc([ $ga->as_array($chromosome) ]);
}

sub terminate {
    my ($ga) = @_;
    my $result = calc([ $ga->as_array($ga->getFittest) ]);
warn(__PACKAGE__,' ',__LINE__," MARK: ",$result,"\n");
    return $result <= 1 ? 1 : 0;
}

sub process_midi {
    my ($pitches) = @_;
    my $score = setup_score();
    for my $p (@$pitches) {
        $score->n('qn', $p);
    }
    $score->write_score($0 . '.mid');
}

sub alteration {
    my $pitches = shift;

    my $atu = Music::AtonalUtil->new;

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

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

    return $altered;
}