File Coverage

blib/lib/Text/Hyphenate.pm

Criterion	Covered	Total	%
statement	138	155	89.0
branch	53	72	73.6
condition	9	9	100.0
subroutine	11	12	91.6
pod	0	8	0.0
total	211	256	82.4

package Text::Hyphenate;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
BEGIN { $DEBUG = 0 }
require Exporter;

@ISA = qw(Exporter);


my $h;

while () {
  last if /-{32}/;
  s/\r?\n$//;
#  print "--- $_\n";

  my ($tag, $value, $begin, $end);

  $begin = 1 if s/^\.//;
  $end = 1 if s/\.$//;
  s/(\D)(?!\d)/${1}0/g;
  s/^(?!\d)/0/;
  ($tag = lc $_) =~ tr/0-9//d;
  ($value = $_) =~ tr/0-9//cd;

#  print "$_: TAG $tag VALUE $value\n";
  if ($begin and $end) {
    $h->{both}{$tag} = $value;
  } elsif ($begin) {
    $h->{begin}{$tag} = $value;
  } elsif ($end) {
    $h->{end}{$tag} = $value;
  } else {
    $h->{hyphen}{$tag} = $value;
  }
}

while () {
  last if /-{32}/;
  chomp;
  my ($tag, $value);

  ($tag = lc $_) =~ tr/-//d;
  ($value = '0' . $_) =~ s/[^-](?!-)/0/g;
  $value =~ s/[^-]-/1/g;
  $value =~ tr/01/0/c;
  $h->{exact}{$tag} = $value;
}

@EXPORT_OK = qw(hyphenate fill_par);
$VERSION = '0.02';

use vars qw($RAGGED_RIGHT $RAGGED_LEFT $JUSTIFY $CENTER);
$RAGGED_RIGHT=0; $RAGGED_LEFT=1; $JUSTIFY=2;  $CENTER=3;

# hyphenate($long_string, $width, [$fill_mode]);
sub hyphenate {
  my (@chunks) = split(/(\n[ \t]*\n)/, $_[0]);
  my $result;
  while (@chunks) {
    local $^W = 0;
    my $par = hyphenate_par(shift @chunks, $_[1], $_[2]);
    $result .= $par . (shift @chunks);
  }
  $result;
}

my $PENALTY = 500;
{ my %cache;
  my $a = 50000/9;
  my $b = 40000/9;
  sub badness {
    my ($length, $target) = @_;
    my $bd = $cache{$length,$target};
    return $bd if defined $bd;
    return $cache{$length,$target} = 1000 if $length > $target;
    my $shortfall = ($target - $length)/$target;
    $bd = $cache{$length,$target} = ($shortfall * $a + $b) * $shortfall;
    $bd;
  }
}

sub hyphenate_par {
  my ($par, $target, $mode) = @_;
  my $result;
  my @wordsets = breakup_par($par, $target);
  my $i;
  for ($i=0; $i < @wordsets; $i++) {
    my $wordset = $wordsets[$i];
    $mode = $RAGGED_RIGHT if $i == $#wordsets && $mode == $JUSTIFY;
    $result .= align_words($wordset, $target, $mode);
    $result .= "\n";
  }
  $result;
}

