#!/usr/bin/perl -CDS

#
# OpenType anchor position generator for Tsukurimashou
# Copyright (C) 2011, 2012  Matthew Skala
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, version 3.
#
# As a special exception, if you create a document which uses this font, and
# embed this font or unaltered portions of this font into the document, this
# font does not by itself cause the resulting document to be covered by the
# GNU General Public License. This exception does not however invalidate any
# other reasons why the document might be covered by the GNU General Public
# License. If you modify this font, you may extend this exception to your
# version of the font, but you are not obligated to do so. If you do not
# wish to do so, delete this exception statement from your version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# Matthew Skala
# http://ansuz.sooke.bc.ca/
# mskala@ansuz.sooke.bc.ca
#

# workaround for "Windows insists on em=1000" issue
$original_em=1200;
$final_em=1000;
$em_ratio=$final_em/$original_em;

$otfeatures=shift;
$oldbfile=shift;
$newbfile=shift;

# read old bearings
open(OBF,$oldbfile);
while (<OBF>) {
  chomp;
  ($n,$b)=split(' ');
  $oldb{$n}=$b;
}
close(OBF);

# read new bearings
open(NBF,$newbfile);
while (<NBF>) {
  if (/Select\(0u([0-9a-f]+)\);SetLBearing\((-?\d+)\);/i) {
    $n=hex("0x$1");
    $newb{$n}=$2;
  }
}
close(NBF);

sub bearing_adjustment {
  my($n)=@_;
  if ((defined $oldb{$n}) && (defined $newb{$n})) {
    return $newb{$n}-$oldb{$n};
  } else {
    return 0;
  }
}

print "#\n# This is a GENERATED FILE.\n"
  ."# Edit the source code in make-gpos instead!\n#\n";

# read character list
open(CHARLIST,'chars.lst');
while (<CHARLIST>) {
   if (/(u|uni)([0-9a-f]+)/i) {
     $n=hex("0x$2");
     $charlist{$n}=1;
   }
}
close(CHARLIST);

# read proof files
foreach $fname (@ARGV) {
  $fname=~/-([0-9a-f]+)\./;
  $page=hex("0x$1");
  open(PRF,$fname);
  while (<PRF>) {
    chomp;
    if (/^BEGINGLYPH '(.*)' (\d+)$/) {
      $n=($page<<8)+$2;
      $glname{$n}=$1;
    } elsif (/^ENDGLYPH (-?[0-9\.]+) (-?[0-9\.]+)/) {
      if (($2>0) && ($ismark{$n})) {
        delete $ismark{$n};
      }
      if ($ismark{$n}) {
        foreach (keys %markclass) {
          $mkmk_exists{$_}=1 if $hasanc{"$n $_"};
        }
        $mark_exists{int($ismark{$n})}=1;
      } else {
        $isbase{$n}=1;
        while (($k,$v)=each %default_anchor) {
          if (!$hasanc{"$n $k"}) {
            ($x,$y)=split(' ',$v);
            $ancx{"$n $k"}=$em_ratio*$x+&bearing_adjustment($n);
            $ancy{"$n $k"}=$em_ratio*$y;
            $markclass{$k}=1;
            $hasanc{"$n $k"}=1;
          }
        }
      }
    } elsif (/^DEFAULTANCHOR\ (\d+)\ (FALSE|-?[0-9\.]+\ -?[0-9\.]+)/) {
      if ($2 eq 'FALSE') {
        delete $default_anchor{$1};
      } else {
        $default_anchor{$1}=$2;
      }
    } elsif (/^ANCHOR\ (-?\d+)\ (-?[0-9\.]+)\ (-?[0-9\.]+)
             \ (-?[0-9\.]+)\ (-?[0-9\.]+) /x) {
      $ancx{"$n $1"}=$em_ratio*($2+$4)/2+&bearing_adjustment($n);
      $ancy{"$n $1"}=$em_ratio*($3+$5)/2;
      $markclass{$1}=1;
      if ($1<0) {
        $ismark{$n}=-$1;
      } else {
        $hasanc{"$n $1"}=1;
      }
    }
  }
  close(PRF);
  %default_anchor=();
}

# friendly names for mark classes - should match mp/intro.mp but
# reasonably harmless if it doesn't, so probably not worth the
# extra data-passing to make that happen automagically
%mclassname=(
  1=>'MC_UPPER',
  2=>'MC_GRAVE',
  3=>'MC_ACUTE',
  4=>'MC_WIDE',
  5=>'MC_TILDE',
  6=>'MC_RING',
  7=>'MC_CARON_COMMA',
  8=>'MC_DAKUTEN',
  9=>'MC_LOWER',
  10=>'MC_LOWER_CONNECT',
  11=>'MC_CENTRE',
  12=>'MC_ICHING1',
  13=>'MC_ICHING2',
  14=>'MC_ICHING3',
  15=>'MC_ICHING4',
  16=>'MC_ICHING5',
  17=>'MC_ICHING6',
);

# mark feature
if ($otfeatures=~/mark/) {
  print "feature mark {\n";
  foreach $markclass (sort keys %mark_exists) {
    $mclassname{$markclass}="MARKCLASS_$markclass"
      if !defined $mclassname{$markclass};
    foreach $k (sort {$a <=> $b} keys %ismark) {
      $v=$ismark{$k};
      if ($v==$markclass) {
        printf "  markClass [%s] <anchor %d %d> @%s;\n",
          $glname{$k},int($ancx{"$k -$markclass"}),
          int($ancy{"$k -$markclass"}),$mclassname{$markclass};
      }
    }
  }
  print "\n";
  foreach $n (sort {$a <=> $b} keys %isbase) {
    $printed=0;
    foreach $markclass (sort keys %mark_exists) {
      if ($hasanc{"$n $markclass"}) {
        if ($printed) {
          print "\n    ";
        } else {
          print "  position base [$glname{$n}]\n    ";
          $printed=1;
        }
        printf "<anchor %d %d> mark @%s",
          int($ancx{"$n $markclass"}),int($ancy{"$n $markclass"}),
          $mclassname{$markclass};
      }
    }
    print ";\n" if $printed;
  }
  print "} mark;\n\n";
}

# mkmk feature
if ($otfeatures=~/mkmk/) {
  print "feature mkmk {\n";
  foreach $markclass (sort keys %mkmk_exists) {
    $mclassname{$markclass}="MARKCLASS_$markclass"
      if !defined $mclassname{$markclass};
    foreach $k (sort {$a <=> $b} keys %ismark) {
      $v=$ismark{$k};
      if ($v==$markclass) {
        printf "  markClass [%s] <anchor %d %d> @%s;\n",
          $glname{$k},int($ancx{"$k -$markclass"}),
          int($ancy{"$k -$markclass"}),$mclassname{$markclass};
      }
    }
  }
  print "\n";
  foreach $n (sort {$a <=> $b} keys %ismark) {
    $printed=0;
    foreach $markclass (sort keys %mkmk_exists) {
      if ($hasanc{"$n $markclass"} && $mark_exists{$markclass}) {
        if ($printed) {
          print "\n    ";
        } else {
          print "  position mark [$glname{$n}]\n    ";
          $printed=1;
        }
        printf "<anchor %d %d> mark @%s",
          int($ancx{"$n $markclass"}),int($ancy{"$n $markclass"}),
          $mclassname{$markclass};
      }
    }
    print ";\n" if $printed;
  }
  print "} mkmk;\n\n";
}
