From: Vincent Pit Date: Thu, 22 Jul 2010 14:22:22 +0000 (+0200) Subject: Introduce LaTeX::TikZ::Functor X-Git-Tag: v0.01~16 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;ds=inline;h=92147217516a40b35ca00c8e08939e8aa5478426;p=perl%2Fmodules%2FLaTeX-TikZ.git Introduce LaTeX::TikZ::Functor --- diff --git a/MANIFEST b/MANIFEST index d9cbbf4..f64fe45 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5,6 +5,7 @@ Makefile.PL README lib/LaTeX/TikZ.pm lib/LaTeX/TikZ/Formatter.pm +lib/LaTeX/TikZ/Functor.pm lib/LaTeX/TikZ/Interface.pm lib/LaTeX/TikZ/Meta/TypeConstraint/Autocoerce.pm lib/LaTeX/TikZ/Mod.pm @@ -43,4 +44,5 @@ t/20-mod.t t/21-layer.t t/22-clip.t t/23-pattern.t +t/30-functor.t t/91-pod.t diff --git a/lib/LaTeX/TikZ/Functor.pm b/lib/LaTeX/TikZ/Functor.pm new file mode 100644 index 0000000..e302d3f --- /dev/null +++ b/lib/LaTeX/TikZ/Functor.pm @@ -0,0 +1,168 @@ +package LaTeX::TikZ::Functor; + +use strict; +use warnings; + +=head1 NAME + +LaTeX::TikZ::Functor - Build functor methods that recursively visit nodes of a LaTeX::TikZ::Set tree. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +use Carp (); + +use Sub::Name (); + +use LaTeX::TikZ::Tools; + +use Any::Moose 'Util' => [ 'does_role' ]; + +my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set'); + +my @default_set_rules; +my @default_mod_rules; + +my ($validate_rule, $insert_rule); +BEGIN { + $validate_rule = Sub::Name::subname('validate_rule' => sub { + my ($target, $handler) = @_; + + unless (defined $target and ref $target eq '' + and $target =~ /[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*/) { + Carp::confess("Invalid target $target"); + } + + (my $pm = $target) =~ s{::}{/}g; + $pm .= '.pm'; + require $pm; + + my $is_set; + if (does_role($target, 'LaTeX::TikZ::Set')) { + $is_set = 1; + } elsif (does_role($target, 'LaTeX::TikZ::Mod')) { + $is_set = 0; + } else { + Carp::confess("Target $target is neither a set nor a mod"); + } + + Carp::confess("Invalid handler for target $target") + unless ref $handler eq 'CODE'; + + return [ $target, $handler, $is_set ]; + }); + + $insert_rule = Sub::Name::subname('insert_rule' => sub { + my ($rule, $list) = @_; + + my $spec = $rule->[0]; + for my $i (0 .. $#$list) { + my $old_spec = $list->[$i]->[0]; + if ($old_spec->isa($spec) or does_role($old_spec, $spec)) { + splice @$list, $i, 1, $rule; + return 1; + } + } + + push @$list, $rule; + return $#$list; + }); +} + +sub default_rule { + shift; + + my $rule = $validate_rule->(@_); + + $insert_rule->($rule, $rule->[2] ? \@default_set_rules : \@default_mod_rules); +} + +sub new { + my ($class, %args) = @_; + + my @set_rules = @default_set_rules; + my @mod_rules = @default_mod_rules; + + my @user_rules = @{$args{rules} || []}; + while (@user_rules) { + my ($target, $handler) = splice @user_rules, 0, 2; + + my $rule = $validate_rule->($target, $handler); + + $insert_rule->($rule, $rule->[2] ? \@set_rules : \@mod_rules); + } + + my %dispatch = map { $_->[0] => $_ } @set_rules, @mod_rules; + + my $self; + + $self = bless sub { + my $set = shift; + + $lts_tc->assert_valid($set); + + my $rule = $dispatch{ref($set)}; + unless ($rule) { + ($set->isa($_->[0]) or $set->does($_->[0])) and $rule = $_ for @set_rules; + $rule = [ undef, sub { $_[1] } ] unless $rule; + } + my $new_set = $rule->[1]->($self, $set, @_); + my $is_new = $new_set ne $set; + + my @new_mods; +MOD: + for my $mod ($set->mods) { + my $rule = $dispatch{ref($mod)}; + unless ($rule) { + ($mod->isa($_->[0]) or $mod->does($_->[0])) and $rule = $_ for @mod_rules; + unless ($rule) { + push @new_mods, $mod; + next MOD; + } + } + push @new_mods, $rule->[1]->($self, $mod, @_); + } + + $new_set->mod(@new_mods) if $is_new; + + return $new_set; + }, $class; +} + +use LaTeX::TikZ::Interface functor => sub { + shift; + + __PACKAGE__->new(rules => \@_); +}; + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc LaTeX::TikZ + +=head1 COPYRIGHT & LICENSE + +Copyright 2010 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of LaTeX::TikZ::Functor diff --git a/lib/LaTeX/TikZ/Interface.pm b/lib/LaTeX/TikZ/Interface.pm index b9371f6..fa5da48 100644 --- a/lib/LaTeX/TikZ/Interface.pm +++ b/lib/LaTeX/TikZ/Interface.pm @@ -55,6 +55,7 @@ sub register { sub load { require LaTeX::TikZ::Formatter; # formatter + require LaTeX::TikZ::Functor; # functor require LaTeX::TikZ::Set::Raw; # raw diff --git a/lib/LaTeX/TikZ/Mod/Clip.pm b/lib/LaTeX/TikZ/Mod/Clip.pm index ee08e41..3f5454e 100644 --- a/lib/LaTeX/TikZ/Mod/Clip.pm +++ b/lib/LaTeX/TikZ/Mod/Clip.pm @@ -20,6 +20,8 @@ use Sub::Name (); use LaTeX::TikZ::Formatter; use LaTeX::TikZ::Mod::Formatted; +use LaTeX::TikZ::Functor; + use LaTeX::TikZ::Tools; use Any::Moose; @@ -142,6 +144,13 @@ use LaTeX::TikZ::Interface clip => sub { __PACKAGE__->new(clip => $_[0]); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $mod, @args) = @_; + $mod->new(clip => $mod->clip->$functor(@args)) + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Circle.pm b/lib/LaTeX/TikZ/Set/Circle.pm index f1bbeab..a4bc64c 100644 --- a/lib/LaTeX/TikZ/Set/Circle.pm +++ b/lib/LaTeX/TikZ/Set/Circle.pm @@ -17,6 +17,8 @@ our $VERSION = '0.01'; use LaTeX::TikZ::Set::Point; +use LaTeX::TikZ::Functor; + use LaTeX::TikZ::Tools; use Any::Moose; @@ -55,6 +57,16 @@ use LaTeX::TikZ::Interface circle => sub { __PACKAGE__->new(center => $_[0], radius => $_[1]); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new( + center => $set->center->$functor(@args), + radius => $set->radius, + ); + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Line.pm b/lib/LaTeX/TikZ/Set/Line.pm index 13c4618..819ccb9 100644 --- a/lib/LaTeX/TikZ/Set/Line.pm +++ b/lib/LaTeX/TikZ/Set/Line.pm @@ -17,6 +17,8 @@ our $VERSION = '0.01'; use LaTeX::TikZ::Set::Point; +use LaTeX::TikZ::Functor; + use Any::Moose; with 'LaTeX::TikZ::Set::Op'; @@ -47,6 +49,13 @@ use LaTeX::TikZ::Interface line => sub { __PACKAGE__->new(from => $_[0], to => $_[1]); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new(map { $_ => $set->$_->$functor(@args) } qw/from to/) + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Path.pm b/lib/LaTeX/TikZ/Set/Path.pm index 18b9020..11ea106 100644 --- a/lib/LaTeX/TikZ/Set/Path.pm +++ b/lib/LaTeX/TikZ/Set/Path.pm @@ -15,6 +15,8 @@ Version 0.01 our $VERSION = '0.01'; +use LaTeX::TikZ::Functor; + use Any::Moose; use Any::Moose 'Util::TypeConstraints' => [ qw/subtype as where find_type_constraint/ ]; @@ -61,6 +63,13 @@ use LaTeX::TikZ::Interface path => sub { __PACKAGE__->new(ops => \@_); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new(ops => [ map $_->$functor(@args), $set->ops ]) + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Point.pm b/lib/LaTeX/TikZ/Set/Point.pm index eee96b0..3b43c99 100644 --- a/lib/LaTeX/TikZ/Set/Point.pm +++ b/lib/LaTeX/TikZ/Set/Point.pm @@ -17,6 +17,8 @@ our $VERSION = '0.01'; use LaTeX::TikZ::Point; +use LaTeX::TikZ::Functor; + use Any::Moose; use Any::Moose 'Util::TypeConstraints'; @@ -55,6 +57,13 @@ use LaTeX::TikZ::Interface point => sub { __PACKAGE__->new(point => $point); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new(point => $set->point); + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Polyline.pm b/lib/LaTeX/TikZ/Set/Polyline.pm index ef339e4..76656af 100644 --- a/lib/LaTeX/TikZ/Set/Polyline.pm +++ b/lib/LaTeX/TikZ/Set/Polyline.pm @@ -17,6 +17,8 @@ our $VERSION = '0.01'; use LaTeX::TikZ::Set::Point; +use LaTeX::TikZ::Functor; + use Any::Moose; use Any::Moose 'Util::TypeConstraints'; @@ -66,6 +68,16 @@ use LaTeX::TikZ::Interface closed_polyline => sub { __PACKAGE__->new(points => \@_, closed => 1); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new( + points => [ map $_->$functor(@args), $set->points ], + closed => $set->closed, + ); + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Raw.pm b/lib/LaTeX/TikZ/Set/Raw.pm index 169569f..d96fc3b 100644 --- a/lib/LaTeX/TikZ/Set/Raw.pm +++ b/lib/LaTeX/TikZ/Set/Raw.pm @@ -15,6 +15,8 @@ Version 0.01 our $VERSION = '0.01'; +use LaTeX::TikZ::Functor; + use Any::Moose; with 'LaTeX::TikZ::Set::Op'; @@ -33,6 +35,13 @@ use LaTeX::TikZ::Interface raw => sub { __PACKAGE__->new(content => join ' ', @_); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new(content => $set->content); + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Rectangle.pm b/lib/LaTeX/TikZ/Set/Rectangle.pm index 8e585bc..f70595d 100644 --- a/lib/LaTeX/TikZ/Set/Rectangle.pm +++ b/lib/LaTeX/TikZ/Set/Rectangle.pm @@ -17,6 +17,8 @@ our $VERSION = '0.01'; use LaTeX::TikZ::Set::Point; +use LaTeX::TikZ::Functor; + use Any::Moose; with 'LaTeX::TikZ::Set::Op'; @@ -97,6 +99,13 @@ use LaTeX::TikZ::Interface rectangle => sub { ); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new(map { $_ => $set->$_->$functor(@args) } qw/from to/) + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/lib/LaTeX/TikZ/Set/Sequence.pm b/lib/LaTeX/TikZ/Set/Sequence.pm index fe32f14..a92ad89 100644 --- a/lib/LaTeX/TikZ/Set/Sequence.pm +++ b/lib/LaTeX/TikZ/Set/Sequence.pm @@ -19,6 +19,8 @@ use List::Util (); use LaTeX::TikZ::Scope; +use LaTeX::TikZ::Functor; + use Any::Moose; use Any::Moose 'Util::TypeConstraints' => [ qw/subtype as where find_type_constraint/ ]; @@ -70,6 +72,13 @@ use LaTeX::TikZ::Interface seq => sub { __PACKAGE__->new(kids => \@_); }; +LaTeX::TikZ::Functor->default_rule( + (__PACKAGE__) => sub { + my ($functor, $set, @args) = @_; + $set->new(kids => [ map $_->$functor(@args), $set->kids ]) + } +); + __PACKAGE__->meta->make_immutable; =head1 AUTHOR diff --git a/t/00-load.t b/t/00-load.t index f5e995c..8db1dec 100644 --- a/t/00-load.t +++ b/t/00-load.t @@ -3,11 +3,12 @@ use strict; use warnings; -use Test::More tests => 32; +use Test::More tests => 33; BEGIN { use_ok( 'LaTeX::TikZ' ); use_ok( 'LaTeX::TikZ::Formatter' ); + use_ok( 'LaTeX::TikZ::Functor' ); use_ok( 'LaTeX::TikZ::Interface' ); use_ok(' LaTeX::TikZ::Meta::TypeConstraint::Autocoerce' ); use_ok( 'LaTeX::TikZ::Mod' ); diff --git a/t/01-api.t b/t/01-api.t index 78b5621..3eea9d9 100644 --- a/t/01-api.t +++ b/t/01-api.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 5 + 18 + 12; +use Test::More tests => 5 + 20 + 12; use LaTeX::TikZ; @@ -29,6 +29,7 @@ is(prototype('Tikz'), '', 'main::Tikz is actually a constant'); } my @methods = qw/ + formatter functor raw path seq point line polyline closed_polyline rectangle circle arc arrow diff --git a/t/30-functor.t b/t/30-functor.t new file mode 100644 index 0000000..347b539 --- /dev/null +++ b/t/30-functor.t @@ -0,0 +1,121 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 4 + 2 * 4; + +use LaTeX::TikZ; + +my $tikz = Tikz->formatter( + format => '%d', +); + +sub check { + my ($set, $desc, $exp) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + my ($head, $decl, $body) = eval { + $tikz->render(ref $set eq 'ARRAY' ? @$set : $set); + }; + is $@, '', "$desc: no error"; + + unless (ref $exp eq 'ARRAY') { + $exp = [ split /\n/, $exp ]; + } + unshift @$exp, '\begin{tikzpicture}'; + push @$exp, '\end{tikzpicture}'; + + is_deeply $body, $exp, $desc; +} + +my $translate = eval { + Tikz->functor( + 'LaTeX::TikZ::Set::Point' => sub { + my ($functor, $set, $v) = @_; + + $set->new( + point => [ + $set->x + $v->x, + $set->y + $v->y, + ], + ); + }, + ); +}; +is $@, '', 'creating a translator doesn\'t croak'; + +my $seq = Tikz->seq( + Tikz->point, + Tikz->raw('foo'), + Tikz->point(2), + Tikz->line(-1 => 3) + ->clip(Tikz->circle(1, 1)) + ) + ->clip(Tikz->rectangle([0, -1] => [2, 3])); + +my $seq2 = eval { + $seq->$translate(Tikz->point(-1, 1)); +}; +is $@, '', 'translating a sequence doesn\'t croak'; + +check $seq, 'the original sequence', <<'RES'; +\begin{scope} +\clip (0cm,-1cm) rectangle (2cm,3cm) ; +\draw (0cm,0cm) ; +\draw foo ; +\draw (2cm,0cm) ; +\begin{scope} +\clip (1cm,0cm) circle (1cm) ; +\draw (-1cm,0cm) -- (3cm,0cm) ; +\end{scope} +\end{scope} +RES + +check $seq2, 'the translated sequence', <<'RES'; +\begin{scope} +\clip (-1cm,0cm) rectangle (1cm,4cm) ; +\draw (-1cm,1cm) ; +\draw foo ; +\draw (1cm,1cm) ; +\begin{scope} +\clip (0cm,1cm) circle (1cm) ; +\draw (-2cm,1cm) -- (2cm,1cm) ; +\end{scope} +\end{scope} +RES + +my $strip = eval { + Tikz->functor( + 'LaTeX::TikZ::Mod' => sub { return }, + ); +}; +is $@, '', 'creating a stripper doesn\'t croak'; + +$_->mod(Tikz->color('red')) for $seq2->kids; + +my $seq3 = eval { + $seq2->$strip; +}; +is $@, '', 'stripping a sequence doesn\'t croak'; + +check $seq2, 'the original sequence', <<'RES'; +\begin{scope} [color=red] +\clip (-1cm,0cm) rectangle (1cm,4cm) ; +\draw (-1cm,1cm) ; +\draw foo ; +\draw (1cm,1cm) ; +\begin{scope} +\clip (0cm,1cm) circle (1cm) ; +\draw (-2cm,1cm) -- (2cm,1cm) ; +\end{scope} +\end{scope} +RES + +check $seq3, 'the stripped sequence', <<'RES'; +\draw (-1cm,1cm) ; +\draw foo ; +\draw (1cm,1cm) ; +\draw (-2cm,1cm) -- (2cm,1cm) ; +RES