lib/LaTeX/TikZ/Mod/Clip.pm

   1 package LaTeX::TikZ::Mod::Clip;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Mod::Clip - A modifier that clips sequences with a path.
   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::Formatter;
  21 use LaTeX::TikZ::Mod::Formatted;
  22
  23 use LaTeX::TikZ::Functor;
  24
  25 use LaTeX::TikZ::Tools;
  26
  27 use Any::Moose;
  28
  29 with 'LaTeX::TikZ::Mod';
  30
  31 has clip => (
  32  is       => 'ro',
  33  does     => 'LaTeX::TikZ::Set::Op',
  34  required => 1,
  35 );
  36
  37 my $default_formatter = LaTeX::TikZ::Formatter->new(
  38  unit   => 'cm',
  39  format => '%.07f',
  40  scale  => 1,
  41 );
  42
  43 sub tag { ref $_[0] }
  44
  45 my $get_tc = do {
  46  my %tc;
  47
  48  Sub::Name::subname('get_tc' => sub {
  49   my ($class) = @_;
  50
  51   return $tc{$class} if exists $tc{class};
  52
  53   my $tc = LaTeX::TikZ::Tools::type_constraint($class);
  54   return unless defined $tc;
  55
  56   $tc{$class} ||= $tc;
  57  })
  58 };
  59
  60 my $cover_rectangle = Sub::Name::subname('cover_rectangle' => sub {
  61  my ($old, $new, $self_tc) = @_;
  62
  63  my $p = $new->from;
  64  my $q = $new->to;
  65
  66  my $x = $p->x;
  67  my $y = $p->y;
  68  my $X = $q->x;
  69  my $Y = $q->y;
  70
  71  ($x, $X) = ($X, $x) if $x > $X;
  72  ($y, $Y) = ($Y, $y) if $y > $Y;
  73
  74  if ($self_tc->check($old)) {
  75   # The old rectangle covers the new one if and only if it's inside the new.
  76
  77   for ($old->from, $old->to) {
  78    my $r = $_->x;
  79    return 0 if LaTeX::TikZ::Tools::numcmp($r, $x) < 0
  80             or LaTeX::TikZ::Tools::numcmp($X, $r) < 0;
  81    my $i = $_->y;
  82    return 0 if LaTeX::TikZ::Tools::numcmp($i, $y) < 0
  83             or LaTeX::TikZ::Tools::numcmp($Y, $i) < 0;
  84   }
  85
  86   return 1;
  87  }
  88
  89  return 0;
  90 });
  91
  92 my $cover_circle = Sub::Name::subname('cover_circle' => sub {
  93  my ($old, $new, $self_tc) = @_;
  94
  95  my $c2 = $new->center;
  96  my $r2 = $new->radius;
  97
  98  if ($self_tc->check($old)) {
  99   # The old circle covers the new one if and only if it's inside the new.
 100
 101   my $c1 = $old->center;
 102   my $r1 = $old->radius;
 103
 104   my $d = abs($c1 - $c2);
 105
 106   return    LaTeX::TikZ::Tools::numcmp($d, $r2)       <= 0
 107          && LaTeX::TikZ::Tools::numcmp($d + $r1, $r2) <= 0;
 108  }
 109
 110  return 0;
 111 });
 112
 113 my @handlers = (
 114  [ 'LaTeX::TikZ::Set::Rectangle' => $cover_rectangle ],
 115  [ 'LaTeX::TikZ::Set::Circle'    => $cover_circle    ],
 116 );
 117
 118 sub cover {
 119  my ($old, $new) = map $_->clip, @_[0, 1];
 120
 121  for (@handlers) {
 122   my $tc = $get_tc->($_->[0]);
 123   next unless defined $tc and $tc->check($new);
 124   return $_->[1]->($old, $new, $tc);
 125  }
 126
 127  $old->path($default_formatter) eq $new->path($default_formatter);
 128 }
 129
 130 sub declare { }
 131
 132 sub apply {
 133  my ($self) = @_;
 134
 135  LaTeX::TikZ::Mod::Formatted->new(
 136   type    => 'clip',
 137   content => $_[0]->clip->path($_[1]),
 138  )
 139 }
 140
 141 use LaTeX::TikZ::Interface clip => sub {
 142  shift;
 143
 144  __PACKAGE__->new(clip => $_[0]);
 145 };
 146
 147 LaTeX::TikZ::Functor->default_rule(
 148  (__PACKAGE__) => sub {
 149   my ($functor, $mod, @args) = @_;
 150   $mod->new(clip => $mod->clip->$functor(@args))
 151  }
 152 );
 153
 154 __PACKAGE__->meta->make_immutable;
 155
 156 =head1 AUTHOR
 157
 158 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 159
 160 You can contact me by mail or on C<irc.perl.org> (vincent).
 161
 162 =head1 BUGS
 163
 164 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>.
 165 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 166
 167 =head1 SUPPORT
 168
 169 You can find documentation for this module with the perldoc command.
 170
 171     perldoc LaTeX::TikZ
 172
 173 =head1 COPYRIGHT & LICENSE
 174
 175 Copyright 2010 Vincent Pit, all rights reserved.
 176
 177 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 178
 179 =cut
 180
 181 1; # End of LaTeX::TikZ::Mod::Clip