diff options
Diffstat (limited to 'hr/michi/haukify')
| -rw-r--r-- | hr/michi/haukify | 390 |
1 files changed, 390 insertions, 0 deletions
diff --git a/hr/michi/haukify b/hr/michi/haukify new file mode 100644 index 0000000..83cb531 --- /dev/null +++ b/hr/michi/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 × (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) = ×("stop"); + $part .= $text; + $NUM += $dur; + } else { + ×("cont", $_); + next; + } + } + if (/times(\d+)\/(\d+)/) { # tuplet start + ×("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 |