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