XS.xs

   1 /*
   2 #
   3 # This file is part of Language::Befunge::Vector::XS.
   4 # Copyright (c) 2008 Jerome Quelin, all rights reserved.
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the same terms as Perl itself.
   8 #
   9 #
  10 */
  11
  12
  13 #include "EXTERN.h"
  14 #include "perl.h"
  15 #include "XSUB.h"
  16
  17 #define NEED_newRV_noinc
  18 #include "ppport.h"
  19
  20
  21 /* used for constructor new() */
  22 typedef int intArray;
  23 void* intArrayPtr(int num) {
  24     SV* mortal;
  25     mortal = sv_2mortal( NEWSV(0, num * sizeof(intArray)) );
  26     return SvPVX(mortal);
  27 }
  28
  29 AV *_rasterize(AV *vec_array, AV *min_array, AV *max_array) {
  30     IV i, inc = 1, nd = av_len(vec_array);
  31     AV *rv = newAV();
  32     for (i = 0; i <= av_len(vec_array); i++) {
  33         IV thisval, minval, maxval;
  34         thisval = SvIV(*av_fetch(vec_array, i, 0));
  35         minval  = SvIV(*av_fetch(min_array, i, 0));
  36         maxval  = SvIV(*av_fetch(max_array, i, 0));
  37         if(inc) {
  38             if(thisval < maxval) {
  39                 inc = 0;
  40                 thisval++;
  41             } else {
  42                 if(i == nd) {
  43                     SvREFCNT_dec(rv);
  44                     return NULL;
  45                 }
  46                 thisval = minval;
  47             }
  48         }
  49         av_push(rv, newSViv(thisval));
  50     }
  51     return rv;
  52 }
  53
  54
  55 MODULE = Language::Befunge::Vector::XS          PACKAGE = Language::Befunge::Vector::XS
  56
  57
  58 #-- CONSTRUCTORS
  59
  60 #
  61 # my $vec = LB::Vector->new( $x [, $y, ...] );
  62 #
  63 # Create a new vector. The arguments are the actual vector data; one
  64 # integer per dimension.
  65 #
  66 SV *
  67 new( class, array, ... )
  68         char*      class;
  69         intArray*  array
  70     INIT:
  71             IV     i;
  72             SV*    self;
  73             SV*    val;
  74             AV*    my_array;
  75             HV*    stash;
  76     CODE:
  77         /* sanity checks */
  78         if ( ix_array < 0 )
  79                 croak("Usage: %s->new($x,...)", class);
  80
  81         /* create the object and populate it */
  82         my_array = newAV();
  83         for ( i=0; i<ix_array; i++ ) {
  84             val = newSViv( array[i] );
  85             av_push(my_array, val);
  86         }
  87
  88         /* Return a blessed reference to the AV */
  89         self  = newRV_noinc( (SV*)my_array );
  90         stash = gv_stashpv( class, TRUE );
  91         sv_bless( (SV*)self, stash );
  92         RETVAL = self;
  93     OUTPUT:
  94         RETVAL
  95
  96
  97 #
  98 # my $vec = Language::Befunge::Vector::XS->new_zeroes( $dims );
  99 #
 100 # Create a new vector of dimension $dims, set to the origin (all
 101 # zeroes). LBVXS->new_zeroes(2) is exactly equivalent to LBVXS->new(0, 0).
 102 #
 103 SV *
 104 new_zeroes( class, dim )
 105         char*  class;
 106         IV     dim;
 107     INIT:
 108         IV     i;
 109         SV*    self;
 110         SV*    zero;
 111         AV*    my_array;
 112         HV*    stash;
 113     CODE:
 114         /* sanity checks */
 115         if ( dim < 1 )
 116                 croak("Usage: %s->new_zeroes($dims)", class);
 117
 118         /* create the object and populate it */
 119         my_array = newAV();
 120         for ( i=0; i<dim; i++ ) {
 121             zero = newSViv(0);
 122             av_push(my_array, zero);
 123         }
 124
 125         /* return a blessed reference to the AV */
 126         self  = newRV_noinc( (SV*)my_array );
 127         stash = gv_stashpv( class, TRUE );
 128         sv_bless( (SV*)self, stash );
 129         RETVAL = self;
 130     OUTPUT:
 131         RETVAL
 132
 133
 134 #
 135 # my $vec = $v->copy;
 136 #
 137 # Return a new LBVXS object, which has the same dimensions and
 138 # coordinates as $v.
 139 #
 140 SV*
 141 copy( vec, ... )
 142         SV*  vec;
 143     INIT:
 144         IV   i;
 145         SV*  val;
 146         SV*  self;
 147         AV*  my_array;
 148         AV*  vec_array;
 149         HV*  stash;
 150     CODE:
 151         /* fetch the underlying array of the object */
 152         vec_array = (AV*)SvRV(vec);
 153
 154         /* create the object and populate it */
 155         my_array = newAV();
 156         for ( i=0; i<=av_len(vec_array); i++ ) {
 157             val = newSViv( SvIV(*av_fetch(vec_array, i, 0)) );
 158             av_push(my_array, val);
 159         }
 160
 161         /* return a blessed reference to the AV */
 162         self  = newRV_noinc( (SV*)my_array );
 163         stash = SvSTASH( (SV*)vec_array );
 164         sv_bless( (SV*)self, stash );
 165         RETVAL = self;
 166     OUTPUT:
 167         RETVAL
 168
 169
 170 #-- PUBLIC METHODS
 171
 172 #- accessors
 173
 174 #
 175 # my $dims = $vec->get_dims;
 176 #
 177 # Return the number of dimensions, an integer.
 178 #
 179 IV
 180 get_dims( self )
 181         SV*  self;
 182     PREINIT:
 183         AV*  my_array;
 184     CODE:
 185         /* fetch the underlying array of the object */
 186         my_array = (AV*)SvRV(self);
 187
 188         RETVAL = av_len(my_array) + 1;
 189     OUTPUT:
 190         RETVAL
 191
 192
 193 #
 194 # my $val = $vec->get_component($dim);
 195 #
 196 # Return the value for dimension $dim.
 197 #
 198 IV
 199 get_component( self, dim )
 200         SV*  self;
 201         IV   dim;
 202     PREINIT:
 203         AV*  my_array;
 204     CODE:
 205         /* fetch the underlying array of the object */
 206         my_array = (AV*)SvRV(self);
 207
 208         /* sanity checks */
 209         if ( dim < 0 || dim > av_len(my_array) )
 210             croak( "No such dimension!" );
 211
 212         RETVAL = SvIV( *av_fetch(my_array, dim, 0) );
 213     OUTPUT:
 214         RETVAL
 215
 216
 217 #
 218 # my @vals = $vec->get_all_components;
 219 #
 220 # Get the values for all dimensions, in order from 0..N.
 221 #
 222 void
 223 get_all_components( self )
 224         SV*  self;
 225     PREINIT:
 226         IV   dim, i, val;
 227         AV*  my_array;
 228     PPCODE:
 229         /* fetch the underlying array of the object */
 230         my_array = (AV*)SvRV(self);
 231         dim = av_len(my_array);
 232
 233         /* extend the return stack and populate it */
 234         EXTEND(SP,dim+1);
 235         for ( i=0; i<=dim; i++ ) {
 236             val = SvIV( *av_fetch(my_array, i, 0) );
 237             PUSHs( sv_2mortal( newSViv(val) ) );
 238         }
 239
 240
 241 #- mutators
 242
 243 #
 244 # $vec->clear;
 245 #
 246 # Set the vector back to the origin, all 0's.
 247 #
 248 void
 249 clear( self )
 250         SV*  self;
 251     INIT:
 252         IV   dim, i;
 253         SV*  zero;
 254         AV*  my_array;
 255     PPCODE:
 256         /* fetch the underlying array of the object */
 257         my_array = (AV*)SvRV(self);
 258         dim = av_len(my_array);
 259
 260         /* clear each slot */
 261         for ( i=0; i<=dim; i++ ) {
 262             zero = newSViv(0);
 263             av_store(my_array, i, zero);
 264         }
 265
 266
 267 #
 268 # my $val = $vec->set_component( $dim, $value );
 269 #
 270 # Set the value for dimension $dim to $value.
 271 #
 272 void
 273 set_component( self, dim, value )
 274         SV*  self;
 275         IV   dim;
 276         IV   value;
 277     INIT:
 278         AV*  my_array;
 279     CODE:
 280         /* fetch the underlying array of the object */
 281         my_array = (AV*)SvRV(self);
 282
 283         /* sanity checks */
 284         if ( dim < 0 || dim > av_len(my_array) )
 285             croak( "No such dimension!" );
 286
 287         /* storing new value */
 288         av_store(my_array, dim, newSViv(value));
 289
 290
 291 #- other methods
 292
 293 #
 294 # my $is_within = $vec->bounds_check($begin, $end);
 295 #
 296 # Check whether $vec is within the box defined by $begin and $end.
 297 # Return 1 if vector is contained within the box, and 0 otherwise.
 298 #
 299 IV
 300 bounds_check( self, v1, v2 )
 301         SV*  self;
 302         SV*  v1;
 303         SV*  v2;
 304     INIT:
 305         IV   i, mydim, dimv1, dimv2, myval, val1, val2;
 306         AV*  my_array;
 307         AV*  v1_array;
 308         AV*  v2_array;
 309     CODE:
 310         /* fetch the underlying array of the object */
 311         my_array = (AV*)SvRV(self);
 312         v1_array = (AV*)SvRV(v1);
 313         v2_array = (AV*)SvRV(v2);
 314         mydim = av_len(my_array);
 315         dimv1 = av_len(v1_array);
 316         dimv2 = av_len(v2_array);
 317
 318         /* sanity checks */
 319         if ( mydim != dimv1 || mydim != dimv2 )
 320             croak("uneven dimensions in bounds check!");
 321
 322         /* compare the arrays */
 323         RETVAL = 1;
 324         for ( i=0 ; i<=dimv1; i++ ) {
 325             myval = SvIV( *av_fetch(my_array, i, 0) );
 326             val1  = SvIV( *av_fetch(v1_array, i, 0) );
 327             val2  = SvIV( *av_fetch(v2_array, i, 0) );
 328             if ( myval < val1 || myval > val2 ) {
 329                 RETVAL = 0;
 330                 break;
 331             }
 332         }
 333     OUTPUT:
 334         RETVAL
 335
 336
 337 #
 338 # for(my $v = $min->copy; defined $v; $v = $v->rasterize($min, $max))
 339 #
 340 # Return the next vector in raster order, or undef if the hypercube space
 341 # has been fully covered.  To enumerate the entire storage area, the caller
 342 # should call rasterize on the storage area's "min" value the first time,
 343 # and keep looping while the return value is defined.  To enumerate a
 344 # smaller rectangle, the caller should pass in the min and max vectors
 345 # describing the rectangle, and keep looping while the return value is
 346 # defined.
 347 #
 348 SV*
 349 rasterize( self, minv, maxv )
 350         SV* self;
 351         SV* minv;
 352         SV* maxv;
 353     INIT:
 354         SV*  new;
 355         AV*  my_array;
 356         AV*  vec_array, *min_array, *max_array;
 357         HV*  stash;
 358     CODE:
 359         /* fetch the underlying array of the object */
 360         vec_array = (AV*)SvRV(self);
 361         min_array = (AV*)SvRV(minv);
 362         max_array = (AV*)SvRV(maxv);
 363
 364         /* create the object and populate it */
 365         my_array = _rasterize(vec_array, min_array, max_array);
 366         if(!my_array) {
 367             XSRETURN_UNDEF;
 368         }
 369
 370         /* return a blessed reference to the AV */
 371         RETVAL = newRV_noinc( (SV*)my_array );
 372         stash  = SvSTASH( (SV*)vec_array );
 373         sv_bless( (SV*)RETVAL, stash );
 374     OUTPUT:
 375         RETVAL
 376
 377
 378
 379 # -- PRIVATE METHODS
 380
 381 #- math ops
 382
 383 #
 384 # my $vec = $v1->_add($v2);
 385 # my $vec = $v1 + $v2;
 386 #
 387 # Return a new LBVXS object, which is the result of $v1 plus $v2.
 388 #
 389 SV*
 390 _add( v1, v2, variant )
 391         SV*  v1;
 392         SV*  v2;
 393         SV*  variant;
 394     INIT:
 395         IV   dimv1, dimv2, i, val1, val2;
 396         SV*  self;
 397         AV*  my_array;
 398         AV*  v1_array;
 399         AV*  v2_array;
 400         HV*  stash;
 401     CODE:
 402         /* fetch the underlying array of the object */
 403         v1_array = (AV*)SvRV(v1);
 404         v2_array = (AV*)SvRV(v2);
 405         dimv1 = av_len(v1_array);
 406         dimv2 = av_len(v2_array);
 407
 408         /* sanity checks */
 409         if ( dimv1 != dimv2 )
 410             croak("uneven dimensions in vector addition!");
 411
 412         /* create the new array and populate it */
 413         my_array = newAV();
 414         for ( i=0 ; i<=dimv1; i++ ) {
 415             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 416             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 417             av_push( my_array, newSViv(val1+val2) );
 418             }
 419
 420         /* return a blessed reference to the AV */
 421         self  = newRV_noinc( (SV*)my_array );
 422         stash = SvSTASH( (SV*)v1_array );
 423         sv_bless( (SV*)self, stash );
 424         RETVAL = self;
 425     OUTPUT:
 426         RETVAL
 427
 428
 429 #
 430 # my $vec = $v1->_substract($v2);
 431 # my $vec = $v1 - $v2;
 432 #
 433 # Return a new LBVXS object, which is the result of $v1 minus $v2.
 434 #
 435 SV*
 436 _substract( v1, v2, variant )
 437         SV*  v1;
 438         SV*  v2;
 439         SV*  variant;
 440     INIT:
 441         IV   dimv1, dimv2, i, val1, val2;
 442         SV*  self;
 443         AV*  my_array;
 444         AV*  v1_array;
 445         AV*  v2_array;
 446         HV*  stash;
 447     CODE:
 448         /* fetch the underlying array of the object */
 449         v1_array = (AV*)SvRV(v1);
 450         v2_array = (AV*)SvRV(v2);
 451         dimv1 = av_len(v1_array);
 452         dimv2 = av_len(v2_array);
 453
 454         /* sanity checks */
 455         if ( dimv1 != dimv2 )
 456             croak("uneven dimensions in vector addition!");
 457
 458         /* create the new array and populate it */
 459         my_array = newAV();
 460         for ( i=0 ; i<=dimv1; i++ ) {
 461             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 462             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 463             av_push( my_array, newSViv(val1-val2) );
 464             }
 465
 466         /* return a blessed reference to the AV */
 467         self  = newRV_noinc( (SV*)my_array );
 468         stash = SvSTASH( (SV*)v1_array );
 469         sv_bless( (SV*)self, stash );
 470         RETVAL = self;
 471     OUTPUT:
 472         RETVAL
 473
 474
 475 #
 476 # my $vec = $v1->_invert;
 477 # my $vec = -$v1;
 478 #
 479 # Subtract $v1 from the origin. Effectively, gives the inverse of the
 480 # original vector. The new vector is the same distance from the origin,
 481 # in the opposite direction.
 482 #
 483 SV*
 484 _invert( v1, v2, variant )
 485         SV*  v1;
 486         SV*  v2;
 487         SV*  variant;
 488     INIT:
 489         IV   dim, i, val;
 490         SV*  self;
 491         AV*  my_array;
 492         AV*  v1_array;
 493         HV*  stash;
 494     CODE:
 495         /* fetch the underlying array of the object */
 496         v1_array = (AV*)SvRV(v1);
 497         dim = av_len(v1_array);
 498
 499         /* create the new array and populate it */
 500         my_array = newAV();
 501         for ( i=0 ; i<=dim; i++ ) {
 502             val = SvIV( *av_fetch(v1_array, i, 0) );
 503             av_push( my_array, newSViv(-val) );
 504             }
 505
 506         /* return a blessed reference to the AV */
 507         self  = newRV_noinc( (SV*)my_array );
 508         stash = SvSTASH( (SV*)v1_array );
 509         sv_bless( (SV*)self, stash );
 510         RETVAL = self;
 511     OUTPUT:
 512         RETVAL
 513
 514
 515
 516 #- inplace math ops
 517
 518 #
 519 # $v1->_add_inplace($v2);
 520 # $v1 += $v2;
 521 #
 522 # Adds $v2 to $v1, and stores the result back into $v1.
 523 #
 524 SV*
 525 _add_inplace( v1, v2, variant )
 526         SV*  v1;
 527         SV*  v2;
 528         SV*  variant;
 529     INIT:
 530         IV   dimv1, dimv2, i, val1, val2;
 531         AV*  v1_array;
 532         AV*  v2_array;
 533     CODE:
 534         /* fetch the underlying array of the object */
 535         v1_array = (AV*)SvRV(v1);
 536         v2_array = (AV*)SvRV(v2);
 537         dimv1 = av_len(v1_array);
 538         dimv2 = av_len(v2_array);
 539
 540         /* sanity checks */
 541         if ( dimv1 != dimv2 )
 542             croak("uneven dimensions in vector addition!");
 543
 544         /* update the array slots */
 545         for ( i=0 ; i<=dimv1; i++ ) {
 546             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 547             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 548             av_store( v1_array, i, newSViv(val1+val2) );
 549             }
 550     OUTPUT:
 551         v1
 552
 553
 554 #
 555 # $v1->_substract_inplace($v2);
 556 # $v1 -= $v2;
 557 #
 558 # Substract $v2 to $v1, and stores the result back into $v1.
 559 #
 560 SV*
 561 _substract_inplace( v1, v2, variant )
 562         SV*  v1;
 563         SV*  v2;
 564         SV*  variant;
 565     INIT:
 566         IV   dimv1, dimv2, i, val1, val2;
 567         AV*  v1_array;
 568         AV*  v2_array;
 569     CODE:
 570         /* fetch the underlying array of the object */
 571         v1_array = (AV*)SvRV(v1);
 572         v2_array = (AV*)SvRV(v2);
 573         dimv1 = av_len(v1_array);
 574         dimv2 = av_len(v2_array);
 575
 576         /* sanity checks */
 577         if ( dimv1 != dimv2 )
 578             croak("uneven dimensions in vector addition!");
 579
 580         /* update the array slots */
 581         for ( i=0 ; i<=dimv1; i++ ) {
 582             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 583             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 584             av_store( v1_array, i, newSViv(val1-val2) );
 585             }
 586     OUTPUT:
 587         v1
 588
 589
 590 #- comparison
 591
 592 #
 593 # my $bool = $v1->_compare($v2);
 594 # my $bool = $v1 <=> $v2;
 595 #
 596 # Check whether the vectors both point at the same spot. Return 0 if they
 597 # do, 1 if they don't.
 598 #
 599 IV
 600 _compare( v1, v2, variant )
 601         SV*  v1;
 602         SV*  v2;
 603         SV*  variant;
 604
 605     INIT:
 606         IV   dimv1, dimv2, i, val1, val2;
 607         AV*  v1_array;
 608         AV*  v2_array;
 609     CODE:
 610         /* fetch the underlying array of the object */
 611         v1_array = (AV*)SvRV(v1);
 612         v2_array = (AV*)SvRV(v2);
 613         dimv1 = av_len(v1_array);
 614         dimv2 = av_len(v2_array);
 615
 616         /* sanity checks */
 617         if ( dimv1 != dimv2 )
 618             croak("uneven dimensions in bounds check!");
 619
 620         /* compare the arrays */
 621         RETVAL = 0;
 622         for ( i=0 ; i<=dimv1; i++ ) {
 623             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 624             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 625             if ( val1 != val2 ) {
 626                 RETVAL = 1;
 627                 break;
 628             }
 629         }
 630     OUTPUT:
 631         RETVAL
 632
 633
 634 # private
 635
 636 # my $ptr = $LBV->_xs_rasterize_ptr();
 637 #
 638 # Get a pointer to the C "rasterize" function, so that other XS modules can
 639 # call it directly for speed.
 640
 641 SV*
 642 _xs_rasterize_ptr()
 643     INIT:
 644         void *ptr = _rasterize;
 645         SV *rv;
 646     CODE:
 647         rv = newSVpvn((const char *)(&ptr), sizeof(ptr));
 648         RETVAL = rv;
 649     OUTPUT:
 650         RETVAL