#!/usr/bin/perl

# LSDJ microtuning script
# JHL (abrasive) 2009
# tested with LSDJ 3.9.9

use Data::Dumper;
use Carp;
use File::Copy;

print "lsdj_tune 1.0 -- for LSDJ 3.9.9 - abrasive 23/3/2009\n";

sub freq2reg {
    my $freq, $reg;
    my @regs;
    while ($freq = shift) {
        $reg = int(2048.5-131072/$freq);
        if ($reg <= 0) {
            $reg = 1;
            print "Warning: frequency too low ($freq Hz)\n";
        }
        if ($reg >= 2048) {
            $reg = 2047;
            print "Warning: frequency too high ($freq Hz)\n";
        }
        push @regs, $reg;
    }
    return @regs;
}

sub reg2freq {
    my $reg;
    my @freqs;
    while ($reg = shift) {
        push @freqs, 131072/(2048-$reg);
    }
    return @freqs;
}

sub tuneerr($$) {
    my ($dfreqs, $afreqs) = @_;
    my @cent_err, @hz_err;
    my $i;
    for ($i=0; $i<=$#{$dfreqs}; $i++) {
        $hz_err[$i] = $afreqs->[$i]-$dfreqs->[$i];
        $cent_err[$i] = 1200*log( $afreqs->[$i]/$dfreqs->[$i] )/log(2);
    }
    return (\@cent_err, \@hz_err);
}

