From: Vincent Pit <vince@profvince.com>
Date: Sat, 16 May 2009 20:44:48 +0000 (+0200)
Subject: Introduce vrot()
X-Git-Tag: v0.06~10
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=856caa5792565f48b11a5dc86856519b649eaffb;p=perl%2Fmodules%2FScalar-Vec-Util.git

Introduce vrot()
---

diff --git a/MANIFEST b/MANIFEST
index 790017d..853545d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -21,6 +21,7 @@ t/31-vcopy-copy.t
 t/32-vcopy-move.t
 t/33-vcopy-long.t
 t/40-vshift.t
+t/50-vrot.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t
diff --git a/lib/Scalar/Vec/Util.pm b/lib/Scalar/Vec/Util.pm
index b5a8080..dd8b1cb 100644
--- a/lib/Scalar/Vec/Util.pm
+++ b/lib/Scalar/Vec/Util.pm
@@ -146,6 +146,37 @@ sub vshift {
  }
 }
 
+=head2 C<< vrot $v, $start, $length, $bits >>
+
+In the area starting at C<$start> and of length C<$length> in C<$v>, rotates bits C<abs $bits> positions left if C<< $bits > 0 >> and right otherwise.
+Bits outside of the specified area are left untouched.
+Currently allocates an extra buffer of size C<O($bits)>.
+
+=cut
+
+sub vrot {
+ my ($start, $length, $bits) = @_[1 .. 3];
+ return unless $length and $bits;
+ my $left = 1;
+ if ($bits < 0) {
+  $left = 0;
+  $bits = -$bits;
+ }
+ $bits %= $length;
+ return unless $bits;
+ $length -= $bits;
+ my $buf = '';
+ if ($left) {
+  vcopy($_[0], $start + $length, $buf,  0,              $bits);
+  vcopy($_[0], $start,           $_[0], $start + $bits, $length);
+  vcopy($buf,  0,                $_[0], $start,         $bits);
+ } else {
+  vcopy($_[0], $start,           $buf,  0,                $bits);
+  vcopy($_[0], $start + $bits,   $_[0], $start,           $length);
+  vcopy($buf,  0,                $_[0], $start + $length, $bits);
+ }
+}
+
 =head2 C<< veq $v1 => $v1_start, $v2 => $v2_start, $length >>
 
 Returns true if the C<$length> bits starting at C<$v1_start> in C<$v1> and C<$v2_start> in C<$v2> are equal, and false otherwise.
@@ -166,7 +197,7 @@ sub veq_pp {
 
 =head1 EXPORT
 
-The functions L</vfill>, L</vcopy>, L</vshift> and L</veq> are only exported on request.
+The functions L</vfill>, L</vcopy>, L</vshift>, L</vrot> and L</veq> are only exported on request.
 All of them are exported by the tags C<':funcs'> and C<':all'>.
 
 The constants L</SVU_PP> and L</SVU_SIZE> are also only exported on request.
@@ -178,7 +209,7 @@ use base qw/Exporter/;
 
 our @EXPORT         = ();
 our %EXPORT_TAGS    = (
- 'funcs'  => [ qw/vfill vcopy vshift veq/ ],
+ 'funcs'  => [ qw/vfill vcopy vshift vrot veq/ ],
  'consts' => [ qw/SVU_PP SVU_SIZE/ ]
 );
 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
diff --git a/t/50-vrot.t b/t/50-vrot.t
new file mode 100644
index 0000000..9222ae3
--- /dev/null
+++ b/t/50-vrot.t
@@ -0,0 +1,99 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scalar::Vec::Util qw/vrot vcopy SVU_SIZE/;
+
+my $p = SVU_SIZE;
+$p = 8 if $p < 8;
+my $n = 3 * $p;
+my $q = 2;
+
+*myfill = *Scalar::Vec::Util::vfill_pp;
+*myeq   = *Scalar::Vec::Util::veq_pp;
+
+sub rst { myfill($_[0], 0, $n, 0); $_[0] = '' }
+
+sub pat {
+ (undef, my $a, my $b, my $c, my $x) = @_;
+ $_[0] = '';
+ myfill($_[0], 0,            $a,                  $x);
+ myfill($_[0], $a,           $b,                  1 - $x);
+ myfill($_[0], $a + $b,      $c,                  $x);
+ myfill($_[0], $a + $b + $c, $n - ($a + $b + $c), 1 - $x);
+}
+
+sub expected {
+ (undef, my $s, my $l, my $b, my $left) = @_;
+ my $lx = int($l / 2);
+ my $ly = $l - $lx;
+ $b %= $l;
+ $_[0] = '';
+ myfill($_[0], 0, $s, 0);
+ if ($left) {
+  if ($b <= $ly) {
+   myfill($_[0], $s,            $b,            0);
+   myfill($_[0], $s + $b,       $lx,           1);
+   myfill($_[0], $s + $b + $lx, $l - $lx - $b, 0);
+  } else {
+   myfill($_[0], $s,            $b - $ly, 1);
+   myfill($_[0], $s + $b - $ly, $ly,      0);
+   myfill($_[0], $s + $b,       $l - $b,  1);
+  }
+ } else {
+  if ($b <= $lx) {
+   myfill($_[0], $s,            $lx - $b, 1);
+   myfill($_[0], $s + $lx - $b, $l - $lx, 0);
+   myfill($_[0], $s + $l  - $b, $b,       1);
+  } else {
+   myfill($_[0], $s,                 $ly - ($b - $lx), 0);
+   myfill($_[0], $s + $l - $b,       $lx,              1);
+   myfill($_[0], $s + $l + $lx - $b, $b - $lx,         0);
+  }
+ }
+ myfill($_[0], $s + $l, $n - $s - $l, 1);
+}
+
+sub prnt {
+ (undef, my $n, my $desc) = @_;
+ my $i = 0;
+ my $s;
+ $s .= vec($_[0], $i++, 1) while $i < $n;
+ diag "$desc: $s";
+}
+
+my ($v, $v0, $c) = ('', '') x 2;
+
+sub try {
+ my ($left) = @_;
+ my @s = ($p - $q) .. ($p + $q);
+ for my $s (@s) {
+  for my $l (1 .. $n - 1) {
+   last if $s + $l > $n;
+   my $l2 = int($l/2);
+   rst $v0;
+   pat $v0, $s, $l2, $l - $l2, 0;
+   my @b = (0, 3, 5, 7, 11, 13, 17, $l2, $l2 + 1, $l + 1);
+   @b = do { my %seen; ++$seen{$_} for @b; sort keys %seen };
+   for my $b (@b) {
+    $v = $v0;
+    expected $c, $s, $l, $b, $left;
+    $b = -$b unless $left;
+    vrot $v, $s, $l, $b;
+    ok(myeq($v, 0, $c, 0, $n), "vrot $s, $l, $b") or do {
+     diag "n = $n, s = $s, l = $l, l2 = $l2";
+     prnt $v0, $n, 'original';
+     prnt $v, $n,  'got     ';
+     prnt $c, $n,  'expected';
+    };
+    is(length $v, length $c, "vrot $s, $l, $b length");
+   }
+  }
+ }
+}
+
+try 1;
+try 0;