#!/usr/bin/perl -s

our ($abs);  # notas absolutas

use Data::Dumper;
my $data = { a => [ b  => 2, g => -2 ],
             b => [ c  => 1, a => -2 ],
             c => [ d  => 2, b => -1 ],
             d => [ e  => 2, c => -2 ],
             e => [ f  => 1, d => -2 ],
             f => [ g  => 2, e => -1 ],
             g => [ a  => 2, f => -2 ]};

my %datajj = qw{
c 0
d 2
e 4
f 5
g 7
a 9
b 11
} ;

undef $/;
$linha = <>;

$linha = preprocess($linha);
my @notas = split /(?:\s|\~)+/,$linha;


print STDERR "Uniforming rythms\n";
@notas = uniformiza_ritmos(@notas);

my @ritmos = ritmos(@notas);
my %rHist = histograma(@ritmos);

print STDERR "Calculating Invervals\n";
my $width;


my @notassimp = map{ s/[\{\}]//g; s/\.+//; s/\d+//; s/~.*$//; $_} 
                   grep { $_ !~ m!(times|\d+/\d+|^\})! } 
                        @notas;
my @intervalos = ();
if($abs){ @intervalos = jjcalcIntervals(@notassimp); }
else    { @intervalos =   calcIntervals(map {letriza($_)} @notassimp);   }

print STDERR "WIDTH ($width)\n";

## print Dumper \@notas;
## print Dumper \@intervalos;
## die("\n");

print STDERR "Calculating Histograms\n";
my %intHist = histograma(@intervalos);
#print Dumper(\%intHist);

my @bi = bigramas(@intervalos);
my %BintHist = histograma(@bi);
#print Dumper(\%BintHist);

my @tri = trigramas(@intervalos);
my %TintHist = histograma(@tri);
#print Dumper(\%TintHist);

my $res;
$res->{$_}=$intHist{$_} for (keys %intHist);
# $res->{$_}=$BintHist{$_} for (keys %BintHist);
# $res->{$_}=$TintHist{$_} for (keys %TintHist);
$res->{$_}=$rHist{$_} for (keys %rHist);
#$res->{width} = $width;

print Dumper($res);
print STDERR "** DONE **\n";





sub jjcalcIntervals{
  my @notas = @_;
  shift @notas while $notas[0] =~ m!^[sr]!;


  my $first = shift @notas;
  my @intervals;

  my $current = 0;
  my $minimum = $current;
  my $maximum = $current;

  my $last_for_range = $first;

  while(@notas) {
    # Isto tem de ser tratado de outra forma. para ja', ver se worka
    my $next = shift @notas;
    if (!$first || !$next || $first =~ m!^[rs]! || $next =~ m!^[sr]!) {
      $first = $next;
      next
    }

    print STDERR "ABS >$first< >$next< \n"; # = $x\n";
    my $i = jjcalcInterval($first,$next);
    push @intervals, $i;

    if ($last_for_range) {
      $i = jjcalcInterval($last_for_range,$next);
    }
    $current += $i;
    $minimum = $current if $current < $minimum;
    $maximum = $current if $current > $maximum;

    $first = $next;
    $last_for_range = $next;
  }
  $width = abs($minimum)+$maximum;
  return @intervals;
}


