path: root/hr/michi/whitacre/haukify

#!/usr/bin/perl

# preamble
use strict;
use warnings;
# elbmaerp
#
# program logic goes here

  my %lines = ();
  my %defs = ();
  my %feds = ();
  my @skeleton = ();
  my @rhf = ();
  my @current;
{ # sub def scope
  my $DEN = 256;
  my $m = 0;
  #my @voices = map { $_ . "Melodie" } ("sopran", "alt", "tenor", "bass");
  my $n = 0;
  my $o = 0;
  my @chunks;
  my @measures;
  { # scope for reading in <dynArt.ly>
    my $lrd = 0;
    my $inda = 0;
    my $num;
    my $den;
    open(FH, "<dynArt.ly");
    while (<FH>) {
      next if (/^\s*%/ or /override/ or /partial/ or /alternative/);
      /{/; #vim bug
      s/{[^}]*}//g;
      if (/{/) {
        $lrd += 1;
        if ($lrd == 1) {
          @measures = ();
          $inda = 1 - $inda;
        }
        next;
      }
      next unless $inda;
      if (/}/) {
        $lrd -= 1;
        if ($lrd == 0) {
          if ($#measures == -1) {
          } else {
            my @bla = map $_, @measures;
            push @chunks, \@bla;
          }
          $inda = 1 - $inda;
        }
      }
      #push @measures, $DEN/$1 if /partial \D*(\d+)/;
      if (/time (\d+)\/(\d+)/) {
        $num = $1;
        $den = $2;
        while ($den < $DEN) {
          $num *= 2; $den *= 2;
        }
      }
      if (/^\s*s/) {
        if (/s(\d+\.*)\*(\d+)\s*$/) {
          my $times = ($2 and ($2 ne "")) ? $2 : 1;
          my $dur = &duration($1);
          push @measures, $dur for (1 .. $times);
        } else {
          my @code = split /\s+/;
          my $num = 0;
          for (@code) {
            $num += &duration($_);
          }
          push @measures, $num;
        }
      }
    }
  }
  my @fm = @{$chunks[0]};

  my $idx = 0;
  my $intimes = 0;
  my $conc = 0;
  
  { # scope for &conc
    my $cdur;
    my $crud;
    my $clev;
    sub conc() {
      return $_ if (/%/);
      if (/^\s*{\s*$/) {
        $clev += 1;
        return $_;
      }
      if (/^\s*}\s*$/) {
        $clev -= 1;
        if ($cdur and $crud) {
          $cdur = 0; $crud = 0;
        }
        return $_;
      }
      if ($clev == 1) {
        my @code = split /\s*/;
        my @tms = map { &duration($_) } @code;
        if ($cdur) {
          $crud += $_ for @code;
        } else {
          $cdur += $_ for @code;
        }
        if ($crud and $crud != $cdur) {
          print STDERR "parallel parts don’t match: $.; $n\n";
        }
        print STDERR "parallel parts don’t match dynArt: $.; $n\n"
        if $cdur % $measures[$idx];
        return $_;
        # recursive call of haukified w/ local counter and state vars!
      }
    }
  }
  sub min() {
    my $a = shift;
    my $b = shift;
    return $a < $b ? $a : $b;
  }
  my $par = "";
  sub par() {
    /{{/; # vim bug
    $par =~ /{([^}]*)}\s*\\\\\s*{([^}]*)}/;
    my (@c, @d);
    @c = split(/\s+/, $1);
    @d = split(/\s+/, $2);
    my ($c, $d);
    $c += &duration($_) for @c;
    $d += &duration($_) for @d;
    print STDERR "parallel mismatch in\n>>>$par\n" . ($c/$DEN) . " " . ($d/$DEN) . "\n" if ($c != $d);
    return &min($c, $d);
  }
  { # scope for &times
    my $tnum;
    my $tden;
    my $tstr;
    my $tdur = 0;
    sub times() {
      my $task = shift;
      if ($task eq "start") {
        $tnum = shift;
        $tden = shift;
        $tdur = 0;
        $tstr = "\\times $tnum\/$tden ";
        $intimes = 1 - $intimes;
      }
      if ($task eq "cont") {
        my $code = shift;
        $tstr .= $code . " ";
        $tdur += &duration($code);
      }
      if ($task eq "stop") {
        $intimes = 1 - $intimes;
        return ($tstr, $tdur*$tnum/$tden);
        #return ($tstr . "} ", $tdur*$tnum/$tden);
      }
    }
  }
  sub duration() {
    return 0 unless(/\D*(\d+)(\.*).*/);
    my ($den, $dots, $num) = ($1, $2, 1);
    $num = 0 if (/</);
    while ($dots) {
      $num *= 2;
      $den *= 2;
      $num += 1;
      chop($dots);
    }
    while ($den < $DEN) {
      $num *= 2; $den *= 2;
    }
    print STDERR "bad duration: $1\n" unless ($den == $DEN);
    return $num;
  }
  my $NUM = 0;
  # one func to rule them all
  sub haukified() {
    if (/^\s*<<\s*$/) {
      $conc += 1;
      return $_;
    }
    if (/^\s*>>\s*$/) {
      $conc -= 1;
      return $_;
    }
    return &conc($_) if ($conc > 1);
    local $, = "|";
    return $_ if (/%/ or /repeat/ or /time / or /clef/ or /partial/ or /version/);
    s/times\s*/times/g;
    #if (/times/) {
    #  $idx += 1 unless (length(@measures)<2);
    #  return $_;
    #}
    # time key -> dynArt
    chomp $_;
    #times, repeat & bla = { … }; partial!
    # -> tokenstream vorbereiten (trb -> hooks)
    # -> repeat ought to occur in dynArt as well
    s/ ~/~/g;
    /^(\s*)(.*)/;
    my $indent = $1;
    my @code = split(/\s+/, $2);
    my @parts;
    my $part = "";
    my $inpar = 0;
    for (@code) {
      if ($inpar) {
        if (/>>/) {
          $part .= "<< $par ";
          $NUM += &par($par);
          while ($NUM > $measures[$idx]) {
            $NUM -= $measures[$idx];
            $idx += 1 if($measures[$idx + 1]);
            #$measures[$idx] //= $measures[$idx-1];
          }
          $par = "";
          $inpar = 0;
        } else {
          $par .= "$_ ";
          next;
        }
      }
      if (/<</) {
        $inpar = 1;
        next;
      }
      if ($intimes) {
        /{/; #vim bug
        if (/}/) {
          my ($text, $dur) = &times("stop");
          $part .= $text;
          $NUM += $dur;
          my $tmp = $dur/$DEN;
        } else {
          &times("cont", $_);
          next;
        }
      }
      if (/times(\d+)\/(\d+)/) {
        &times("start", $1, $2);
        next;
      }
      $part .= "$_ ";
      if (/^\\(\S+)$/) {
        &align($defs{$1}, $1);
        next;
      }
      /{/; #vim bug
      $NUM += &duration($_) unless /}/;
      if ($NUM > $measures[$idx]) {
        print STDERR "error at measure " . ($idx+1) . " (local $m) in (orig) $o, (result) $n\n";
        print STDERR "$NUM out of $measures[$idx]\n";
        print STDERR "(occurred after reading $part)\n";
      }
      unless ($NUM < $measures[$idx]) {
        push @parts, $part;
        $n += 1;
        $idx += 1;
        $m += 1;
        $measures[$idx] //= $measures[$idx-1];
        $NUM = 0;
        $part = $indent;
      }
    }
    if ($part =~ /\S/) {
      push @parts, $part;
      print STDERR "underfull measure at (orig) $o, measure " . ($idx+1) . " (local $m)  ";
      print STDERR "$part?\n";
      print STDERR "$NUM out of $measures[$idx]\n";
      $idx += 1 unless ($#measures < 1);
      $measures[$idx] //= $measures[$idx-1];
    } else {
      $n -= 1;
      #$idx -= 1 unless (length(@measures)<2);
    }
    my $res = $indent;
    for (@parts) {
      s/~/ ~/g;
      $res .= $_ . "\n";
    }
    return $res;
    #return $indent . join("\n", map s/~/ ~/g, @parts);
  }
  #my $m;
  my %aligned = ();
  sub align {
    my $bla = shift;
    my @out = ();
    my $name = shift;
    my $oldm = $m;
    $m = 1; # measure innerhalb dieser def
    my $oldo = $o;
    $o = $lines{$name};
    for (@$bla) {
      if (/^\s*\\(\S+)\s*$/) {
        unless (/voice/) {
          print STDERR "$_";
          &align($defs{$1}, $1);
        }
      }
      $n += 1;
      push @out, $_ unless (/\d/);
    #print &haukified($_), "\n" if /\d/;
      $o += 1;
      push @out, &haukified($_) if /\d/;
    }
    $m = $oldm;
    $o = $oldo;
    if ($aligned{$name}) {
      my $match = 1;
      for (0 .. &min(@out, @{$feds{$name}})) {
        $match = 0 if $feds{$name}->[$_] != $out[$_];
      }
      print STDERR "inconsistent use of $name …" unless $match;
    } else {
      @{$feds{$name}} = map $_, @out;
    }
  }
  my $i = 0;
  sub align_voice() {
    #print STDERR "dynart exhausted before stimmen done!\n" unless ($#chunks > -1);
    @measures = ($#chunks == -1) ? @fm : @{pop @chunks};
    $idx = 0;
    $NUM = 0;
    &align(@_);
    $i += 1;
  }
  sub check() {
    $o += @{$skeleton[$i]};
    for (keys %defs) {
      &align_voice($defs{$_}, $_) if /Melodie/;
    }
    for (keys %defs) {
      $feds{$_} //= $defs{$_};
    }
  }
  sub flush() {
    for (0 .. $#rhf) {
      print for @{$skeleton[$_]};
      print for @{$feds{$rhf[$_]}};
    }
    print for @{$skeleton[$#rhf+1]};
  }
}

my $inddef = "";
my $def = 0;
while (<>) {
  if ($def) {
    /{/; #vim bug
    if (/^$inddef}\s*$/) {
      $def = 0;
      my @bla = map $_, @current;
      $defs{$rhf[$#rhf]} = \@bla;
      @current = ();
    }
  }
  if (/^(\s*)(\S*) = \\relative/) {
    push @current, $_;
    my @bla = map $_, @current;
    push @skeleton, \@bla;
    @current = ();
    $inddef = $1;
    push @rhf, $2;
    $lines{$2} = $.;
    $def = 1; #TODO: def zoix -> %def, später einbinden
    # ds chunk -> begin orig, begin hauked
    # TODO: conc innerhalb des taktes -> zwei gobble-ups, vgl, hinzufügen
    next;
  }
  push @current, $_;
}

{ # using the defs
  my @bla = map $_, @current;
  push @skeleton, \@bla;
  &check();
  &flush();
}

# some settings # vim: et