path: root/hr/michi/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 { # sub def scope
  my $DEN = 256; # shortest duration glyph
  my $measure = 0;
  #my @voices = map { $_ . "Melodie" } ("sopran", "alt", "tenor", "bass");
  my $n = 0;
  my $orig = 0;
  my @chunks;
  my @measures;
  { # scope for reading in <dynArt.ly>
    my $lrd = 0;
    my $inside = 0; # are we inside a definition?
    my $num; # numerator
    my $den; # denominator
    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 = ();
          $inside = 1 - $inside;
        }
        next;
      }
      next unless $inside;
      if (/}/) {
        $lrd -= 1;
        if ($lrd == 0) {
          if ($#measures == -1) {
          } else {
            my @bla = map $_, @measures;
            push @chunks, \@bla;
          }
          $inside = 1 - $inside;
        }
      }
      if (/time (\d+)\/(\d+)/) { # time signature change
        $num = $1;
        $den = $2;
        while ($den < $DEN) {
          $num *= 2; $den *= 2;
        }
      }
      if (/^\s*s/) {
        if (/s(\d+\.*)\*(\d+)\s*$/) { # multiple measures
          #TODO: support s8*7*18 etc.
          my $times = ($2 and ($2 ne "")) ? $2 : 1;
          my $dur = &duration($1);
          push @measures, $dur for (1 .. $times);
        } else { # analogous to a melody
          my @code = split /\s+/;
          my $num = 0;
          for (@code) {
            $num += &duration($_);
          }
          push @measures, $num;
        }
      }
    }
  }
  my @fm = @{$chunks[0]}; # first @measures

  my $idx = 0;
  my $intimes = 0;
  my $conc = 0;
  
  { # scope for &conc (concurrent music)
    my $cdur; # duration
    my $crud; # same for second part
    my $clev; # manage sequential construct level (nesting curlies)
    sub conc() {
      return $_ if (/%/); # ignore comments
      if (/^\s*{\s*$/) {
        $clev += 1;
        return $_;
      }
      if (/^\s*}\s*$/) {
        $clev -= 1;
        if ($cdur and $crud) {
          $cdur = 0; $crud = 0;
        }
        return $_;
      }
      if ($clev == 1) { # ought to never be anything but 0 or 1
                        # -> TODO: don’t rely on that
        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];
        # TODO: don’t rely on the measure not to change inside conc music!
        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 = ""; # parallel text inside &par
  sub par() { # single line parallel music
    /{{/; # 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 (old-style tuple declaration)
    my $tnum; # numerator
    my $tden; # denominator
    my $tstr; # resulting string
    my $tdur = 0; # aggregate sum of nominal duration
    sub times() { # simulating a FSM w/ outside states
                  # (basically a dispatcher w/ local memory)
      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() { # find a single note’s/a chord’s duration
    return 0 unless(/\D*(\d+)(\.*).*/); # ignore anything w/o duration
    my ($den, $dots, $num) = ($1, $2, 1);
    $num = 0 if (/</); # chord -> TODO: just ignore
    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; # where am I in this measure?
  # one func to rule them all
  sub haukified() { # line-wise pretty-print definitions into arrays
    if (/^\s*<<\s*$/) { # multi-line concurrent start
      $conc += 1;
      return $_;
    }
    if (/^\s*>>\s*$/) { # multi-line concurrent stop
      $conc -= 1;
      return $_;
    }
    return &conc($_) if ($conc > 1);
    #local $, = "|";
    return $_ if (/%/ or /repeat/ or /time / or /clef/ or /partial/ or /version/); # pipe single-line instructions that don’t need to be matched
    #if (/times/) {
    #  $idx += 1 unless ($#measures<2);
    #  return $_;
    #}
    # time key -> dynArt
    chomp $_;
    #times, repeat & bla = { … }; partial!
    # -> tokenstream vorbereiten (trb -> hooks)
    # -> repeat ought to occur in dynArt as well
    s/times\s*/times/g; # this glues the numerator to 'times'
    s/ ~/~/g; # this glues a tie to its left anchor, will be untied again
    /^(\s*)(.*)/;
    my $indent = $1;
    my @code = split(/\s+/, $2);
    my @parts; # prettified measures
    my $part = ""; # current measure’s text
    my $inpar = 0; # inside parallel section?
    for (@code) {
      if ($inpar) {
        if (/>>/) { # parallel stop
          $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 (/<</) { # parallel start
        $inpar = 1;
        next;
      }
      if ($intimes) {
        /{/; #vim bug
        if (/}/) { # tuplet stop
                   # -> TODO: maybe support curlies inside tuplets
          my ($text, $dur) = &times("stop");
          $part .= $text;
          $NUM += $dur;
        } else {
          &times("cont", $_);
          next;
        }
      }
      if (/times(\d+)\/(\d+)/) { # tuplet start
        &times("start", $1, $2);
        next;
      }
      $part .= "$_ ";
      if (/^\\(\S+)$/) { # definition start
        &align($defs{$1}, $1);
        next;
      }
      /{/; #vim bug
      $NUM += &duration($_) unless /}/;
      if ($NUM > $measures[$idx]) { # overfull measure
        print STDERR "error at measure " . ($idx+1) . " (local $measure) in (orig) $orig, (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;
        $measure += 1;
        $measures[$idx] //= $measures[$idx-1]; # for most simplistic dynArt
                                               # as well as for errors
        $NUM = 0;
        $part = $indent;
      }
    }
    if ($part =~ /\S/) { # still sth read left?
      push @parts, $part;
      print STDERR "underfull measure at (orig) $orig, measure " . ($idx+1) . " (local $measure)  ";
      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 ($#measures<2);
    }
    my $res = $indent;
    for (@parts) {
      s/~/ ~/g; # undoing the gluing ;-)
      $res .= $_ . "\n";
    }
    return $res;
    #return $indent . join("\n", map s/~/ ~/g, @parts);
  }
  my %aligned = ();
  sub align { # match a def against the dynArt definition’s measures
    my $bla = shift;
    my @out = ();
    my $name = shift;
    my $oldm = $measure;
    $measure = 1; # measure inside this def
    my $oldorig = $orig;
    $orig = $lines{$name}; # actual input file position
    for (@$bla) {
      if (/^\s*\\(\S+)\s*$/) { # call to another def
                               # -> TODO: beware of recursive calls
                               # well, we assume a sane user anyway …
        unless (/voice/) {
          print STDERR "$_"; # tell the caller we’re handling this
          &align($defs{$1}, $1);
        }
      }
      $n += 1;
      $orig += 1;
      push @out, $_ unless (/\d/); # pipe non-duration lines
    #print &haukified($_), "\n" if /\d/;
      push @out, &haukified($_) if /\d/;
    }
    $measure = $oldm; # restoring values …
    $orig = $oldorig;
    if ($aligned{$name}) { # already aligned this def
      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; # index into @skeleton
  sub align_voice() { # match a voice using &align
    #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() { # overall handling of everything read from <stimmen.ly>
    $orig += @{$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 stop
      $def = 0;
      my @bla = map $_, @current;
      $defs{$rhf[$#rhf]} = \@bla;
      @current = ();
    }
  }
  if (/^(\s*)(\S*) = \\relative/) { # def start
    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
    next;
  }
  push @current, $_;
}

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

# some settings # vim: et