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