view release on metacpan or  search on metacpan

script/hex2font.pl  view on Meta::CPAN

#!/usr/bin/perl -w
use strict;
use utf8;

my 	($rcs) = (' $Id: hex2font.pl,v 2.2 2025/08/09 23:21:05 vera Exp $ ' =~ /(\d+(\.\d+)+)/);

#warn substr '·', 0, 1;
# TODO:		
#	Redo looking for stars after reducing the maybe-stars - not productive for ideographics
#	Generalize logic of "somebody else's rays" to ignore also parts of curves which pass next to a star (see circled 17).

# Ends: Ees	Joins: *	Corners: L^v><		Curves: cCfF|-\/u
# Rest: x

my %opt = (coarse_blobs => 0, workaround_bug_expand => 1);
#warn "ARGV = <@ARGV>";
$opt{$1} = (defined($3) ? $3 : 1), shift while ($ARGV[0] || '') =~ /^--(\w+)(=(.*))?$/s;	#;
#$opt{mono} = 0 if $opt{nolayouts};		# But the name will be as if --nolayouts was not given
my $nostroke_rex = $opt{nostroke_rex} && qr/^($opt{nostroke_rex})$/i;
print "$rcs\n" and exit if exists $opt{version};
print(int($rcs*1000+0.5)."\n") and exit if exists $opt{iversion};
die "No version of original font specified" if $opt{sfd} and not exists $opt{oversion};

my $height = 16;		# Should be a multiple of 4
my @dx = (0,1,1,1,0,-1,-1,-1);	# Start from "up", go clockwise
my @dy = (-1,-1,0,1,1,1,0,-1);	# +-direction is "down"
my $can_convert_to_join = qr/[cCsef]/;	# special-case cCs later...  s appears more or less as a bug
my @onebit;
$onebit[1<<$_] = $_ + 1 for 0..8;
$| = 1;
my $fuzzier_adjacent;		# Hard to debug interaction of nearby stars introduced in 1.43
my $extend_tip = 1/3;		# Crashes of fontforge; see issues #3239 #3240 #3242
my $dejavu_sizes = $opt{DejaVu};
my($marked2, $marked) = 1;
$opt{marked} ||= 1 if $opt{marked2};

open my $fea, '>>', 'comb-fea' or die "Cannot open comb-fea for write" if $opt{mono} and $opt{nolayouts} and not $opt{nofea};

BEGIN { my $debug = 0;
	$debug++ while @ARGV and $ARGV[0] eq '-d' and shift;
        eval ( $debug ? 'sub dwarn { warn @_, ("@_" =~ /\n$/ ? q() : "\n") }' : 'sub dwarn {1}') ;
        eval "sub debug () { $debug }";
}

sub c_bits8 ($) { my $n = shift; my $o = 0; $n & (1<<$_) and $o++ for 0..7; $o}
my @c_bits = map c_bits8 $_, 0..0xFF;

_test_encodes_line(), exit if $opt{test_calc_line};

my %filter;
if (exists $opt{filterFile}) {
  my $str = do {local $/; open my $f, '<', $opt{'filterFile'} or die "Cannot open filterfile $opt{'filterFile'}"; <$f>};
  $str =~ s/^\x{feff}?##.*//mg;		# Skip comments and BOM
#  warn "<<$str>>";
  $str =~ s/\b([\dA-F]{4,6})\b/chr hex $1/gei;
  my @c = grep /\S/, split //, $str;
  @filter{@c} = (1) x @c;
}

my @rotate = ([0..0xFF],	# In 90deg increments, act on bitmaps of neighbors
	      [map 0xFF & (($_ << 2) | ($_ >> 6)), 0..0xFF]);
for my $i (2, 3) {
  my $prev = $i - 1;
  $rotate[$i] = [map $rotate[1][ $rotate[$prev][$_] ], 0..0xFF];
}

# Precalculate bitmap of neighbors for curves at angles ±1, ±2; assume we are at angle 0
my @neighb_0 = (	# Array of length 5 may be indexed by -2..2
  [],
  [1<<2, 1<<2, 1<<2, (1<<2) + (1<<1)],	# Array of length 4 may be indexed by -1..2
  [(1<<3) x 4],				# The index is the curvature of the curve (2 for undef)
  [(1<<5) x 4],
  [1<<6, (1<<6) + (1<<7), 1<<6, 1<<6]
);
my @neighb_1 = (	# Same assuming we are at angle 1; index is the relative angle
  [],
  [(1<<4) + (1<<3), 1<<4, 1<<4, (1<<4) + (1<<2)],	# Array of length 4 may be indexed by -1..2
  0,
  0,
  [(1<<6) + (1<<7), (1<<6) + (1<<0), 1<<6, 1<<6]
);

my($E, $ER, $ord) = ([], ['']);
END {die '$E corrupted: ' . "<@$E>" if $E and @$E}
my $ALLGOOD = [(1) x 8];
my $ALLcnt = 69671;	# Std .hex of Unifont for planes 0, 1, e contains this many (+.undef) non-fake entries
print STDERR "# (progressBar valid for full UniFont planes 0, 1, e)\n", '.' x int($ALLcnt/1000), "\r"; # print on 1000th, 2000th etc

sub sfd_start ($$);
my($px_size, $px_descent, $eps_px_size) = (64, 2, 1);
print sfd_start(16*$px_size, $px_descent*$px_size) if $opt{sfd};
my $charcnt = 0;
END {
  print << "END" if $opt{sfd};

EndChars
EndSplineFont
END
}

my %override;
if ($opt{overridefile}) {
  open my $f, '<', $opt{overridefile} or die "file `$opt{overridefile}': $!";
  while (<$f>) {
    next if not /\S/ or /^#/;
    die "unknown format of override line: `$_'" unless /^(\S+):([\da-f]+)$/i or /^(\.null):()$/i;
    $override{lc $1} = $2;
  }
  close $f or die "close `$opt{overridefile}': $!";
}

my $filter_rex = (defined $opt{only} ? ($opt{only} eq '.0' ? qr/^[.0]/ :
							     ($opt{only}) =~ /^\w$/ ? qr/^(?:$opt{only})...$/i