sub align_words {
  my ($wds, $t, $mode) = @_;
  my $l;
  my $w;
  if ($mode != $JUSTIFY) {
    for $w (@$wds) {
      $l .= $w;
      $l .= ' ' unless $w =~ /-$/;
    }
    $l =~ s/\s+$//;
    my $mul = $mode == $RAGGED_LEFT  ? 1
            : $mode == $CENTER       ? 0.5 : 0
            ;
    $l = (' ' x ($mul * ($t - length $l))) . $l;
  } else {
    my $i;
    my @wds;
    my $tl;
    for ($i = 0; $i < @$wds; $i++) {
      local $^W = 0;
      $w = $wds->[$i];
      $tl += length $w;
      if ($w =~ /-$/) {
	push @wds, $w . $wds->[$i+1] ;
	$tl += length($wds->[$i+1]);
	++$i;
      } else {
	push @wds, $w;
      }
    }
    my $padding = $t - $tl;
    for ($i = 0; $i < @wds; $i++) {
      $l .= $wds[$i];
      last if $i == $#wds;
      my $spl = int($padding / ($#wds - $i) + .5);
      $padding -= $spl;
      $l .= (' ' x $spl);
    }
  }
  $l;
}

sub breakup_par {
  my ($par, $target) = @_;
  my ($r, $l) = ('', 0);
  my ($w, @ln);
  my @words = grep $_ ne '', split(/\s+|([\w\']+[^\w\s]*)/, $par);
#  print "Split into: (@words)\n";
  my @lines;

  while (defined($w = shift @words)) {
    my $wl = length $w;

    if ($wl + $l <= $target) {
      push @ln, $w;
      $l += length($w);
      $l += 1 unless $w =~ /-$/;
    } else {
      my $b = badness($l, $target);
      print "Badness of this line ($l/$target) is $b ($PENALTY)\n" if $DEBUG;
      if ($b >= $PENALTY) {
	my @splitpos = hyphen_pos($w);
	print "`$w' hyphenates at positions: (@splitpos).\n" if $DEBUG;
	my ($longest, $good_hyphen) = (0,0);
	for $longest (@splitpos) {
	  $good_hyphen=$longest, last if $longest + $l + 1 <= $target;
	}
	if ($good_hyphen) {
	  print "$good_hyphen is the best place to hyphenate `$w'.\n"
	    if $DEBUG;
	  push @ln, (substr($w, 0, $good_hyphen) . '-');
	  substr($w, 0, $good_hyphen) = '';
	} else {
	  print "No improvement from hyphenating `$w'.\n"
	    if $DEBUG;
	}
      }
      push @lines, [@ln];
      @ln = ();
      $l = 0;
      redo;
    }
  }
  push @lines, \@ln if @ln;
  @lines;
}

my ($LEFTMIN, $RIGHTMIN) = (2, 2);
sub hyphen_pos {
  hyphen_pos_aux($h, @_);
}

{ my %cache ;

  sub hyphen_pos_aux {
    my ($h, $word) = @_;

    return @{$cache{$word}} if exists $cache{$word};
    print STDERR "Hyphenate `$word'\n" if $DEBUG;

    my $exact = $h->{exact};
    if (defined(my $res = $exact->{$word})) {
      print STDERR "Exact match $res\n" if $DEBUG;
      my @result = split //, $res;
      my @result_list = reverse grep $result[$_] % 2, (0 .. $#result);
      $cache{$word} = \@result_list;
      return @result_list;
    }

    my $hyphen = $h->{hyphen};
    my $beginhyphen = $h->{begin};
    my $endhyphen = $h->{end};
    my $bothhyphen = $h->{both};

    my $totallength = length $word;
    my @result = (0) x ($totallength + 1);

    # walk the word
    my $rightstop = $totallength - $RIGHTMIN;
    my $pos;
    for ($pos = 0; $pos <= $rightstop; $pos++) {
      # length of the rest of the word
      my $restlength = $totallength - $pos;
      # length of a substring
      my $length;
      for ($length = 1; $length <= $restlength; $length++) {
	my $substr = substr $word, $pos, $length;
	my $value;
	my $j;
	my $letter;
	if (defined($value = $hyphen->{$substr})) {
	  $j = $pos;
	  print STDERR "$j: $substr: $value\n" if $DEBUG > 2;
	  while ($value =~ /(.)/gs) {
	    $result[$j] = $1 if ($1 > $result[$j]);
	    $j++;
	  }
	}
	if (($pos == 0) and
	    defined($value = $beginhyphen->{$substr})) {
	  $j = 0;
	  print STDERR "$j: $substr: $value\n" if $DEBUG > 2;
	  while ($value =~ /(.)/gs) {
	    $result[$j] = $1 if ($1 > $result[$j]);
	    $j++;
	  }
	}
	if (($restlength == $length) and
	    defined($value = $endhyphen->{$substr})) {
	  $j = $pos;
	  print STDERR "$j: $substr: $value\n" if $DEBUG > 2;
	  while ($value =~ /(.)/gs) {
	    $result[$j] = $1 if ($1 > $result[$j]);
	    $j++;
	  }
	}
      }
    }
    my $value;
    my $letter;
    if (defined($value = $bothhyphen->{$word})) {
      my $j = 0;
      print STDERR "$j: $word: $value\n" if $DEBUG > 2;
      while ($value =~ /(.)/gs) {
	$result[$j] = $1 if ($1 > $result[$j]);
	$j++;
      }
    }

    ### substr($result, 0, $LEFTMIN + 1) = '0' x ($LEFTMIN + 1);
    @result[0..$LEFTMIN-1] = ((0) x $LEFTMIN);
    @result[-$RIGHTMIN..-1] = ((0) x $RIGHTMIN);

    my @result_list = reverse grep $result[$_] % 2, (0 .. $#result);
    print STDERR "Result: @result_list\n" if $DEBUG;
    $cache{$word} = \@result_list;
    @result_list;
  }
}


# #########################################
# For a word show the result of hyphenation
#
sub hyphenate_word {
  my $pos;
  my ($word) = @_;
  for $pos (hyphen_pos_aux($h, $word)) {
    substr($word, $pos, 0) = "-";
  }
  $word;
}

1;
__DATA__