lib/Language/Befunge/Vector.pm

   1 #
   2 # This file is part of Language::Befunge.
   3 # Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8 #
   9
  10 package Language::Befunge::Vector;
  11
  12 use strict;
  13 use warnings;
  14 use integer;
  15 use Carp;
  16
  17 use overload
  18     '='   => \&copy,
  19     '+'   => \&_add,
  20     '-'   => \&_substract,
  21     'neg' => \&_invert,
  22     '+='  => \&_add_inplace,
  23     '-='  => \&_substract_inplace,
  24     '<=>' => \&_compare,
  25     'eq'  => \&_compare_string,
  26     '""'  => \&as_string;
  27
  28 # try to load speed-up LBV
  29 eval 'use Language::Befunge::Vector::XS';
  30 if ( defined $Language::Befunge::Vector::XS::VERSION ) {
  31     my $xsversion = $Language::Befunge::Vector::XS::VERSION;
  32     my @subs = qw[
  33         new new_zeroes copy
  34         as_string get_dims get_component get_all_components
  35         clear set_component
  36         bounds_check
  37         _add _substract _invert
  38         _add_inplace _substract_inplace
  39         _compare
  40     ];
  41     foreach my $sub ( @subs ) {
  42         no strict 'refs';
  43         no warnings 'redefine';
  44         my $lbvxs_sub = "Language::Befunge::Vector::XS::$sub";
  45         *$sub = \&$lbvxs_sub;
  46     }
  47     # LBV::XS 1.1.0 adds rasterize()
  48     @subs = qw[ rasterize _xs_rasterize_ptr ];
  49     if($xsversion gt "1.0.0") {
  50         # import the XS functions from LBVXS
  51         no strict 'refs';
  52         no warnings 'redefine';
  53         foreach my $sub (@subs) {
  54             my $lbvxs_sub = "Language::Befunge::Vector::XS::$sub";
  55             *$sub = \&$lbvxs_sub;
  56         }
  57     } else {
  58         # export the pure-perl functions to LBVXS
  59         no strict 'refs';
  60         no warnings 'redefine';
  61         foreach my $sub (@subs) {
  62             my $lbvxs_sub = "Language::Befunge::Vector::XS::$sub";
  63             *$lbvxs_sub = \&$sub;
  64         }
  65     }
  66 }
  67
  68
  69 # -- CONSTRUCTORS
  70
  71 #
  72 # my $vec = LB::Vector->new( $x [, $y, ...] );
  73 #
  74 # Create a new vector. The arguments are the actual vector data; one
  75 # integer per dimension.
  76 #
  77 sub new {
  78     my $pkg = shift;
  79
  80     # sanity checks
  81     my $usage = "Usage: $pkg->new(\$x, ...)";
  82     croak $usage unless scalar(@_) > 0;
  83
  84     # regular LBV object
  85     my $self = [@_];
  86     bless $self, $pkg;
  87     return $self;
  88 }
  89
  90
  91 #
  92 # my $vec = LB::Vector->new_zeroes($dims);
  93 #
  94 # Create a new vector of dimension $dims, set to the origin (all
  95 # zeroes). LBV->new_zeroes(2) is exactly equivalent to LBV->new(0, 0).
  96 #
  97 sub new_zeroes {
  98     my ($pkg, $dims) = @_;
  99
 100     # sanity checks
 101     my $usage = "Usage: $pkg->new_zeroes(\$dimensions)";
 102     croak $usage unless defined $dims;
 103     croak $usage unless $dims > 0;
 104
 105     # regular LBV object
 106     my $self = [ (0) x $dims ];
 107     bless $self, $pkg;
 108     return $self;
 109 }
 110
 111
 112 #
 113 # my $vec = $v->copy;
 114 #
 115 # Return a new LBV object, which has the same dimensions and coordinates
 116 # as $v.
 117 #
 118 sub copy {
 119     my $vec = shift;
 120     return bless [@$vec], ref $vec;
 121 }
 122
 123
 124 # -- PUBLIC METHODS
 125
 126 #- accessors
 127
 128
 129 #
 130 # my $str = $vec->as_string;
 131 # my $str = "$vec";
 132 #
 133 # Return the stringified form of $vec. For instance, a Befunge vector
 134 # might look like "(1,2)".
 135 #
 136 sub as_string {
 137     my $self = shift;
 138     return "(" . join(",",@$self) . ")";
 139 }
 140
 141
 142 #
 143 # my $dims = $vec->get_dims;
 144 #
 145 # Return the number of dimensions, an integer.
 146 #
 147 sub get_dims {
 148     my $self = shift;
 149     return scalar(@$self);
 150 }
 151
 152
 153 #
 154 # my $val = $vec->get_component($dim);
 155 #
 156 # Get the value for dimension $dim.
 157 #
 158 sub get_component {
 159     my ($self, $dim) = @_;
 160     croak "No such dimension $dim!" unless $dim >= 0 && $self->get_dims > $dim;
 161     return $self->[$dim];
 162 }
 163
 164
 165 #
 166 # my @vals = $vec->get_all_components;
 167 #
 168 # Get the values for all dimensions, in order from 0..N.
 169 #
 170 sub get_all_components {
 171     my ($self) = @_;
 172     return @$self;
 173 }
 174
 175
 176 # - mutators
 177
 178 #
 179 # $vec->clear;
 180 #
 181 # Set the vector back to the origin, all 0's.
 182 #
 183 sub clear {
 184     my ($self) = @_;
 185     @$self = (0) x $self->get_dims;
 186 }
 187
 188
 189 #
 190 # $vec->set_component($dim, $value);
 191 #
 192 # Set the value for dimension $dim to $value.
 193 #
 194 sub set_component {
 195     my ($self, $dim, $val) = @_;
 196     croak "No such dimension $dim!" unless $dim >= 0 && $self->get_dims > $dim;
 197     $self->[$dim] = $val;
 198 }
 199
 200
 201 #- other methods
 202
 203 #
 204 # my $is_within = $vec->bounds_check($begin, $end);
 205 #
 206 # Check whether $vec is within the box defined by $begin and $end.
 207 # Return 1 if vector is contained within the box, and 0 otherwise.
 208 #
 209 sub bounds_check {
 210     my ($vchk, $begin, $end) = @_;
 211     croak "uneven dimensions in bounds check!" unless $vchk->get_dims == $begin->get_dims;
 212     croak "uneven dimensions in bounds check!" unless $vchk->get_dims == $end->get_dims;
 213     for (my $d = 0; $d < $vchk->get_dims; $d++) {
 214         return 0 if $vchk->get_component($d) < $begin->get_component($d);
 215         return 0 if $vchk->get_component($d) >   $end->get_component($d);
 216     }
 217     return 1;
 218 }
 219
 220
 221 #
 222 # $vec = $vec->rasterize($min, $max);
 223 #
 224 # Return the next vector in raster order, or undef if the hypercube space
 225 # has been fully covered.  To enumerate the entire storage area, the caller
 226 # should call rasterize on the storage area's "min" value the first time,
 227 # and keep looping while the return value is defined.  To enumerate a
 228 # smaller rectangle, the caller should pass in the min and max vectors
 229 # describing the rectangle, and keep looping while the return value is
 230 # defined.
 231 #
 232
 233 sub rasterize {
 234     my ($v, $min, $max) = @_;
 235     return undef unless $v->bounds_check($min, $max);
 236     $v = $v->copy;
 237     my $nd = $v->get_dims();
 238     for my $d (0..$nd-1) {
 239         if($v->get_component($d) >= $max->get_component($d)) {
 240             # wrap to the next highest dimension, continue loop
 241             $v->set_component($d, $min->get_component($d));
 242         } else {
 243             # still have farther to go in this dimension.
 244             $v->set_component($d, $v->get_component($d) + 1);
 245             return $v;
 246         }
 247     }
 248     # ran out of dimensions!
 249     return undef;
 250 }
 251
 252
 253
 254 # -- PRIVATE METHODS
 255
 256 #- math ops
 257
 258 #
 259 # my $vec = $v1->_add($v2);
 260 # my $vec = $v1 + $v2;
 261 #
 262 # Return a new LBV object, which is the result of $v1 plus $v2.
 263 #
 264 sub _add {
 265     my ($v1, $v2) = @_;
 266     my $nd = scalar @$v1;
 267     croak "uneven dimensions in vector addition!" unless $nd == scalar @$v2;
 268     return ref($v1)->new(map { $$v1[$_] + $$v2[$_] } (0..$nd-1));
 269 }
 270
 271
 272 #
 273 # my $vec = $v1->_substract($v2);
 274 # my $vec = $v1 - $v2;
 275 #
 276 # Return a new LBV object, which is the result of $v1 minus $v2.
 277 #
 278 sub _substract {
 279     my ($v1, $v2) = @_;
 280     my $nd = scalar @$v1;
 281     croak "uneven dimensions in vector subtraction!" unless $nd == scalar @$v2;
 282     return ref($v1)->new(map { $$v1[$_] - $$v2[$_] } (0..$nd-1));
 283 }
 284
 285
 286 #
 287 # my $v2 = $v1->_invert;
 288 # my $v2 = -$v1;
 289 #
 290 # Subtract $v1 from the origin. Effectively, gives the inverse of the
 291 # original vector. The new vector is the same distance from the origin,
 292 # in the opposite direction.
 293 #
 294 sub _invert {
 295     my ($v1) = @_;
 296     my $nd = scalar @$v1;
 297     return ref($v1)->new(map { -$_ } (@$v1));
 298 }
 299
 300
 301 #- inplace math ops
 302
 303 #
 304 # $v1->_add_inplace($v2);
 305 # $v1 += $v2;
 306 #
 307 #
 308 sub _add_inplace {
 309     my ($v1, $v2) = @_;
 310     my $nd = scalar @$v1;
 311     croak "uneven dimensions in vector addition!" unless $nd == scalar @$v2;
 312     map { $$v1[$_] += $$v2[$_] } (0..$nd-1);
 313     return $v1;
 314 }
 315
 316
 317 #
 318 # $v1->_substract_inplace($v2);
 319 # $v1 -= $v2;
 320 #
 321 # Substract $v2 to $v1, and stores the result back into $v1.
 322 #
 323 sub _substract_inplace {
 324     my ($v1, $v2) = @_;
 325     my $nd = scalar @$v1;
 326     croak "uneven dimensions in vector substraction!" unless $nd == scalar @$v2;
 327     map { $$v1[$_] -= $$v2[$_] } (0..$nd-1);
 328     return $v1;
 329 }
 330
 331
 332 #- comparison
 333
 334 #
 335 # my $bool = $v1->_compare($v2);
 336 # my $bool = $v1 <=> $v2;
 337 #
 338 # Check whether the vectors both point at the same spot. Return 0 if they
 339 # do, 1 if they don't.
 340 #
 341 sub _compare {
 342     my ($v1, $v2) = @_;
 343     my $nd = scalar @$v1;
 344     croak "uneven dimensions in bounds check!" unless $nd == scalar @$v2;
 345     for (my $d = 0; $d < $nd; $d++) {
 346         return 1 if $$v1[$d] != $$v2[$d];
 347     }
 348     return 0;
 349 }
 350
 351
 352 #
 353 # my $bool = $v->_compare($string);
 354 # my $bool = $v eq $string;
 355 #
 356 # Check whether the vector stringifies to $string.
 357 #
 358 sub _compare_string {
 359     my ($self, $str) = @_;
 360     return $self->as_string eq $str;
 361 }
 362
 363
 364
 365 #- other private methods
 366
 367 #
 368 # my $ptr = $v1->_xs_rasterize_ptr();
 369 #
 370 # Get a pointer to the C "rasterize" function.  Returns undef if LBVXS is not
 371 # loaded.  This is useful for external XS modules, because calling the C
 372 # function directly is faster.
 373 #
 374 # The prototype of the C rasterize function is:
 375 #
 376 #     AV *rasterize(AV *vec_array, AV *min_array, AV *max_array);
 377 #
 378 # It operates just like the perl rasterize function, and returns NULL when the
 379 # end of the loop has been reached.
 380 #
 381 sub _xs_rasterize_ptr { return undef }
 382
 383
 384 1;
 385 __END__
 386
 387 =head1 NAME
 388
 389 Language::Befunge::Vector - an opaque, N-dimensional vector class.
 390
 391
 392
 393 =head1 SYNOPSIS
 394
 395     my $v1 = Language::Befunge::Vector->new($x, $y, ...);
 396     my $v2 = Language::Befunge::Vector->new_zeroes($dims);
 397
 398
 399
 400 =head1 DESCRIPTION
 401
 402 This class abstracts normal vector manipulation. It lets you pass
 403 around one argument to your functions, rather than N arguments, one
 404 per dimension.  This means much of your code doesn't have to care
 405 how many dimensions you're working with.
 406
 407 You can do vector arithmetic, test for equality, or even stringify
 408 the vector to a string like I<"(1,2,3)">.
 409
 410
 411
 412 =head1 CONSTRUCTORS
 413
 414 =head2 my $vec = LB::Vector->new( $x [, $y, ...] )
 415
 416 Create a new vector. The arguments are the actual vector data; one
 417 integer per dimension.
 418
 419
 420 =head2 my $vec = LB::Vector->new_zeroes($dims);
 421
 422 Create a new vector of dimension C<$dims>, set to the origin (all zeroes). C<<
 423 LBV->new_zeroes(2) >> is exactly equivalent to B<< LBV->new(0,0) >>.
 424
 425
 426 =head2 my $vec = $v->copy;
 427
 428 Return a new LBV object, which has the same dimensions and coordinates
 429 as $v.
 430
 431
 432
 433 =head1 PUBLIC METHODS
 434
 435 =head2 my $str = $vec->as_string;
 436
 437 Return the stringified form of C<$vec>. For instance, a Befunge vector
 438 might look like C<(1,2)>.
 439
 440 This method is also applied to stringification, ie when one forces
 441 string context (C<"$vec">).
 442
 443
 444 =head2 my $dims = $vec->get_dims;
 445
 446 Return the number of dimensions, an integer.
 447
 448
 449 =head2 my $val = $vec->get_component($dim);
 450
 451 Get the value for dimension C<$dim>.
 452
 453
 454 =head2 my @vals = $vec->get_all_components;
 455
 456 Get the values for all dimensions, in order from 0..N.
 457
 458
 459 =head2 $vec->clear;
 460
 461 Set the vector back to the origin, all 0's.
 462
 463
 464 =head2 $vec->set_component($dim, $value);
 465
 466 Set the value for dimension C<$dim> to C<$value>.
 467
 468
 469 =head2 my $is_within = $vec->bounds_check($begin, $end);
 470
 471 Check whether C<$vec> is within the box defined by C<$begin> and C<$end>.
 472 Return 1 if vector is contained within the box, and 0 otherwise.
 473
 474
 475 =head2 $vec->rasterize($min, $max);
 476
 477 Return the next vector in raster order, or undef if the hypercube space
 478 has been fully covered.
 479
 480 To enumerate the entire storage area, the caller should call rasterize
 481 on the storage area's "min" value the first time, and keep looping while
 482 the return value is defined.  To enumerate a smaller rectangle, the
 483 caller should pass in the min and max vectors describing the rectangle,
 484 and keep looping while the return value is defined.
 485
 486
 487
 488 =head1 MATHEMATICAL OPERATIONS
 489
 490 =head2 Standard operations
 491
 492 One can do some maths on the vectors. Addition and substraction work as
 493 expected:
 494
 495     my $v = $v1 + $v2;
 496     my $v = $v1 - $v2;
 497
 498 Either operation return a new LBV object, which is the result of C<$v1>
 499 plus / minus C<$v2>.
 500
 501 The inversion is also supported:
 502     my $v2 = -$v1;
 503
 504 will subtracts C<$v1> from the origin, and effectively, gives the
 505 inverse of the original vector. The new vector is the same distance from
 506 the origin, in the opposite direction.
 507
 508
 509 =head2 Inplace operations
 510
 511 LBV objects also supports inplace mathematical operations:
 512
 513     $v1 += $v2;
 514     $v1 -= $v2;
 515
 516 effectively adds / substracts C<$v2> to / from C<$v1>, and stores the
 517 result back into C<$v1>.
 518
 519
 520 =head2 Comparison
 521
 522 Finally, LBV objects can be tested for equality, ie whether two vectors
 523 both point at the same spot.
 524
 525     print "same"   if $v1 == $v2;
 526     print "differ" if $v1 != $v2;
 527
 528
 529 =head1 PRIVATE METHODS
 530
 531 =head2 _xs_rasterize_ptr
 532
 533     my $ptr = $v1->_xs_rasterize_ptr();
 534
 535 Get a pointer to the C "rasterize" function.  Returns undef if LBVXS is not
 536 loaded.  This is useful for external XS modules, to allow them to call the
 537 C function directly for additional speed.
 538
 539 The prototype of the C rasterize function is:
 540
 541     AV *rasterize(AV *vec_array, AV *min_array, AV *max_array);
 542
 543 It operates just like the perl rasterize function, and returns NULL when the
 544 end of the loop has been reached.
 545
 546
 547 =head1 SEE ALSO
 548
 549 L<Language::Befunge>
 550
 551
 552 =head1 AUTHOR
 553
 554 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 555
 556 Development is discussed on E<lt>language-befunge@mongueurs.netE<gt>
 557
 558
 559 =head1 COPYRIGHT & LICENSE
 560
 561 Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
 562
 563 This program is free software; you can redistribute it and/or modify
 564 it under the same terms as Perl itself.
 565
 566
 567 =cut
 568