my @note_names = ('C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B');
sub nam2num {
    my $name = shift;
    return -1 unless $name =~ /^([A-G]|[ACDFG]\#) *([3-9AB])$/i;
    my $octave = hex($2)-3;
    for (my $i=0; $i<=$#note_names; $i++) {
        if ($note_names[$i] eq uc($1)) {
            return $i+$octave*12;
        }
    }
    return -1;
}
sub num2nam {   # for display only
    my $num = shift;
    return '   ' if ($num<0) || ($num >= 108);
    my $oct = int($num/12);
    my $note = $num % 12;
    return sprintf("%-2s%1X", $note_names[$note], $oct+3);
}

sub min($$) {
    my ($a, $b) = @_;
    return $a<$b ? $a : $b;
}

sub rep_cent_tune {
    my ($basenote, $basefreq, $centarr) = @_;
    my $looplen = $#{$centarr};

    my @cents, @freqs;
    my $notes_remain = 108;
    my $centrun = 0;
    my $centstep = $centarr->[$#{$centarr}];

    my $offset = $basenote % $looplen;

    if ($offset) {
        push @cents, $centarr->[$looplen-$offset..$looplen];
        $notes_remain -= $offset;
        $centrun += $centstep;
    }

    while ($notes_remain>0) {
        for (my $i=0; $i<min($looplen, $notes_remain); $i++) {
            push @cents, $centarr->[$i]+$centrun;
        }
        $centrun += $centstep;
        $notes_remain -= min($looplen, $notes_remain);
    }

    my $base_cent = $cents[$basenote];
    foreach (@cents) {
        push @freqs, $basefreq * 2**(($_-$base_cent)/1200);
    }
    return @freqs;
}

sub print_tuning {
    my ($freqs, $regs) = @_;
    my @gbfreqs = reg2freq(@{$regs});
    my ($cent_err, $hz_err) = tuneerr($freqs, \@gbfreqs);
           #C 3    65.41  002C    65.41      -0.00  -0.03
    print "       Freq   Reg    Actual   Error\n";
    print "        (hz)           (hz)         Hz    cent\n";

    for (my $i=0; $i<108; $i++) {
        print num2nam($i) . " ";
        printf("%8.2f  ", $freqs->[$i]);
        printf("%04X ", $regs->[$i]);
        printf("%8.2f ", $gbfreqs[$i]);
print "  ";
        printf("%+8.2f %+7.2f", $hz_err->[$i], $cent_err->[$i]);
        print "\n";
    }
}

sub usage {
    print <<USAGE
Usage:
    Pregenerated tuning:
        --freq-table <filename>     for 108 freqs, one per line
                                        starting with C3
    Generated tuning:
  -b    --base <note> <freq>        define the fixed-point        
                                        (required for generated tuning)
  -e    --et N              N-tone equal temperament
        --cstep N           equal steps of N cents
        --fstep N           fixed frequency step
        --cents X,Y,Z       specify a series in cents
                                eg. 0,100,200...1200 is 12-tone ET
        --ratio X,Y,Z       ratio tuning
                                eg. 1,81/80,33/32,2

    ROM handling:
  -r    --rom <romfile>     the LSDJ ROM to use as source
  -o    --out <outfile>     file to write the tuned ROM into
    
    Misc:
  -q    --quiet             don't print the tuning table
USAGE
;
exit(1);
#confess("No!");
}

sub eat_cmdline {
    my $method = undef;
    my $basenote = undef;
    my $basefreq = undef;
    my $nparam;
    my $outfile = undef;
    my $infile = undef;
    my $quiet = 0;
    my $rom = undef;
    
    while ($_=shift) {
        (/^--et$/ || /^-e$/) && do {
            usage() if defined($method);
            $method = 'et';
            $nparam = shift;
            usage() unless $nparam>0;
            next;
            };
        (/^--cstep$/) && do {
            usage() if defined($method);
            $method = 'cstep';
            $nparam = shift;
            usage() unless $nparam>0;
            next;
            };
        (/^--fstep$/) && do {
            usage() if defined($method);
            $method = 'fstep';
            $nparam = shift;
            usage() unless $nparam>0;
            next;
            };
        (/^--cents$/) && do {
            usage() if defined($method);
            $method = 'cents';
            $nparam = shift;
            usage() unless $nparam;
            next;
            };
        (/^--ratio$/) && do {
            usage() if defined($method);
            $method = 'ratio';
            $nparam = shift;
            usage() unless $nparam;
            next;
            };
        (/^--base$/ || /^-b$/) && do {
            $basenote = nam2num(shift);
            usage() if ($basenote<0);
            $basefreq = shift; 
            usage() if $basefreq <= 0;
            next;
            };
        (/^--freq-table$/) && do {
            usage() if defined($method);
            $method = 'ftable';
            $infile = shift;
            next;
            };
        (/^--out$/ || /^-o$/) && do {
            $outfile = shift;
            next;
            };
        (/^--quiet$/ || /^-q$/) && do {
            $quiet = 1;
            next;
            };
        (/^--rom$/ || /^-r$/) && do {
            $rom = shift;
            next;
            };
        usage();
    }
    usage() if $method ne 'ftable' && !defined($basefreq);
    usage() if defined($outfile) && !defined($rom);
    return {'method' => $method,
            'nparam' => $nparam,
            'infile' => $infile,
            'outfile' => $outfile,
            'basenote' => $basenote,
            'basefreq' => $basefreq,
            'rom' => $rom,
            'quiet' => $quiet};
}


my $args = eat_cmdline(@ARGV);

my $method = $args->{method};
my @freqs = ();
if ($method eq 'ftable') {
    open FIN, '<', $args->{infile} || die("Could not open input file!");
    for (<FIN>) {
        /([0-9]+(\.[0-9]+)?)/ && do {
            print "freq $1\n";
            push @freqs, $1;
            }
    }
    close FIN;
    my $nfreqs = $#freqs+1;
    die ("File contains $nfreqs entries, expected 108!") if ($nfreqs != 108);
} else {
    if ($method eq 'fstep') {
        die("not implemented");
    } elsif ($method eq 'cstep') {
        @freqs = rep_cent_tune($args->{basenote},
                               $args->{basefreq},
                               [0, $args->{nparam}]);
    } elsif ($method eq 'et') {
        @freqs = rep_cent_tune($args->{basenote},
                               $args->{basefreq},
                               [0, 1200/$args->{nparam}]);
    } elsif ($method eq 'cents') {
        my @cents = split(/,/, $args->{nparam});
        @freqs = rep_cent_tune($args->{basenote},
                               $args->{basefreq},
                               \@cents);
    } elsif ($method eq 'ratio') {
        my @ratios = split(/,/, $args->{nparam});
        my @cents;
        foreach (@ratios) {
            /^([0-9]+)\/([0-9]+)$/ && do {
                push @cents, log($1/$2)/log(2)*1200;
                };
            /^([0-9]+(\.[0-9+])?)$/ && do {
                push @cents, log($1)/log(2)*1200;
                };
        }
        @freqs = rep_cent_tune($args->{basenote},
                               $args->{basefreq},
                               \@cents);
    }
}

my @regs = freq2reg(@freqs);
print_tuning(\@freqs, \@regs) unless $args->{quiet};


if (defined($args->{outfile})) {
    print "Writing tuned ROM to " . $args->{outfile} . "\n";
    copy($args->{rom}, $args->{outfile}) or die("Could not create output file!");
    open FOUT, '+<', $args->{outfile} or die("Could not open output file!");
    my $table = pack('S*', @regs);
    my $tab_offset = 0x6f69;    # XXX: more than LSDJ399!
    seek FOUT, $tab_offset, SEEK_SET;
    
    print FOUT $table;
    close FOUT;
}