sub ritmos {
  my @r = grep {$_ !~ m!({|times|\d+/\d+|^s)!} @_;
  @r = map {
    my $orig = $_;
    my $oo = $_;
    $orig =~ s!^{?(do|re|mi|fa|sol|la|si|[a-gr])((is)+|(es)+|b+|d+|f+|s+)?\'*,*!!;
    $orig =~ s![\}\{]!!g;
    $orig =~ s!^!rythm!;
    $orig;
  } @r;
}

sub uniformiza_ritmos {
  my @notas = @_;
  my $r = 4; # this is not nice...
  for (@notas) {
    next if m!times!;
    next if m!\d/\d!;
    next if m!{$!;
    if (m!(\d+\.*)!) {
      $r = $1;
    } else {
      if (m!^(.*)\}$!) {
	$_ = "$1$r}"
      } else {
	$_.=$r;
      }
    }
  }
  return @notas;
}


sub bigramas {
  my $f = shift @_;
  my @r;
  while(@_){
    my $n = shift @_;
    push @r, "$f,$n";
    $f = $n;
  }
  @r;
}

sub trigramas {
  my $f = shift @_;
  my $s = shift @_;
  my @r;
  while(@_) {
    my $n = shift @_;
    push @r, "$f,$s,$n";
    $f = $s;
    $s = $n;
  }
  @r;
}

sub histograma {
  my %x;
  $x{$_}++ for @_;
  my $length = scalar(@_);
  for (keys %x) {
    $x{$_}/=$length
  }
  %x
}

sub calcIntervals {
  my @notas = @_;


  shift @notas while $notas[0] =~ m!^([sr]|$)!;



  my $first = shift @notas;
  my @intervals;

  my $current = 0;
  my $minimum = $current;
  my $maximum = $current;

  my $last_for_range = $first;

  while(@notas) {
    # Isto tem de ser tratado de outra forma. para ja', ver se worka
    my $next = shift @notas;

    if ( !$next || $next =~ m!^[rs]!) {
      $first = $next;
      next;
    }

    if (!$first || $first =~ m!^[rs]!) {
      if ($last_for_range) {
	$i = calcInterval($last_for_range, $next);

	$current+=$i;
	$minimum = $current if $current < $minimum;
	$maximum = $current if $current > $maximum;

	print STDERR "REL >$last_for_range< >$next< ($i) $current\n";

      }

      $first = $next;
      $last_for_range = $next;

      next
    }

#    print STDERR "REL >$first< >$next< \n"; # = $x\n";
    my $i = calcInterval($first,$next);
    push @intervals, $i;

    if ($last_for_range) {
      $i = calcInterval($last_for_range, $next);
      $current+=$i;
      $minimum = $current if $current < $minimum;
      $maximum = $current if $current > $maximum;

      print STDERR "REL >$last_for_range< >$next< ($i) $current\n";

    }

    $first = $next;
    $last_for_range = $next;
  }
  $width = abs($minimum)+$maximum;
  return @intervals;
}

sub jjcalcInterval{
 my ($f,$n) = @_;
 notade($f)-notade($n)
}

sub notade{
 my $n=shift;
 if($n =~ s/^([a-g])/$datajj{$1} + /){} else {return 1000};
 if($n =~ s/^(is|s|d)/1 + /){} ;
 if($n =~ s/^''/24 + /){} ;
 if($n =~ s/^\'/12 + /){} ;
 if($n =~ s/^,,/-24 + /){} ;
 if($n =~ s/^,/-12 + /){} ;
 #eval("$n 0");
 "$n 0";
}

sub preprocess {
  my $l = shift;

  for ($l) {
    s/(\.)([a-z])/$1 $2/g;
    s/%.*//g;
    s/\\[><!]/ /g;
    s/<(\S+)\s[^>]+>/$1/g;
    s/-[.>]/ /g;
    s/R\d+(\s*\*\s*\d+)?/ /g;
    s/\\repeat "?volta"? \d {/ /g;
    s/\^"[^"]*"/ /g;
    s/\\clef\s[\S]+/ /g;
    s/\\bar\s*"[^"]*"/ /g;
    s/[|\)\]\[\(!\"\?]/ /g;
    s/\^\\[a-z]+/ /g;
    s/-\\[a-zA-Z]+/ /g;
    s/_\\[a-zA-Z]+/ /g;
    s/\\(mf|mp|acciaccatura|trill|fermata|repeat|(default|modern)Accidentals|stem(Up|Both|Down)|bar|no(Beam|ResetKey)|autoBeamO(n|ff)|triplets(Show(Once)?|Hide)|cresc)/ /g;
#    s/\\grace\s*\{[^}]+\}/ /g;
    s/\\grace/ /g;
    s/\\(ff?|pp?)/ /g;
    s!\s+~\s+!~!g;
    s!-! !g;
    s/\n/ /g;
    s/\s+/ /g;
    s/\^\s+//g;
    s/\s+$//g;
  }

  return $l;
}

sub calcInterval {
  my ($one, $two) = @_;
  my $x = _calcOitavas($one,$two);
  return $x;
}

sub letriza {
  my $l = shift;
  for ($l) {
    s/^do/c/;
    s!^re!d!;
    s/^mi/e/;
    s/^fa/f/;
    s/^sol/g/;
    s/^la/a/;
    s/^si/b/;
  }
  return $l;
}


sub _calcOitavas {
  my ($one,$two) = @_;
  $one =~ s!'!!g;
  $one =~ s!,!!g;

  if ($two =~ m!'!) {
    $two =~ s!'!!;
    return _calcOitavas($one,$two) + 12;
  }
  if ($two =~ m!,!) {
    $two =~ s!,!!;
    return _calcOitavas($one,$two) - 12;
  }
  return _calcAcidentes($one,$two);
}

sub _calcAcidentes {
  my ($one,$two) = @_;

  # sustenidos
  if ($one =~ m!is!) {
    $one =~ s/is//;
    return _calcAcidentes($one,$two) - 1;
  }
  if ($two =~ m!is!) {
    $two =~ s/is//;
    return _calcAcidentes($one,$two) + 1;
  }

  # bemois
  if ($one =~ m!es!) {
    $one =~ s/es//;
    return _calcAcidentes($one,$two) + 1;
  }
  if ($two =~ m!es!) {
    $two =~ s/es//;
    return _calcAcidentes($one,$two) - 1;
  }


  # bemois
  if ($one =~ m![a-g]f!) {
    $one =~ s/([a-g])f/$1/;
    return _calcAcidentes($one,$two) + 1;
  }
  if ($two =~ m![a-g]f!) {
    $two =~ s/([a-g])f/$1/;
    return _calcAcidentes($one,$two) - 1;
  }


  # bemois
  if ($one =~ m![a-g]b!) {
    $one =~ s/([a-g])b/$1/;
    return _calcAcidentes($one,$two) + 1;
  }
  if ($two =~ m![a-g]b!) {
    $two =~ s/([a-g])b/$1/;
    return _calcAcidentes($one,$two) - 1;
  }


  # sustenidos
  if ($one =~ m!s!) {
    $one =~ s/s//;
    return _calcAcidentes($one,$two) - 1;
  }
  if ($two =~ m!s!) {
    $two =~ s/s//;
    return _calcAcidentes($one,$two) + 1;
  }

  # sustenidos
  if ($one =~ m![a-g]d!) {
    $one =~ s/([a-g])d/$1/;
    return _calcAcidentes($one,$two) - 1;
  }
  if ($two =~ m![a-g]d!) {
    $two =~ s/([a-g])d/$1/;
    return _calcAcidentes($one,$two) + 1;
  }

  return _calcIntervalo($one,$two);
}

sub _calcIntervalo {
  my ($one,$two) = @_;

  my $asc = _calcIntervaloAux($one,$two,0);
  my $desc = _calcIntervaloAux($one,$two,1);

  return [$asc,$desc]->[abs($asc) > abs($desc)];
}

sub _calcIntervaloAux {
  my ($one,$two,$idx) = @_;


  if ($one eq $two) {
    return 0
  } else {
    my $none = $data->{$one}[$idx*2];
    return _calcIntervaloAux($none, $two, $idx) + $data->{$one}[$idx*2+1]
  }
}