#!/usr/bin/perl -w

#
# $Id: Scales.pm,v 1.2 2002-09-10 21:46:50-05 bobn Exp bobn $
#
# provide musical scales
#

=head1

NAME

Scales.pm - provide musically-significant streams of numbers and/or text.

=cut

package Scales;

# use warnings;
use strict;

use Data::Dumper;
select STDERR; $|++;
select STDOUT; $|++;

use Storable qw(nstore store_fd nstore_fd freeze thaw dclone);

use vars qw( $VERSION %TUNINGS );

$VERSION = '0.20';
sub VERSION
{
	return $VERSION;
}

sub new
{
	my $class = shift;
	my $self = {};
	return(bless($self, $class));
}

my @notes;

@notes = split(' ', 'c c# d d# e f f# g g# a a# b' );

my (%notes, $i);
$i = 0;

for ( @notes )
{
	$notes{$_} = $i++;
}

=head1 

METHODS

=head2 

notes()

called as $m->notes('c') or $m->notes(0), return the 12-tone scale beginning with the specified note.
The examples given both output 12 tones starting with c.  Numeric input is interpreted 
as the number of half-steps from c on which to begin.

=cut

sub notes
{
	my @ret;
	shift if ref($_[0]); # save first parm if not called as method.
	my ($key, $majmin) = @_;
	$key = lc $key;
	$key = $notes{$key} if exists $notes{$key};
	die "Invalid value for key: '$key'" unless (  $key =~/^\d+$/ and $key >= 0 and $key <= 11 ) ;
	for ( 0..11 )
	{
		push @ret, $notes[ ($key + $_) % 12 ];
	}
	return @ret;
}

my %scales;


# relate name to number of 1/2 steps from tonic.
my %note_number =
(
	I		=> 0,
	ii		=> 1,
	II		=> 2,
	iii		=> 3,
	III		=> 4,
	IV		=> 5,
	'IV+'	=> 6,
	v		=> 6,
	V		=> 7,
	'V+'	=> 8,
	vi		=> 8,
	VI		=> 9,
	vii		=> 10,
	VII		=> 11,
);


%scales =
(
	all =>
	{
		'' => [ qw( 0 1 2 3 4 5 6 7 8 9 10 11 ) ],
	},
	dominant =>
	{
		seventhC => [ qw( 0 4 7 10 ) ],
		'7thC'   => [ qw( 0 4 7 10 ) ],
		ninethC => [ qw( 0 4 7 10 14) ],
		'9thC'  => [ qw( 0 4 7 10 14) ],
		thirteenthC => [ qw( 0 4 7 10 21) ],
		'13thC'     => [ qw( 0 4 7 10 21) ],
	},
	major =>
	{
		seventhC => [ qw( 0 4 7 11 ) ],
		'7thC'   => [ qw( 0 4 7 11 ) ],
		diatonic => [ qw( 0 2 4 5 7 9 11 ) ],
		'' 		 => [ qw( 0 2 4 5 7 9 11 ) ],
		pentatonic => [ qw( 0 2 4 7 9 ) ],
	},
	minor =>
	{
		diatonic => [ qw( 0 2 3 5 7 8 10 ) ],
		''       => [ qw( 0 2 3 5 7 8 10 ) ],
		harmonic => [ qw( 0 2 3 5 7 8 11 ) ],
		melodic =>  [ qw( 0 2 3 5 7 9 11 ) ],
		pentatonic => [ qw( 0 3 5 7 10 ) ],
		seventhC => [ qw( 0 3 7 10 ) ],
		'7thC'   => [ qw( 0 3 7 10 ) ],
	},
	wholetone => 
	{
		'' => [ qw( 0 2 4 6 8 10 ) ]
	},
	diminished =>
	{
		'' => [ qw( 0 2 3 5 6 8 9 11 ) ],
	},
	diminishedC =>
	{
		'' => [ qw( 0 3 6 9 ) ],
	},
#	mixolydian =>
#	{

#		''		=> [ qw( 0 2 4 5 7 9 10) ],
#	},
);

my $new_scales = dclone(\%scales);
# print Dumper($new_scales);

my @out_scales = ();;

sub do_list_scales
{
	_list_scales(\%scales, ());
	return @out_scales;
}

sub _list_scales
{
	my ( $hr, @out ) = @_;
	for my $key ( keys %$hr )
	{
		if ( ref($hr->{$key}) eq 'HASH' )
		{
			_list_scales( $hr->{$key}, @out, $key);
		}
		else
		{
			push @out_scales, join(',',  @out, $key);
		}
	}
}

=head2

define_scale

Allows user program to define a scale for later use.

Example:

    $m->define_scale('mixolydian', '', ' I II III IV V VI vii  ' );

or:

    $m->define_scale('mixolydian', '', ' 0 2 4 5 7 9 10  ' );


When called with numbers, they are tekn to be the number of 
half-stpes from the tonic.

note: this modifies class data, so all further uses of the module by this process 
will be affected.  
Is this a "feature"? Probably not in the mod_perl context.

Note that this could be used to define the notes of chords, rather than scales,
e.g.: 

	$m->define_scale('minor,9th', ' 0 3 7 10 14 ' );

but note that the program will render the 9th as 2nds, also.

=cut

sub define_scale
{
	shift if ref($_[0]); # save first parm if not called as method.
	my ($type, $subtype, @notes) = @_;
	if ( scalar(@notes) == 1) { @notes = split(' ', $notes[0]) };

	@notes = map { ( exists $note_number{$_} ? $note_number{$_} : $_ ) } @notes;

	$scales{$type}{$subtype} = [ @notes ];
}

# use of define_scale
define_scale('mixolydian', '', ' I II III IV V VI vii  ' );




# return an array of the notes in this scale.
sub scale
{
	shift if ref($_[0]); # save first parm if not called as method.
	my ( $key, $type, $subtype ) = @_;
	my (@vals, @ret);
	my @notes = notes($key);

	if ( exists $scales{$type} and exists $scales{$type}{$subtype} )
	{
		@vals = @{$scales{$type}{$subtype}};
	}
	else
	{
		die "no scale defined for typs: '$type' and subtype: '$subtype'\n";
	}

	for ( @vals )
	{
		push @ret, $notes[ $_  % 12 ];
	}
	return @ret;
}

sub show_all
{
	print Data::Dumper->Dump( 
		[ \%scales, \%note_number, ],
		[ qw(*scales *note_number) ],
		);
}

1;

__END__

#
# $Log: Scales.pm,v $
# Revision 1.2  2002-09-10 21:46:50-05  bobn
# whatever
#
# Revision 1.1  2002-09-05 21:27:55-05  bobn
# Initial revision
#
#