=head1 VERSION
-Version 0.01
+Version 0.02
=cut
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use Sub::Name ();
use Any::Moose;
+=head1 ATTRIBUTES
+
+=head2 C<mods>
+
+=cut
+
has '_mods' => (
- is => 'ro',
+ is => 'rw',
isa => 'Maybe[ArrayRef[LaTeX::TikZ::Mod::Formatted]]',
- init_arg => undef,
+ init_arg => 'mods',
default => sub { [ ] },
);
default => sub { +{ } },
);
-has '_body' => (
- is => 'rw',
- isa => 'LaTeX::TikZ::Scope|Str',
+=head2 C<body>
+
+=cut
+
+has 'body' => (
+ is => 'ro',
+ isa => 'LaTeX::TikZ::Scope|ArrayRef[Str]',
+ required => 1,
init_arg => 'body',
);
my $my_tc = LaTeX::TikZ::Tools::type_constraint(__PACKAGE__);
my $ltmf_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Formatted');
+my $body_tc = __PACKAGE__->meta->find_attribute_by_name('body')
+ ->type_constraint;
+
+around 'BUILDARGS' => sub {
+ my ($orig, $class, %args) = @_;
-sub mod {
+ my $mods = $args{mods};
+ if (defined $mods and ref $mods eq 'ARRAY') {
+ for my $mod (@$mods) {
+ $mod = $ltmf_tc->coerce($mod);
+ }
+ }
+
+ $class->$orig(%args);
+};
+
+sub BUILD {
my $scope = shift;
my $cache = $scope->_mods_cache;
- for (@_) {
- my $mod = $ltmf_tc->check($_) ? $_ : $ltmf_tc->coerce($_);
+ my @unique_mods;
+ for my $mod ($scope->mods) {
my $tag = $mod->tag;
next if exists $cache->{$tag};
$cache->{$tag} = $mod;
- push @{$scope->_mods}, $mod;
+ push @unique_mods, $mod;
}
-
- $scope;
+ $scope->_mods(\@unique_mods);
}
-sub body {
- my $scope = shift;
+=head1 METHODS
- if (@_) {
- $scope->_body($_[0]);
- $scope;
- } else {
- $scope->_body;
- }
-}
+=head2 C<flatten>
-use overload (
- '.' => \&concat,
- '""' => \&stringify,
-);
+=cut
sub flatten {
my ($scope) = @_;
do {
my $body = $scope->body;
return $scope unless $my_tc->check($body);
- $scope = $scope->new
- ->mod ($scope->mods, $body->mods)
- ->body($body->body)
+ $scope = $scope->new(
+ mods => [ $scope->mods, $body->mods ],
+ body => $body->body,
+ );
} while (1);
}
return \@left, \@common, \@right;
});
-sub concat {
- my ($scope, $str, $rev) = @_;
+=head2 C<instantiate>
- $scope = $scope->flatten;
-
- my $body = $scope->body;
- my @mods = $scope->mods;
-
- if ($my_tc->check($str)) {
- $str = $str->flatten;
+=cut
- my ($only_scope, $common, $only_str) = $inter->(
- $scope->_mods_cache,
- $str->_mods_cache,
- );
+sub instantiate {
+ my ($scope) = @_;
- if (@$common) {
- my $x = $scope->new
- ->mod(@$only_scope)
- ->body($body);
- my $y = $scope->new
- ->mod(@$only_str)
- ->body($str->body);
- ($x, $y) = ($y, $x) if $rev;
- return $scope->new
- ->mod(@$common)
- ->body($x . $y);
- }
- }
+ $scope = $scope->flatten;
my ($layer, @clips, @raw_mods);
- for (@mods) {
+ for ($scope->mods) {
my $type = $_->type;
if ($type eq 'clip') {
unshift @clips, $_->content;
}
}
+ my @body = @{$scope->body};
+
my $mods_string = @raw_mods ? ' [' . join(',', @raw_mods) . ']' : undef;
- if (@raw_mods and $body =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
- $body = "\\draw$mods_string $1\n"; # Has trailing semicolon
- $mods_string = undef; # Done with mods
+ if (@raw_mods and @body == 1 and $body[0] =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
+ $body[0] = "\\draw$mods_string $1"; # Has trailing semicolon
+ $mods_string = undef; # Done with mods
}
for (0 .. $#clips) {
my $clip_string = "\\clip $clip ;";
my $mods_string = ($_ == $#clips and defined $mods_string)
? $mods_string : '';
- 1 while chomp $body;
- $body = <<" CLIP";
-\\begin{scope}$mods_string
-$clip_string
-$body
-\\end{scope}
- CLIP
+ unshift @body, "\\begin{scope}$mods_string",
+ $clip_string;
+ push @body, "\\end{scope}",
}
if (not @clips and defined $mods_string) {
- 1 while chomp $body;
- $body = <<" MODS";
-\\begin{scope}$mods_string
-$body
-\\end{scope}
- MODS
+ unshift @body, "\\begin{scope}$mods_string";
+ push @body, "\\end{scope}";
}
if (defined $layer) {
- 1 while chomp $body;
- $body = <<" LAYER";
-\\begin{pgfonlayer}{$layer}
-$body
-\\end{pgfonlayer}
- LAYER
+ unshift @body, "\\begin{pgfonlayer}{$layer}";
+ push @body, "\\end{pgfonlayer}";
+ }
+
+ return @body;
+}
+
+=head2 C<fold>
+
+=cut
+
+sub fold {
+ my ($left, $right, $rev) = @_;
+
+ my (@left, @right);
+
+ if ($my_tc->check($left)) {
+ $left = $left->flatten;
+
+ if ($my_tc->check($right)) {
+ $right = $right->flatten;
+
+ my ($only_left, $common, $only_right) = $inter->(
+ $left->_mods_cache,
+ $right->_mods_cache,
+ );
+
+ my $has_different_layers;
+ for (@$only_left, @$only_right) {
+ if ($_->type eq 'layer') {
+ $has_different_layers = 1;
+ last;
+ }
+ }
+
+ if (!$has_different_layers and @$common) {
+ my $x = $left->new(
+ mods => $only_left,
+ body => $left->body,
+ );
+ my $y = $left->new(
+ mods => $only_right,
+ body => $right->body,
+ );
+ return $left->new(
+ mods => $common,
+ body => fold($x, $y, $rev),
+ );
+ } else {
+ @right = $right->instantiate;
+ }
+ } else {
+ $body_tc->assert_valid($right);
+ @right = @$right;
+ }
+
+ @left = $left->instantiate;
+ } else {
+ if ($my_tc->check($right)) {
+ return fold($right, $left, 1);
+ } else {
+ $body_tc->assert_valid($_) for $left, $right;
+ @left = @$left;
+ @right = @$right;
+ }
}
- $rev ? $str . $body : $body . $str;
+ $rev ? [ @right, @left ] : [ @left, @right ];
}
-sub stringify { $_[0]->concat('') }
+use overload (
+ '@{}' => sub { [ $_[0]->instantiate ] },
+);
__PACKAGE__->meta->make_immutable;
+=head1 SEE ALSO
+
+L<LaTeX::TikZ>.
+
=head1 AUTHOR
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
projects / perl / modules / LaTeX-TikZ.git / blobdiff