Acme-TextLayout
view release on metacpan or search on metacpan
Acme-TextLayout
Lay out patterns in Text, and provide facilities for mapping this to a
real-world coordinate space, and figuring out the relationship between
text blocks.
For example:
AAAABBBBBBBBBBBCCC
AAAABBBBBBBBBBBCCC
DDDDDDDDDDDDDDDCCC
EEEEEEEEEEEEEEECCC
FFFFFFFGGGGGGGGHHH
lib/Acme/TextLayout.pm view on Meta::CPAN
The only caveat is that the collection of like characters/symbols
making the pattern must be adjacent, and must be rectangular. And
the overall pattern must be rectangular.
Note that this textual arrangement can be as big as you want.
It's all relative. Although it might not look like it on
the screen in your editor of choice, all spacing is assummed to
be the same in X and Y. Thus, the aspect ratio of the above
pattern is 16/7 (width/height).
To be useful for a GUI, one must be able to map this goofy space
into screen coordinates. That's what the B<map_range> function is
for (see below).
Now, I know what you must be thinking: is this guy nuts? Why not
use brand-X fancy GUI layout tool? Well, the fact is that those
are nice and easy for the initial layout, but they generally generate
code with precise XY coordinates in them, which makes resizing almost
impossible.
The idea here is that we use the above textual layout to specify
all the relative positions of things, then map this to a real
coordinate system, preserving the spatial relativity and size
associations.
I wrote this for use in a GUI application, but figured it might have
use elsewhere. Hence, this class. If you find a novel use for it,
please let me know what it is (email address in this document).
=head1 METHODS
lib/Acme/TextLayout.pm view on Meta::CPAN
$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;
}
lib/Acme/TextLayout.pm view on Meta::CPAN
}
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) = @_;
my @text = @$textRef;
my $first;
map {
my $n = index $_, $char;
unless (defined $first) {
$first = $n if $n >= 0;
}
if (defined $first && $n >= 0) {
die "$.Class - char $char appears misaligned\n"
if $n < $first;
}
} @text;
return $first;
}
sub _last {
my ($self, $textRef, $char) = @_;
my @text = @$textRef;
my $last;
map {
my $n = rindex $_, $char;
unless (defined $last) {
$last = $n if $n >= 0;
}
if (defined $last && $n >= 0) {
die "$.Class - char $char appears misaligned\n"
if $n > $last;
}
} @text;
return $last;
}
sub _range {
my ($self, $textRef, $char) = @_;
my ($top, $bottom) = ./_vrange($textRef, $char);
my $left = ./_first($textRef, $char);
my $right = ./_last($textRef, $char);
return ($top, $bottom, $left, $right);
}
# simple equation to map char ranges to something else
sub _stretch_offset {
my ($self, $i1, $i2, $o1, $o2) = @_;
# handle single characters
$i2 = $i1 + 1 if $i1 == $i2;
my $stretch = ($o2-$o1)/($i2-$i1);
my $offset = $o1-($i1*$stretch);
return ($stretch, $offset);
}
=head2 B<range>
lib/Acme/TextLayout.pm view on Meta::CPAN
Return height of our pattern (in # characters).
=cut
sub height {
my ($self) = @_;
my $h = ./_height($.textRef);
return $h;
}
=head2 B<map_range>
@bbox = $tl->map_range($width, $height, $char);
Map the relative position and size of the indicated character ($char)
region in our pattern to a real XY coordinate space.
@bbox is the bounding box, returned as ($x1, $y1, $x2, $y2), where
$x1, $y1 is the upper left corner, and $x2, $y2 is the lower right.
Because this was written (primarily) to interface to a GUI,
the origin is assumed
to be 0,0 in the upper left corner, with x bigger to the right, and
y bigger down. Adjust as necessary to fit your problem domain.
=cut
sub map_range {
my ($self, $width, $height, $char) = @_;
my @r = @{$.Ranges{$char}};
my $h = ./_height($.textRef);
my $w = ./_widest($.textRef);
my ($xs, $xo) = ./_stretch_offset(0, $w, 0, $width);
my ($ys, $yo) = ./_stretch_offset(0, $h, 0, $height);
my $xEqn = sub { my ($x) = @_; my $y = $xs*$x + $xo; return $y; };
my $yEqn = sub { my ($y) = @_; my $x = $ys*$y + $yo; return $x; };
my $xmin = $xEqn->($r[2]);
my $ymin = $yEqn->($r[0]),
lib/Acme/TextLayout.pm view on Meta::CPAN
# find out if there is overlap; $c0 and $c1 are array references
sub _check_overlap {
my ($self, $c0, $c1) = @_;
my %x;
my @x0 = @$c0;
my @x1 = @$c1;
$x{$_} = 1 foreach $x0[0] .. $x0[1];
$x{$_} += 1 foreach $x1[0] .. $x1[1];
my $status;
map {
$status = 1 if $x{$_} > 1;
} keys(%x);
return defined $status ? 1 : 0;
}
# are they in same x range?
sub _in_x {
my ($self, $me, $other) = @_;
my @x = ($me->[2], $me->[3]);
my @xo = ($other->[2], $other->[3]);
lib/Acme/TextLayout.pm view on Meta::CPAN
=cut
sub above {
my ($self, $char) = @_;
my @r = @{$.Ranges{$char}};
return () if $r[0] == 0;
return @{$.Above{$char}} if defined $.Above{$char};
my @keys = keys(%.Ranges);
my @d;
map {
if ($_ ne $char) {
#print "Comparing $_ ";
my @other = @{$.Ranges{$_}};
push(@d, $_) if ./_in_x(\@r, \@other) &&
($other[0] == ($r[0]-1) || $other[1] == ($r[0]-1));
}
} @keys;
$.Above{$char} = \@d;
#print "Above $char @d\n";
return @d;
lib/Acme/TextLayout.pm view on Meta::CPAN
=cut
sub below {
my ($self, $char) = @_;
my @r = @{$.Ranges{$char}};
return () if $r[1] == ./width();
return @{$.Below{$char}} if defined $.Below{$char};
my @keys = keys(%.Ranges);
my @d;
map {
if ($_ ne $char) {
my @other = @{$.Ranges{$_}};
push(@d, $_) if ./_in_x(\@r, \@other) &&
($other[0] == ($r[0]+1) || $other[1] == ($r[0]+1));
}
} @keys;
$.Below{$char} = \@d;
return @d;
}
lib/Acme/TextLayout.pm view on Meta::CPAN
=cut
sub left {
my ($self, $char) = @_;
my @r = @{$.Ranges{$char}};
return () if $r[2] == 0;
return @{$.Left{$char}} if defined $.Left{$char};
my @keys = keys(%.Ranges);
my @d;
map {
if ($_ ne $char) {
my @other = @{$.Ranges{$_}};
push(@d, $_) if ./_in_y(\@r, \@other) &&
($other[3] == ($r[2]-1));
}
} @keys;
$.Left{$char} = \@d;
return @d;
}
lib/Acme/TextLayout.pm view on Meta::CPAN
=cut
sub right {
my ($self, $char) = @_;
my @r = @{$.Ranges{$char}};
return () if $r[2] == ./width();
return @{$.Right{$char}} if defined $.Right{$char};
my @keys = keys(%.Ranges);
my @d;
map {
if ($_ ne $char) {
my @other = @{$.Ranges{$_}};
push(@d, $_) if ./_in_y(\@r, \@other) &&
($other[2] == ($r[3]+1));
}
} @keys;
$.Right{$char} = \@d;
return @d;
}
lib/Acme/TextLayout.pm view on Meta::CPAN
sub order {
my ($self, $line) = @_;
$line = 0 unless defined $line;
die "$.Class - in order, line $line is too big!\n"
unless $line < ./height();
my $text = $.textRef[$line];
return unless defined $text;
my %Chars;
my @Chars;
my @chars = split('', $text);
map {
unless (defined $Chars{$_}) {
push(@Chars, $_);
$Chars{$_} = 1;
}
} @chars;
return @Chars;
}
=head2 B<only_one>
t/01-test.t view on Meta::CPAN
ok($tl->only_one() == 1);
$tl = Acme::TextLayout->new;
$pattern = <<'EOF';
AAAABBBBBB
AAAABBBBBB
EOF
ok($tl->instantiate(text => $pattern));
ok(check([qw(0.4 1)], $tl->range_as_percent('A')));
ok(check([qw(0.6 1)], $tl->range_as_percent('B')));
ok(check([qw(0 0 39 99)], $tl->map_range(100, 100, 'A')));
ok(check([qw(40 0 99 99)], $tl->map_range(100, 100, 'B')));
$pattern = <<'EOF';
AAAABBBBBB
AAAABBBBBB
CCCCDDDDDD
CCCCDDDDDD
EOF
ok($tl->instantiate(text => $pattern));
ok(check([qw(0.4 0.5)], $tl->range_as_percent('A')));
ok(check([qw(0.4 0.5)], $tl->range_as_percent('C')));
ok(check([qw(0.6 0.5)], $tl->range_as_percent('B')));
ok(check([qw(0.6 0.5)], $tl->range_as_percent('D')));
ok(check([qw(0 0 39 49)], $tl->map_range(100, 100, 'A')));
ok(check([qw(0 50 39 99)], $tl->map_range(100, 100, 'C')));
ok(check([qw(40 0 99 49)], $tl->map_range(100, 100, 'B')));
ok(check([qw(40 50 99 99)], $tl->map_range(100, 100, 'D')));
ok($tl->height()==4 && $tl->width()==10);
ok(check([qw(0 1 0 3)], $tl->range('A')));
ok(check([qw(2 3 0 3)], $tl->range('C')));
ok(check([qw(0 1 4 9)], $tl->range('B')));
ok(check([qw(2 3 4 9)], $tl->range('D')));
ok($tl->instantiate(file => 'data/foobar.dat'));
ok($tl->width()==5 && $tl->height()==3);
sub check {
my ($ref, @x) = @_;
my $status = 1;
if (@$ref != @x) {
print STDERR Dumper(\@x);
return 0;
}
map {
$status = 0 unless $ref->[$_] eq $x[$_];
} 0..$#x;
print STDERR Dumper(\@x) unless $status;
return $status;
}
( run in 0.934 second using v1.01-cache-2.11-cpan-3b35f9de6a3 )