Hauke eingefügt

1 files changed, 390 insertions, 0 deletions

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