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