use Any::Moose;
+=head1 ATTRIBUTES
+
+=head2 C<mods>
+
+=cut
+
has '_mods' => (
is => 'ro',
isa => 'Maybe[ArrayRef[LaTeX::TikZ::Mod::Formatted]]',
default => sub { +{ } },
);
+=head2 C<body>
+
+=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<mod>
+
+=cut
sub mod {
my $scope = shift;
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;
$scope;
}
+=head2 C<body>
+
+=cut
+
sub body {
my $scope = shift;
$scope->_body($_[0]);
$scope;
} else {
- $scope->_body;
+ @{$scope->_body};
}
}
use overload (
- '.' => \&concat,
- '""' => \&stringify,
+ '@{}' => 'dereference',
);
+=head2 C<flatten>
+
+=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);
}
return \@left, \@common, \@right;
});
-sub concat {
- my ($scope, $str, $rev) = @_;
+=head2 C<instantiate>
- $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;
}
}
+ 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}";
}
- $rev ? $str . $body : $body . $str;
+ return @body;
}
-sub stringify { $_[0]->concat('') }
+=head2 C<dereference>
+
+=cut
+
+sub dereference { [ $_[0]->instantiate ] }
+
+=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) {
+ 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;
projects / perl / modules / LaTeX-TikZ.git / blobdiff