view release on metacpan or  search on metacpan

lib/Acme/TextLayout.pm  view on Meta::CPAN

=cut

sub new {
    my $class = shift;
    my %opts = @_;
    my $self = \%opts;
    bless $self, $class;
    $.Class = $class;
    return $self;
}

=head2 B<instantiate>

  $tl->instantiate(text => ??);
  -or-
  $tl->instantiate(file => ??);

Specify the textual layout pattern we are interested in, either
from a text string or a file.

Returns undef if something wrong with your input.

=cut

sub instantiate {
    my ($self, %opts) = @_;
    my $file = $opts{file};
    my $text = $opts{text};

    # reset state on new instantiation
    $.textRef = [];
    $.Ranges  = {};
    $.widest = undef;
    $.chars  = {};
    $.Above = $.Below = $.Left = $.Right = undef;

    if (defined $file) {
        my $fh = FileHandle->new($file);
        return unless defined $fh;
        my @text = <$fh>;
        $fh->close;
        chomp foreach @text;
        s/^\s+// foreach @text;
        $text = [ @text ];
        ./_widest(\@text);
    }
    elsif (defined $text) {
        my @text = split(/\n{1}/, $text);
        s/^\s+// foreach @text;
        $text = [ @text ];
        ./_widest(\@text);
    }
    else {
        return undef;
    }

    ./_whats_in_there($text);
    ./_widest($text);
    $.textRef = $text;
    map {
        return undef unless length($_) == $.widest;
    } @{$.textRef};

    my %Ranges;
    my %chars = %.chars;
    map {
        my $C = $_;
        my @d = ./range($C);
        $Ranges{$C} = \@d;
    } keys(%chars);

    $.Ranges = \%Ranges;
    print STDERR "Pattern appears disjoint\n" if ./_disjoint();
    return undef if ./_disjoint();
    # signify OK if we got here
    return 1;
}

# not a complete test, but tests for the obvious
sub _disjoint {
    my ($self) = @_;
    my @text = @{$.textRef};
    my @chars = ./characters();
    my $ok = 1;
    map {
        my $line = $_;
        map {
            my $n = 0;
            my $t = $line;
            $n++ while $t =~ s/$_{1,}//;
            $ok = 0 if $n > 1;
        } @chars;
    } @text;
    my $width = ./width();
    for (my $i=0; $i < $width; $i++) {
        my @new;
        push(@new, substr($_, $i, 1)) foreach @text;
        my $line = join('', @new);
        map {
            my $n = 0;
            my $t = $line;
            $n++ while $t =~ s/$_{1,}//;
            $ok = 0 if $n > 1;
        } @chars;
    }

    return $ok ? 0 : 1;
}

sub _widest {
    my ($self, $textRef) = @_;
    my @text = @$textRef;
    my $widest = length($text[0]);
    map {
        my $len = length($_);
        $widest = $len if $len > $widest;
    } @text;
    $.widest = $widest;
}

sub _height {
    my ($self, $textRef) = @_;
    my @text = @$textRef;
    return scalar(@text);
}

# figure out all characters in our pattern
sub _whats_in_there {
    my ($self, $aref) = @_;
    my @text = @$aref;
    #print "@text", "\n";
    my %chars;
    map {
        my $c = $_;
        my $C = chr($c);
        map {
            my $n;
            $chars{$C} = 1 if $_ =~ /\Q$C\E/;
            die "$.Class - space unacceptable in pattern\n"
                if $C eq " " && defined $chars{$C} && $chars{$C} == 1;
        } @text;
    } 1 .. 255;

    # preserve our character set
    $.chars = \%chars;
}

sub _right {
    my ($self, $text, $char) = @_;
    my @text = split(//, $text);
    my $first;
    my $last;
    if ($text =~ /$char/) {
        $first = pos($text);
        $last = rindex $text, $char;
    }
    return ($first, $last);
}

# determine vertical range of a specific character in our pattern
sub _vrange {
    my ($self, $textRef, $char) = @_;
    my $top;
    my $bottom;
    my $n = 0;
    map {
        $top    = $n if $_ =~ /$char/ && !defined $top;
        $bottom = $n if $_ =~ /$char/;
        $n++;
    } @$textRef;
    return ($top, $bottom);
}

sub _first {
    my ($self, $textRef, $char) = @_;