X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FLaTeX%2FTikZ%2FScope.pm;h=8edad60f9d67019ebe1149ba72b06d603faf812e;hb=f54cadb836315572aa2c4bcb16f221da1687df7a;hp=7b2eadafe97da7c09de89e883c617d79cf7b39d8;hpb=e8f0879ade07eed4f58cd52c0771f4e1ecc90b09;p=perl%2Fmodules%2FLaTeX-TikZ.git diff --git a/lib/LaTeX/TikZ/Scope.pm b/lib/LaTeX/TikZ/Scope.pm index 7b2eada..8edad60 100644 --- a/lib/LaTeX/TikZ/Scope.pm +++ b/lib/LaTeX/TikZ/Scope.pm @@ -9,11 +9,11 @@ LaTeX::TikZ::Scope - An object modeling a TikZ scope or layer. =head1 VERSION -Version 0.01 +Version 0.02 =cut -our $VERSION = '0.01'; +our $VERSION = '0.02'; use Sub::Name (); @@ -21,6 +21,12 @@ use LaTeX::TikZ::Tools; use Any::Moose; +=head1 ATTRIBUTES + +=head2 C + +=cut + has '_mods' => ( is => 'ro', isa => 'Maybe[ArrayRef[LaTeX::TikZ::Mod::Formatted]]', @@ -37,14 +43,26 @@ has '_mods_cache' => ( default => sub { +{ } }, ); +=head2 C + +=cut + has '_body' => ( is => 'rw', - isa => 'LaTeX::TikZ::Scope|Str', + isa => 'LaTeX::TikZ::Scope|ArrayRef[Str]', 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 $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; + +=head1 METHODS + +=head2 C + +=cut sub mod { my $scope = shift; @@ -52,7 +70,8 @@ sub mod { my $cache = $scope->_mods_cache; for (@_) { - my $mod = $ltmf_tc->check($_) ? $_ : $ltmf_tc->coerce($_); + my $mod = $ltmf_tc->coerce($_); + $ltmf_tc->assert_valid($mod); my $tag = $mod->tag; next if exists $cache->{$tag}; $cache->{$tag} = $mod; @@ -62,6 +81,10 @@ sub mod { $scope; } +=head2 C + +=cut + sub body { my $scope = shift; @@ -69,24 +92,27 @@ sub body { $scope->_body($_[0]); $scope; } else { - $scope->_body; + @{$scope->_body}; } } use overload ( - '.' => \&concat, - '""' => \&stringify, + '@{}' => 'dereference', ); +=head2 C + +=cut + sub flatten { my ($scope) = @_; do { - my $body = $scope->body; + my $body = $scope->_body; return $scope unless $my_tc->check($body); $scope = $scope->new ->mod ($scope->mods, $body->mods) - ->body($body->body) + ->body($body->_body) } while (1); } @@ -112,38 +138,17 @@ my $inter = Sub::Name::subname('inter' => sub { return \@left, \@common, \@right; }); -sub concat { - my ($scope, $str, $rev) = @_; +=head2 C - $scope = $scope->flatten; +=cut - my $body = $scope->body; - my @mods = $scope->mods; - - if ($my_tc->check($str)) { - $str = $str->flatten; - - my ($only_scope, $common, $only_str) = $inter->( - $scope->_mods_cache, - $str->_mods_cache, - ); - - 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); - } - } +sub instantiate { + my ($scope) = @_; + + $scope = $scope->flatten; my ($layer, @clips, @raw_mods); - for (@mods) { + for ($scope->mods) { my $type = $_->type; if ($type eq 'clip') { unshift @clips, $_->content; @@ -155,11 +160,13 @@ sub concat { } } + 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) { @@ -167,40 +174,104 @@ sub concat { 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}"; } - $rev ? $str . $body : $body . $str; + return @body; } -sub stringify { $_[0]->concat('') } +=head2 C + +=cut + +sub dereference { [ $_[0]->instantiate ] } + +=head2 C + +=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) { + if ($_->type eq 'layer') { + $has_different_layers = 1; + last; + } + } + unless ($has_different_layers) { + for (@$only_right) { + if ($_->type eq 'layer') { + $has_different_layers = 1; + last; + } + } + } + + if (!$has_different_layers and @$common) { + my $x = $left->new + ->mod(@$only_left) + ->body($left->_body); + my $y = $left->new + ->mod(@$only_right) + ->body($right->_body); + return $left->new + ->mod(@$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 ? [ @right, @left ] : [ @left, @right ]; +} __PACKAGE__->meta->make_immutable; +=head1 SEE ALSO + +L. + =head1 AUTHOR Vincent Pit, C<< >>, L.