As part of side-project (inspired by this) to breed Irish jigs (just the 'A' part to start off with), I had the need for a large, random but still 'genetically strong' population of tunes - I was getting bored waiting for 100 generations of random notes to start getting interesting.

To that end, here's a little Markov-chain routine that analyses as many tunes as I could be bothered to type in and then prints "random diddly". The LENGTH constant can be used to refine the length of the chain 'key' - 1 will just pick single random weighted notes from a flat data structure, whereas a setting of 8 or 9 will duplicate an existing tune near-exactly (although some of the more 'symmetrical' tunes) can wrap round a few times before stopping). A setting of 3 or 4 can produce some quite interesting tunes - not structured, but then that's what the breeding will attempt to achieve.

When I get a chance, I'll write a ABC P::RD module so I don't have to type in the data (or play back the notes off the screen on my penny-whistle :) ) - unless anybody can point me in the direction of an existing one.

All suggestions are as ever welcome. 
#!/usr/bin/perl

###########################################
# Variable Length Markov Diddly. 
###########################################

use strict;
use constant LENGTH => 4;                            # length of patte
+rn key

my %probs;                                            # probabilities 
+of next note

while (<DATA>) {                                    # read the existin
+g tunes...
    chomp;
    my @line = split /,/;
    my @notes = ("START") x (LENGTH);                # cyclic buffer
    while (@line) {
        shift (@notes);
        push @notes, shift(@line).",".shift(@line); # "note,length"
        $probs{key(@notes)}{$notes[$#notes]}++;
    }
    shift (@notes);
    $probs{key(@notes)}{"END"}++;
}

my @notes = ("START") x LENGTH;
do {
    shift(@notes);
    my %next = %{$probs{key(@notes)}};                # array of probs
    my @next = map {($_) x $next{$_}} keys %next;    # 1 entry per 'pr
+ob'
    push @notes, $next[int(rand(@next))];
    print "$notes[$#notes] " unless ($notes[$#notes] eq "END");
} while ($notes[$#notes] ne "END");

sub key {return join("",@_[0..LENGTH-2]);}            # make space-sep
+arated key

# a bunch of common session tunes (plus one of mine <g>)
__DATA__
e2,4,e2,2,b2,2,e2,2,b2,2,e2,2,e2,2,b2,2,a2,2,fs2,2,d2,2,e2,4,e2,2,b2,4
+,cs3,2,d3,2,cs3,2,b2,2,a2,2,fs2,2,d2,2,e2,4,e2,2,b2,2,e2,2,b2,2,e2,2,
+e2,2,b2,2,a2,2,fs2,2,d2,2,g2,4,g2,2,fs2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs
+2,2,e2,2,d2,2
d2,2,g2,2,g2,2,b2,2,g2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,g2,2,e3,2,g3,2,
+e3,2,d3,2,b2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,e2,2,d2,2,g2,2,g2,2,b2,2
+,g2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,g2,2,e3,2,g3,2,e3,2,d3,2,b2,2,g2,
+2,a2,2,g2,2,fs2,2,g2,6
d2,4,d2,2,a2,6,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,d2,4,d2,2,a2,6,b2,2,a2,2,
+g2,2,e2,2,g2,2,e2,2,d2,4,d2,2,a2,6,b2,2,a2,2,g2,2,a2,2,b2,2,c3,2,d2,2
+,c3,2,b2,2,c3,2,b2,2,a2,2,b2,2,a2,2,g2,2,e2,2,g2,2,e2,2
d3,2,e3,2,d3,2,b2,4,g2,2,a2,4,g2,2,e2,4,d2,2,g2,4,g2,2,g2,2,a2,2,b2,2,
+d3,4,b2,2,a2,6,d3,2,e3,2,d3,2,b2,4,g3,2,fs2,4,e3,2,c3,4,e3,2,d3,2,e3,
+2,d3,2,c3,2,b2,2,a2,2,g2,12
b2,2,g2,2,g2,2,d2,2,g2,2,g2,2,b2,2,g2,2,b2,2,d3,2,c3,2,b2,2,c3,2,a2,2,
+a2,2,fs2,2,a2,2,a2,2,c3,2,a2,2,c3,2,e3,2,d3,2,c3,2,b2,2,g2,2,g2,2,d2,
+2,g2,2,g2,2,b2,2,g2,2,b2,2,d3,2,c3,2,b2,2,c3,2,b2,2,c3,2,a2,2,d3,2,c3
+,2,b2,2,g2,2,g2,2,g2,2,d3,2,c3,2
fs2,4,b2,2,b2,2,cs3,2,d3,2,cs3,4,a2,2,a2,2,b2,2,cs3,2,d3,4,b2,2,b2,2,c
+s3,2,d3,2,e3,2,fs3,2,e3,2,d3,2,cs3,2,b2,2,fs2,4,b2,2,b2,2,cs3,2,d3,2,
+cs3,4,a2,2,a2,2,b2,2,cs3,2,d3,2,cs3,2,d3,2,e3,2,d3,2,e3,2,fs3,2,b2,2,
+b2,2,b2,6
a2,2,fs2,2,a2,2,a2,2,fs2,2,a2,2,b2,2,g2,2,b2,2,b2,2,g2,2,b2,2,a2,2,fs2
+,2,a2,2,a2,2,d3,2,e3,2,fs3,2,e3,2,d3,3,b2,2,d3,2,b2,2,a2,2,fs2,2,a2,2
+,a2,2,fs2,2,a2,2,b2,2,g2,2,b2,2,b2,2,g2,2,b2,2,d3,2,e3,2,fs3,2,a3,2,f
+s3,2,e3,2,fs3,2,b2,2,b2,3,b2,2,d3,2,b2,2
a2,2,d2,2,d2,2,b2,2,d2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,
+g2,2,fs2,2,g2,2,fs2,2,g2,2,e2,2,fs2,2,g2,2,a2,2,d2,2,d2,2,b2,2,d2,2,d
+2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs2,2,g2,12
e2,2,fs2,2,e2,2,b2,4,b2,2,b2,2,a2,2,fs2,2,d3,6,e2,2,fs2,2,e2,2,b2,4,b2
+,2,b2,2,a2,2,fs2,2,fs2,4,e2,2,e2,2,fs2,2,e2,2,b2,4,b2,2,b2,2,a2,2,fs2
+,2,d3,6,b2,2,cs3,2,d3,2,e3,4,b2,2,b2,2,a2,2,fs2,2,fs2,4,e2,2
d2,4,a2,2,fs2,4,a2,2,d2,4,a2,2,fs2,4,a2,2,d3,4,e3,2,fs3,4,e3,2,d3,4,cs
+3,2,b2,4,a2,2,e3,6,fs3,6,g3,6,fs3,6,e3,4,d3,2,cs3,4,b2,2,a2,2,b2,2,a2
+,2,g2,2,fs2,2,e2,2
d2,4,e2,2,fs2,4,g2,2,a2,4,b2,2,a2,4,fs2,2,a2,4,b2,2,a2,4,fs2,2,a2,4,b2
+,2,a2,4,fs2,2,d2,4,e2,2,fs2,4,g2,2,a2,4,b2,2,a2,4,d3,2,cs3,4,b2,2,a2,
+4,fs2,2,d2,12
g2,2,g2,2,g2,2,g2,6,g2,2,g2,2,g2,2,g2,4,d3,2,b2,4,g2,2,b2,4,d3,2,g3,4,
+d3,2,b2,4,g2,2,d2,2,d2,2,d2,2,d2,6,d2,2,d2,2,d2,2,d2,4,a2,2,fs2,4,d2,
+2,fs2,4,a2,2,c3,4,a2,2,fs2,4,d2,2
a2,6,a2,6,a2,2,fs2,2,d3,2,a2,2,fs2,2,d2,2,g2,6,g2,6,g2,2,e2,2,fs2,2,g3
+,2,fs2,2,e2,2,a2,6,a2,6,a2,2,fs2,2,d3,2,a2,2,fs2,2,d2,2,e2,2,fs2,2,g2
+,2,fs2,2,g2,2,e2,2,d2,12
a2,2,d2,2,d2,2,b2,2,d2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,
+g2,2,fs2,2,g2,2,fs2,2,g2,2,e2,2,fs2,2,g2,2,a2,2,d2,2,d2,2,b2,2,d2,2,d
+2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs2,2,g2,12

[download]
Cheers,
Ben

Replies are listed 'Best First'.
Re: Markov Diddly
by Mr. Muskrat (Canon) on Apr 09, 2003 at 17:02 UTC

    ++benn. Now here is my adaptation that uses MIDI::Simple for creating a MIDI of it ;)

    #!/usr/bin/perl

###########################################
# Variable Length Markov Diddly. 
###########################################

use strict;
use constant LENGTH => 4;                            # length of patte
+rn key
use MIDI::Simple;
my %duration = (
  2 => 'qn',
  4 => 'hn',
  8 => 'wn',
  12 => 'dwn',
);

new_score;
set_tempo 500000;  # 1 qn => .5 seconds (500,000 microseconds)
patch_change 1, 77;  # Patch 76 = recorder, 77 = pan flute, 80 = whist
+le, 81 = Ocarina

noop "c1", "fff", "o3";  # Setup

my %probs;                                            # probabilities 
+of next note

while (<DATA>) {                                    # read the existin
+g tunes...
    chomp;
    my @line = split /,/;
    my @notes = ("START") x (LENGTH);                # cyclic buffer
    while (@line) {
        shift (@notes);
        push @notes, shift(@line).",".shift(@line); # "note,length"
        $probs{key(@notes)}{$notes[$#notes]}++;
    }
    shift (@notes);
    $probs{key(@notes)}{"END"}++;
}

my @notes = ("START") x LENGTH;
do {
    shift(@notes);
    my %next = %{$probs{key(@notes)}};                # array of probs
    my @next = map {($_) x $next{$_}} keys %next;    # 1 entry per 'pr
+ob'
    push @notes, $next[int(rand(@next))];
    my ($note, $dur);
    unless ($notes[$#notes] eq "END") {
    print "$notes[$#notes] ";
      ($note, $dur) = split',',$notes[$#notes];
      ++$note; # increment once
      $note = uc(++$note); # increment again and then upcase it!
      $note = $MIDI::note2number{$note};
    eval(n $duration{$dur}, $note);
    }
    
} while ($notes[$#notes] ne "END");


write_score 'markov-diddly.mid';

 
sub key {return join("",@_[0..LENGTH-2]);}            # make space-sep
+arated key

# a bunch of common session tunes (plus one of mine <g>)
 
__DATA__
e2,4,e2,2,b2,2,e2,2,b2,2,e2,2,e2,2,b2,2,a2,2,fs2,2,d2,2,e2,4,e2,2,b2,4
+,cs3,2,d3,2,cs3,2,b2,2,a2,2,fs2,2,d2,2,e2,4,e2,2,b2,2,e2,2,b2,2,e2,2,
+e2,2,b2,2,a2,2,fs2,2,d2,2,g2,4,g2,2,fs2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs
+2,2,e2,2,d2,2
d2,2,g2,2,g2,2,b2,2,g2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,g2,2,e3,2,g3,2,
+e3,2,d3,2,b2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,e2,2,d2,2,g2,2,g2,2,b2,2
+,g2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,g2,2,e3,2,g3,2,e3,2,d3,2,b2,2,g2,
+2,a2,2,g2,2,fs2,2,g2,6
d2,4,d2,2,a2,6,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,d2,4,d2,2,a2,6,b2,2,a2,2,
+g2,2,e2,2,g2,2,e2,2,d2,4,d2,2,a2,6,b2,2,a2,2,g2,2,a2,2,b2,2,c3,2,d2,2
+,c3,2,b2,2,c3,2,b2,2,a2,2,b2,2,a2,2,g2,2,e2,2,g2,2,e2,2
d3,2,e3,2,d3,2,b2,4,g2,2,a2,4,g2,2,e2,4,d2,2,g2,4,g2,2,g2,2,a2,2,b2,2,
+d3,4,b2,2,a2,6,d3,2,e3,2,d3,2,b2,4,g3,2,fs2,4,e3,2,c3,4,e3,2,d3,2,e3,
+2,d3,2,c3,2,b2,2,a2,2,g2,12
b2,2,g2,2,g2,2,d2,2,g2,2,g2,2,b2,2,g2,2,b2,2,d3,2,c3,2,b2,2,c3,2,a2,2,
+a2,2,fs2,2,a2,2,a2,2,c3,2,a2,2,c3,2,e3,2,d3,2,c3,2,b2,2,g2,2,g2,2,d2,
+2,g2,2,g2,2,b2,2,g2,2,b2,2,d3,2,c3,2,b2,2,c3,2,b2,2,c3,2,a2,2,d3,2,c3
+,2,b2,2,g2,2,g2,2,g2,2,d3,2,c3,2
fs2,4,b2,2,b2,2,cs3,2,d3,2,cs3,4,a2,2,a2,2,b2,2,cs3,2,d3,4,b2,2,b2,2,c
+s3,2,d3,2,e3,2,fs3,2,e3,2,d3,2,cs3,2,b2,2,fs2,4,b2,2,b2,2,cs3,2,d3,2,
+cs3,4,a2,2,a2,2,b2,2,cs3,2,d3,2,cs3,2,d3,2,e3,2,d3,2,e3,2,fs3,2,b2,2,
+b2,2,b2,6
a2,2,fs2,2,a2,2,a2,2,fs2,2,a2,2,b2,2,g2,2,b2,2,b2,2,g2,2,b2,2,a2,2,fs2
+,2,a2,2,a2,2,d3,2,e3,2,fs3,2,e3,2,d3,3,b2,2,d3,2,b2,2,a2,2,fs2,2,a2,2
+,a2,2,fs2,2,a2,2,b2,2,g2,2,b2,2,b2,2,g2,2,b2,2,d3,2,e3,2,fs3,2,a3,2,f
+s3,2,e3,2,fs3,2,b2,2,b2,3,b2,2,d3,2,b2,2
a2,2,d2,2,d2,2,b2,2,d2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,
+g2,2,fs2,2,g2,2,fs2,2,g2,2,e2,2,fs2,2,g2,2,a2,2,d2,2,d2,2,b2,2,d2,2,d
+2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs2,2,g2,12
e2,2,fs2,2,e2,2,b2,4,b2,2,b2,2,a2,2,fs2,2,d3,6,e2,2,fs2,2,e2,2,b2,4,b2
+,2,b2,2,a2,2,fs2,2,fs2,4,e2,2,e2,2,fs2,2,e2,2,b2,4,b2,2,b2,2,a2,2,fs2
+,2,d3,6,b2,2,cs3,2,d3,2,e3,4,b2,2,b2,2,a2,2,fs2,2,fs2,4,e2,2
d2,4,a2,2,fs2,4,a2,2,d2,4,a2,2,fs2,4,a2,2,d3,4,e3,2,fs3,4,e3,2,d3,4,cs
+3,2,b2,4,a2,2,e3,6,fs3,6,g3,6,fs3,6,e3,4,d3,2,cs3,4,b2,2,a2,2,b2,2,a2
+,2,g2,2,fs2,2,e2,2
d2,4,e2,2,fs2,4,g2,2,a2,4,b2,2,a2,4,fs2,2,a2,4,b2,2,a2,4,fs2,2,a2,4,b2
+,2,a2,4,fs2,2,d2,4,e2,2,fs2,4,g2,2,a2,4,b2,2,a2,4,d3,2,cs3,4,b2,2,a2,
+4,fs2,2,d2,12
g2,2,g2,2,g2,2,g2,6,g2,2,g2,2,g2,2,g2,4,d3,2,b2,4,g2,2,b2,4,d3,2,g3,4,
+d3,2,b2,4,g2,2,d2,2,d2,2,d2,2,d2,6,d2,2,d2,2,d2,2,d2,4,a2,2,fs2,4,d2,
+2,fs2,4,a2,2,c3,4,a2,2,fs2,4,d2,2
a2,6,a2,6,a2,2,fs2,2,d3,2,a2,2,fs2,2,d2,2,g2,6,g2,6,g2,2,e2,2,fs2,2,g3
+,2,fs2,2,e2,2,a2,6,a2,6,a2,2,fs2,2,d3,2,a2,2,fs2,2,d2,2,e2,2,fs2,2,g2
+,2,fs2,2,g2,2,e2,2,d2,12
a2,2,d2,2,d2,2,b2,2,d2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,
+g2,2,fs2,2,g2,2,fs2,2,g2,2,e2,2,fs2,2,g2,2,a2,2,d2,2,d2,2,b2,2,d2,2,d
+2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs2,2,g2,12

    [download]

[reply]
[d/l]
      Coo - ++Mr. Muskrat - flattered by the fact that somebody cares, I thought I'd better make it a bit more useful :)

      Here's an OO version that allows you to mix-and-match 'diddly-streams' - the example code at the bottom tells the whole story.
      I've also fixed a couple of typos in the tune data. 
      package MarkovDiddly;

use strict;

###########################################
# Variable Length Markov Diddly Stream
###########################################

my @tunes = (# a bunch of common tunes
    "e2,4,e2,2,b2,2,e2,2,b2,2,e2,2,e2,2,b2,2,a2,2,fs2,2,d2,2,e2,4,e2,2
+,b2,4,cs3,2,d3,2,cs3,2,b2,2,a2,2,fs2,2,d2,2,e2,4,e2,2,b2,2,e2,2,b2,2,
+e2,2,e2,2,b2,2,a2,2,fs2,2,d2,2,g2,4,g2,2,fs2,2,g2,2,a2,2,b2,2,a2,2,g2
+,2,fs2,2,e2,2,d2,2",
    "d2,2,g2,2,g2,2,b2,2,g2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,g2,2,e3,2,
+g3,2,e3,2,d3,2,b2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,e2,2,d2,2,g2,2,g2,2
+,b2,2,g2,2,g2,2,a2,2,g2,2,a2,2,b2,2,g2,2,g2,2,e3,2,g3,2,e3,2,d3,2,b2,
+2,g2,2,a2,2,g2,2,fs2,2,g2,6",
    "d2,4,d2,2,a2,6,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,d2,4,d2,2,a2,6,b2,2,
+a2,2,g2,2,e2,2,g2,2,e2,2,d2,4,d2,2,a2,6,b2,2,a2,2,g2,2,a2,2,b2,2,c3,2
+,d2,2,c3,2,b2,2,c3,2,b2,2,a2,2,b2,2,a2,2,g2,2,e2,2,g2,2,e2,2",
    "d3,2,e3,2,d3,2,b2,4,g2,2,a2,4,g2,2,e2,4,d2,2,g2,4,g2,2,g2,2,a2,2,
+b2,2,d3,4,b2,2,a2,6,d3,2,e3,2,d3,2,b2,4,g3,2,fs2,4,e3,2,c3,4,e3,2,d3,
+2,e3,2,d3,2,c3,2,b2,2,a2,2,g2,12",
    "b2,2,g2,2,g2,2,d2,2,g2,2,g2,2,b2,2,g2,2,b2,2,d3,2,c3,2,b2,2,c3,2,
+a2,2,a2,2,fs2,2,a2,2,a2,2,c3,2,a2,2,c3,2,e3,2,d3,2,c3,2,b2,2,g2,2,g2,
+2,d2,2,g2,2,g2,2,b2,2,g2,2,b2,2,d3,2,c3,2,b2,2,c3,2,b2,2,c3,2,a2,2,d3
+,2,c3,2,b2,2,g2,2,g2,2,g2,2,d3,2,c3,2",
    "fs2,4,b2,2,b2,2,cs3,2,d3,2,cs3,4,a2,2,a2,2,b2,2,cs3,2,d3,4,b2,2,b
+2,2,cs3,2,d3,2,e3,2,fs3,2,e3,2,d3,2,cs3,2,b2,2,fs2,4,b2,2,b2,2,cs3,2,
+d3,2,cs3,4,a2,2,a2,2,b2,2,cs3,2,d3,2,cs3,2,d3,2,e3,2,d3,2,e3,2,fs3,2,
+b2,2,b2,2,b2,6",
    "a2,2,fs2,2,a2,2,a2,2,fs2,2,a2,2,b2,2,g2,2,b2,2,b2,2,g2,2,b2,2,a2,
+2,fs2,2,a2,2,a2,2,d3,2,e3,2,fs3,2,e3,2,d3,2,b2,2,d3,2,b2,2,a2,2,fs2,2
+,a2,2,a2,2,fs2,2,a2,2,b2,2,g2,2,b2,2,b2,2,g2,2,b2,2,d3,2,e3,2,fs3,2,a
+3,2,fs3,2,e3,2,fs3,2,b2,2,b2,2,b2,2,d3,2,b2,2",
    "a2,2,d2,2,d2,2,b2,2,d2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,
+a2,2,g2,2,fs2,2,g2,2,fs2,2,g2,2,e2,2,fs2,2,g2,2,a2,2,d2,2,d2,2,b2,2,d
+2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs2,2,g2,12",
    "e2,2,fs2,2,e2,2,b2,4,b2,2,b2,2,a2,2,fs2,2,d3,6,e2,2,fs2,2,e2,2,b2
+,4,b2,2,b2,2,a2,2,fs2,2,fs2,4,e2,2,e2,2,fs2,2,e2,2,b2,4,b2,2,b2,2,a2,
+2,fs2,2,d3,6,b2,2,cs3,2,d3,2,e3,4,b2,2,b2,2,a2,2,fs2,2,fs2,4,e2,2",
    "d2,4,a2,2,fs2,4,a2,2,d2,4,a2,2,fs2,4,a2,2,d3,4,e3,2,fs3,4,e3,2,d3
+,4,cs3,2,b2,4,a2,2,e3,6,fs3,6,g3,6,fs3,6,e3,4,d3,2,cs3,4,b2,2,a2,2,b2
+,2,a2,2,g2,2,fs2,2,e2,2",
    "d2,4,e2,2,fs2,4,g2,2,a2,4,b2,2,a2,4,fs2,2,a2,4,b2,2,a2,4,fs2,2,a2
+,4,b2,2,a2,4,fs2,2,d2,4,e2,2,fs2,4,g2,2,a2,4,b2,2,a2,4,d3,2,cs3,4,b2,
+2,a2,4,fs2,2,d2,12",
    "g2,2,g2,2,g2,2,g2,6,g2,2,g2,2,g2,2,g2,4,d3,2,b2,4,g2,2,b2,4,d3,2,
+g3,4,d3,2,b2,4,g2,2,d2,2,d2,2,d2,2,d2,6,d2,2,d2,2,d2,2,d2,4,a2,2,fs2,
+4,d2,2,fs2,4,a2,2,c3,4,a2,2,fs2,4,d2,2",
    "a2,6,a2,6,a2,2,fs2,2,d3,2,a2,2,fs2,2,d2,2,g2,6,g2,6,g2,2,e2,2,fs2
+,2,g3,2,fs2,2,e2,2,a2,6,a2,6,a2,2,fs2,2,d3,2,a2,2,fs2,2,d2,2,e2,2,fs2
+,2,g2,2,fs2,2,g2,2,e2,2,d2,12",
    "a2,2,d2,2,d2,2,b2,2,d2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,
+a2,2,g2,2,fs2,2,g2,2,fs2,2,g2,2,e2,2,fs2,2,g2,2,a2,2,d2,2,d2,2,b2,2,d
+2,2,d2,2,c3,6,c3,2,b2,2,a2,2,g2,2,a2,2,b2,2,a2,2,g2,2,fs2,2,g2,12",
);


sub new {    
    my $class = shift();
    my $length = shift() || 4;                            # a good ave
+rage
    my %self = ('length'=>$length);
    foreach (@tunes) {                                    # read the e
+xisting tunes...
        chomp;
        my @line = split /,/;
        my @notes = ("START") x $length;                # cyclic buffe
+r of notes
        my @pitches = ("START") x $length;                # cyclic buf
+fer of pitches
        my @durs = ("START") x $length;                    # cyclic bu
+ffer of durations
        while (@line) {
            shift (@notes);shift (@pitches);shift (@durs);
            my ($pitch,$dur) = (shift(@line),shift(@line));
            push @notes, "$pitch,$dur";
            push @pitches,$pitch;
            push @durs,$dur;
            $self{notes}{key($length,@notes)}{$notes[$#notes]}++;
            $self{pitches}{key($length,@pitches)}{$pitches[$#pitches]}
+++;
            $self{durs}{key($length,@durs)}{$durs[$#durs]}++;
        }
        shift (@notes);shift (@pitches);shift (@durs);
        $self{notes}{key($length,@notes)}{"END"}++;
        $self{pitches}{key($length,@pitches)}{"END"}++;
        $self{durs}{key($length,@durs)}{"END"}++;
    }
    $self{nbuffer} = [("START") x $length];
    $self{pbuffer} = [("START") x $length];
    $self{dbuffer} = [("START") x $length];
    bless \%self,$class;
}

# get a full sequence to end
sub sequence {
    my ($self,$buffer,$probs) = @_;
    my @seq;
    do {push @seq,$self->get_next(1,$buffer,$probs);} while ($seq[$#se
+q] ne "END");
    $self->set_buffer($buffer);
    pop @seq;    #remove 'END' tag
    @seq;
}

sub get_tune { sequence(shift(),"nbuffer","notes");}
sub get_pitches { sequence(shift(),"pbuffer","pitches");}
sub get_durations { sequence(shift(),"dbuffer","durs");}

# receive a buffer & a bunch of probabilities, 
# return an item (and rotate the buffer)
# only allow possibility of 'END' token if requested
sub get_next {                                            
    my ($self,$end,$buffer,$probs) = @_;
    $self->set_buffer($buffer) unless (@{$self->{$buffer}});
    my @buffer = @{$self->{$buffer}};
    shift(@buffer);
    my %next = %{$self->{$probs}{key($self->{length},@buffer)}};      
+  
    my @next = map {($_) x $next{$_}} keys %next;    # 1 entry per 'pr
+ob'
    my $n = $next[int(rand(@next))];
    unless ($end) {
        unless (grep {$_ ne "END"} @next) {    # only 1 option left,
            $self->set_buffer($buffer);            # so go to beginnin
+g
            return $self->get_next($end,$buffer,$probs);
        }
        while ($n eq 'END') {$n = $next[int(rand(@next))]};
    }
    push @buffer, $n;
    $self->set_buffer($buffer,@buffer);
    return $buffer[$#buffer];
}

# 'stream' functions - get_next_xxx(allow_end_token)
sub get_next_note {get_next(shift(),shift(),"nbuffer","notes");}
sub get_next_pitch {get_next(shift(),shift(),"pbuffer","pitches");}
sub get_next_duration {get_next(shift(),shift(),"dbuffer","durs");}

# set the intitial states
sub set_notes {set_buffer(shift,"nbuffer",@_);}
sub set_pitches {set_buffer(shift,"pbuffer",@_);}
sub set_durations {set_buffer(shift,"dbuffer",@_);}
sub set_buffer {
    my ($self,$buffer,@buffer) = @_;
    shift(@buffer) while (@buffer > $self->{length});
    unshift(@buffer,"START") while (@buffer < $self->{length});
    $self->{$buffer} = \@buffer;
}

sub key {my $l=shift();my @arr = @_;return join(" ",@arr[0..$l - 2]);}
+            
1;

      [download]
      later... 
      package main;

use strict;
use MarkovDiddly;

my $t6 = MarkovDiddly->new(6);            # will closely an resemble e
+xisting tune
print "tune      (6): ",join(" ",$t6->get_tune()),"\n\n";
print "pitches   (6): ",join(" ",$t6->get_pitches()),"\n\n";
print "durations (6): ",join(" ",$t6->get_durations()),"\n\n";

my $t2 = MarkovDiddly->new(2);            # will be more random
print "tune      (2): ",join(" ",$t2->get_tune()),"\n\n";

# grab a load of predictable notes with more random durations
$t6->set_pitches(qw(d2 g2 g2 b2 g2 g2));
my @tune = map {$t6->get_next_pitch().",".$t2->get_next_duration()." "
+} (0..30);

print "mixture (6/2): ",join(",",@tune),"\n";
exit;

      [download]
      Cheers,
      Ben
[reply]
[d/l]
[select]

Back to Cool Uses for Perl