]> git.vpit.fr Git - perl/modules/LaTeX-TikZ.git/blob - TikZ/Scope.pm
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/LaTeX-TikZ.git] / TikZ / Scope.pm
1 package LaTeX::TikZ::Scope;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 LaTeX::TikZ::Scope - An object modeling a TikZ scope or layer.
9
10 =head1 VERSION
11
12 Version 0.01
13
14 =cut
15
16 our $VERSION = '0.01';
17
18 use Sub::Name ();
19
20 use LaTeX::TikZ::Tools;
21
22 use Any::Moose;
23
24 has '_mods' => (
25  is       => 'ro',
26  isa      => 'Maybe[ArrayRef[LaTeX::TikZ::Mod::Formatted]]',
27  init_arg => undef,
28  default  => sub { [ ] },
29 );
30
31 sub mods { @{$_[0]->_mods} }
32
33 has '_mods_cache' => (
34  is       => 'ro',
35  isa      => 'Maybe[HashRef[LaTeX::TikZ::Mod::Formatted]]',
36  init_arg => undef,
37  default  => sub { +{ } },
38 );
39
40 has '_body' => (
41  is       => 'rw',
42  isa      => 'LaTeX::TikZ::Scope|ArrayRef[Str]',
43  init_arg => 'body',
44 );
45
46 my $my_tc    = LaTeX::TikZ::Tools::type_constraint(__PACKAGE__);
47 my $ltmf_tc  = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Formatted');
48 my $_body_tc = __PACKAGE__->meta->find_attribute_by_name('_body')
49                                 ->type_constraint;
50
51 sub mod {
52  my $scope = shift;
53
54  my $cache = $scope->_mods_cache;
55
56  for (@_) {
57   my $mod = $ltmf_tc->coerce($_);
58   $ltmf_tc->assert_valid($mod);
59   my $tag = $mod->tag;
60   next if exists $cache->{$tag};
61   $cache->{$tag} = $mod;
62   push @{$scope->_mods}, $mod;
63  }
64
65  $scope;
66 }
67
68 sub body {
69  my $scope = shift;
70
71  if (@_) {
72   $scope->_body($_[0]);
73   $scope;
74  } else {
75   @{$scope->_body};
76  }
77 }
78
79 use overload (
80  '@{}' => 'dereference',
81 );
82
83 sub flatten {
84  my ($scope) = @_;
85
86  do {
87   my $body = $scope->_body;
88   return $scope unless $my_tc->check($body);
89   $scope = $scope->new
90                  ->mod ($scope->mods, $body->mods)
91                  ->body($body->_body)
92  } while (1);
93 }
94
95 my $inter = Sub::Name::subname('inter' => sub {
96  my ($lh, $rh) = @_;
97
98  my (@left, @common, @right);
99  my %where;
100
101  --$where{$_} for keys %$lh;
102  ++$where{$_} for keys %$rh;
103
104  while (my ($key, $where) = each %where) {
105   if ($where < 0) {
106    push @left,   $lh->{$key};
107   } elsif ($where > 0) {
108    push @right,  $rh->{$key};
109   } else {
110    push @common, $rh->{$key};
111   }
112  }
113
114  return \@left, \@common, \@right;
115 });
116
117 sub instantiate {
118  my ($scope) = @_;
119
120  $scope = $scope->flatten;
121
122  my ($layer, @clips, @raw_mods);
123  for ($scope->mods) {
124   my $type = $_->type;
125   if ($type eq 'clip') {
126    unshift @clips, $_->content;
127   } elsif ($type eq 'layer') {
128    confess("Can't apply two layers in a row") if defined $layer;
129    $layer = $_->content;
130   } else { # raw
131    push @raw_mods, $_->content;
132   }
133  }
134
135  my @body = $scope->body;
136
137  my $mods_string = @raw_mods ? ' [' . join(',', @raw_mods) . ']' : undef;
138
139  if (@raw_mods and @body == 1 and $body[0] =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
140   $body[0]     = "\\draw$mods_string $1"; # Has trailing semicolon
141   $mods_string = undef;                   # Done with mods
142  }
143
144  for (0 .. $#clips) {
145   my $clip        = $clips[$_];
146   my $clip_string = "\\clip $clip ;";
147   my $mods_string = ($_ == $#clips and defined $mods_string)
148                      ? $mods_string : '';
149   unshift @body, "\\begin{scope}$mods_string",
150                  $clip_string;
151   push    @body, "\\end{scope}",
152  }
153
154  if (not @clips and defined $mods_string) {
155   unshift @body, "\\begin{scope}$mods_string";
156   push    @body, "\\end{scope}";
157  }
158
159  if (defined $layer) {
160   unshift @body, "\\begin{pgfonlayer}{$layer}";
161   push    @body, "\\end{pgfonlayer}";
162  }
163
164  return @body;
165 }
166
167 sub dereference { [ $_[0]->instantiate ] }
168
169 sub fold {
170  my ($left, $right, $rev) = @_;
171
172  my (@left, @right);
173
174  if ($my_tc->check($left)) {
175   $left = $left->flatten;
176
177   if ($my_tc->check($right)) {
178    $right = $right->flatten;
179
180    my ($only_left, $common, $only_right) = $inter->(
181     $left->_mods_cache,
182     $right->_mods_cache,
183    );
184
185    my $has_different_layers;
186    for (@$only_left) {
187     if ($_->type eq 'layer') {
188      $has_different_layers = 1;
189      last;
190     }
191    }
192    unless ($has_different_layers) {
193     for (@$only_right) {
194      if ($_->type eq 'layer') {
195       $has_different_layers = 1;
196       last;
197      }
198     }
199    }
200
201    if (!$has_different_layers and @$common) {
202     my $x = $left->new
203                  ->mod(@$only_left)
204                  ->body($left->_body);
205     my $y = $left->new
206                  ->mod(@$only_right)
207                  ->body($right->_body);
208     return $left->new
209                 ->mod(@$common)
210                 ->body(fold($x, $y, $rev));
211    } else {
212     @right = $right->instantiate;
213    }
214   } else {
215    $_body_tc->assert_valid($right);
216    @right = @$right;
217   }
218
219   @left = $left->instantiate;
220  } else {
221   if ($my_tc->check($right)) {
222    return fold($right, $left, 1);
223   } else {
224    $_body_tc->assert_valid($_) for $left, $right;
225    @left  = @$left;
226    @right = @$right;
227   }
228  }
229
230  $rev ? [ @right, @left ] : [ @left, @right ];
231 }
232
233 __PACKAGE__->meta->make_immutable;
234
235 =head1 AUTHOR
236
237 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
238
239 You can contact me by mail or on C<irc.perl.org> (vincent).
240
241 =head1 BUGS
242
243 Please report any bugs or feature requests to C<bug-latex-tikz at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LaTeX-TikZ>.
244 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
245
246 =head1 SUPPORT
247
248 You can find documentation for this module with the perldoc command.
249
250     perldoc LaTeX::TikZ
251
252 =head1 COPYRIGHT & LICENSE
253
254 Copyright 2010 Vincent Pit, all rights reserved.
255
256 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
257
258 =cut
259
260 1; # End of LaTeX::TikZ::Scope