Hauke eingefügt

1 files changed, 385 insertions, 0 deletions

diff --git a/hr/michi/whitacre/haukify b/hr/michi/whitacre/haukify
new file mode 100644
index 0000000..857ed04
--- /dev/null
+++ b/hr/michi/whitacre/haukify
@@ -0,0 +1,385 @@
+#!/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