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 #include "ppport.h"
  18
  19
  20 /* used for constructor new() */
  21 typedef int intArray;
  22 void* intArrayPtr(int num) {
  23     SV* mortal;
  24     mortal = sv_2mortal( NEWSV(0, num * sizeof(intArray)) );
  25     return SvPVX(mortal);
  26 }
  27
  28
  29
  30 MODULE = Language::Befunge::Vector::XS          PACKAGE = Language::Befunge::Vector::XS
  31
  32
  33 #-- CONSTRUCTORS
  34
  35 #
  36 # my $vec = LB::Vector->new( $x [, $y, ...] );
  37 #
  38 # Create a new vector. The arguments are the actual vector data; one
  39 # integer per dimension.
  40 #
  41 SV *
  42 new( class, array, ... )
  43         char*      class;
  44         intArray*  array
  45     INIT:
  46             IV     i;
  47             SV*    self;
  48             SV*    val;
  49             AV*    my_array;
  50             HV*    stash;
  51     CODE:
  52         /* create the object and populate it */
  53         my_array = newAV();
  54         for ( i=0; i<ix_array; i++ ) {
  55             val = newSViv( array[i] );
  56             av_push(my_array, val);
  57         }
  58
  59         /* Return a blessed reference to the AV */
  60         self  = newRV_noinc( (SV*)my_array );
  61         stash = gv_stashpv( class, TRUE );
  62         sv_bless( (SV*)self, stash );
  63         RETVAL = self;
  64     OUTPUT:
  65         RETVAL
  66
  67
  68 #
  69 # my $vec = Language::Befunge::Vector::XS->new_zeroes( $dims );
  70 #
  71 # Create a new vector of dimension $dims, set to the origin (all
  72 # zeroes). LBVXS->new_zeroes(2) is exactly equivalent to LBVXS->new(0, 0).
  73 #
  74 SV *
  75 new_zeroes( class, dim )
  76         char*  class;
  77         IV     dim;
  78     INIT:
  79         IV     i;
  80         SV*    self;
  81         SV*    zero;
  82         AV*    my_array;
  83         HV*    stash;
  84     CODE:
  85         /* create the object and populate it */
  86         my_array = newAV();
  87         for ( i=0; i<dim; i++ ) {
  88             zero = newSViv(0);
  89             av_push(my_array, zero);
  90         }
  91
  92         /* return a blessed reference to the AV */
  93         self  = newRV_noinc( (SV*)my_array );
  94         stash = gv_stashpv( class, TRUE );
  95         sv_bless( (SV*)self, stash );
  96         RETVAL = self;
  97     OUTPUT:
  98         RETVAL
  99
 100
 101 #
 102 # my $vec = $v->copy;
 103 #
 104 # Return a new LBVXS object, which has the same dimensions and
 105 # coordinates as $v.
 106 #
 107 SV*
 108 copy( vec, ... )
 109         SV*  vec;
 110     INIT:
 111         IV   val, i;
 112         SV*  self;
 113         AV*  my_array;
 114         AV*  vec_array;
 115         HV*  stash;
 116     CODE:
 117         /* fetch the underlying array of the object */
 118         vec_array = (AV*)SvRV(vec);
 119
 120         /* create the object and populate it */
 121         my_array = newAV();
 122         for ( i=0; i<=av_len(vec_array); i++ ) {
 123             val = newSViv( SvIV(*av_fetch(vec_array, i, 0)) );
 124             av_push(my_array, val);
 125         }
 126
 127         /* return a blessed reference to the AV */
 128         self  = newRV_noinc( (SV*)my_array );
 129         stash = SvSTASH( (SV*)vec_array );
 130         sv_bless( (SV*)self, stash );
 131         RETVAL = self;
 132     OUTPUT:
 133         RETVAL
 134
 135
 136 #-- PUBLIC METHODS
 137
 138 #- accessors
 139
 140 #
 141 # my $dims = $vec->get_dims;
 142 #
 143 # Return the number of dimensions, an integer.
 144 #
 145 IV
 146 get_dims( self )
 147         SV*  self;
 148     PREINIT:
 149         AV*  my_array;
 150     CODE:
 151         /* fetch the underlying array of the object */
 152         my_array = (AV*)SvRV(self);
 153
 154         RETVAL = av_len(my_array) + 1;
 155     OUTPUT:
 156         RETVAL
 157
 158
 159 #
 160 # my $val = $vec->get_component($dim);
 161 #
 162 # Return the value for dimension $dim.
 163 #
 164 IV
 165 get_component( self, dim )
 166         SV*  self;
 167         IV   dim;
 168     PREINIT:
 169         AV*  my_array;
 170     CODE:
 171         /* fetch the underlying array of the object */
 172         my_array = (AV*)SvRV(self);
 173
 174         /* sanity checks */
 175         if ( dim < 0 || dim > av_len(my_array) )
 176             croak( "No such dimension!" );
 177
 178         RETVAL = SvIV( *av_fetch(my_array, dim, 0) );
 179     OUTPUT:
 180         RETVAL
 181
 182
 183 #
 184 # my @vals = $vec->get_all_components;
 185 #
 186 # Get the values for all dimensions, in order from 0..N.
 187 #
 188 void
 189 get_all_components( self )
 190         SV*  self;
 191     PREINIT:
 192         IV   dim, i, val;
 193         AV*  my_array;
 194     PPCODE:
 195         /* fetch the underlying array of the object */
 196         my_array = (AV*)SvRV(self);
 197         dim = av_len(my_array);
 198
 199         /* extend the return stack and populate it */
 200         EXTEND(SP,dim+1);
 201         for ( i=0; i<=dim; i++ ) {
 202             val = SvIV( *av_fetch(my_array, i, 0) );
 203             PUSHs( sv_2mortal( newSViv(val) ) );
 204         }
 205
 206
 207 #- mutators
 208
 209 #
 210 # $vec->clear;
 211 #
 212 # Set the vector back to the origin, all 0's.
 213 #
 214 void
 215 clear( self )
 216         SV*  self;
 217     INIT:
 218         IV   dim, i, zero;
 219         AV*  my_array;
 220     PPCODE:
 221         /* fetch the underlying array of the object */
 222         my_array = (AV*)SvRV(self);
 223         dim = av_len(my_array);
 224
 225         /* clear each slot */
 226         for ( i=0; i<=dim; i++ ) {
 227             zero = newSViv(0);
 228             av_store(my_array, i, zero);
 229         }
 230
 231
 232 #
 233 # my $val = $vec->set_component( $dim, $value );
 234 #
 235 # Set the value for dimension $dim to $value.
 236 #
 237 void
 238 set_component( self, dim, value )
 239         SV*  self;
 240         IV   dim;
 241         IV   value;
 242     INIT:
 243         AV*  my_array;
 244     CODE:
 245         /* fetch the underlying array of the object */
 246         my_array = (AV*)SvRV(self);
 247
 248         /* sanity checks */
 249         if ( dim < 0 || dim > av_len(my_array) )
 250             croak( "No such dimension!" );
 251
 252         /* storing new value */
 253         av_store(my_array, dim, newSViv(value));
 254
 255
 256 #- other methods
 257
 258 #
 259 # my $is_within = $vec->bounds_check($begin, $end);
 260 #
 261 # Check whether $vec is within the box defined by $begin and $end.
 262 # Return 1 if vector is contained within the box, and 0 otherwise.
 263 #
 264 IV
 265 bounds_check( self, v1, v2 )
 266         SV*  self;
 267         SV*  v1;
 268         SV*  v2;
 269     INIT:
 270         IV   i, mydim, dimv1, dimv2, myval, val1, val2;
 271         AV*  my_array;
 272         AV*  v1_array;
 273         AV*  v2_array;
 274     PPCODE:
 275         /* fetch the underlying array of the object */
 276         my_array = (AV*)SvRV(self);
 277         v1_array = (AV*)SvRV(v1);
 278         v2_array = (AV*)SvRV(v2);
 279         mydim = av_len(my_array);
 280         dimv1 = av_len(v1_array);
 281         dimv2 = av_len(v2_array);
 282
 283         /* sanity checks */
 284         if ( mydim != dimv1 || mydim != dimv2 )
 285             croak("uneven dimensions in bounds check!");
 286
 287         /* compare the arrays */
 288         for ( i=0 ; i<=dimv1; i++ ) {
 289             myval = SvIV( *av_fetch(my_array, i, 0) );
 290             val1  = SvIV( *av_fetch(v1_array, i, 0) );
 291             val2  = SvIV( *av_fetch(v2_array, i, 0) );
 292             if ( myval < val1 || myval > val2 ) {
 293                 XPUSHs( sv_2mortal( newSViv(0) ) );
 294                 RETURN;
 295             }
 296         }
 297         XPUSHs( sv_2mortal( newSViv(1) ) );
 298
 299
 300
 301 # -- PRIVATE METHODS
 302
 303 #- math ops
 304
 305 #
 306 # my $vec = $v1->_add($v2);
 307 # my $vec = $v1 + $v2;
 308 #
 309 # Return a new LBVXS object, which is the result of $v1 plus $v2.
 310 #
 311 SV*
 312 _add( v1, v2, variant )
 313         SV*  v1;
 314         SV*  v2;
 315         SV*  variant;
 316     INIT:
 317         IV   dimv1, dimv2, i, val1, val2;
 318         SV*  self;
 319         AV*  my_array;
 320         AV*  v1_array;
 321         AV*  v2_array;
 322         HV*  stash;
 323     CODE:
 324         /* fetch the underlying array of the object */
 325         v1_array = (AV*)SvRV(v1);
 326         v2_array = (AV*)SvRV(v2);
 327         dimv1 = av_len(v1_array);
 328         dimv2 = av_len(v2_array);
 329
 330         /* sanity checks */
 331         if ( dimv1 != dimv2 )
 332             croak("uneven dimensions in vector addition!");
 333
 334         /* create the new array and populate it */
 335         my_array = newAV();
 336         for ( i=0 ; i<=dimv1; i++ ) {
 337             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 338             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 339             av_push( my_array, newSViv(val1+val2) );
 340             }
 341
 342         /* return a blessed reference to the AV */
 343         self  = newRV_noinc( (SV*)my_array );
 344         stash = SvSTASH( (SV*)v1_array );
 345         sv_bless( (SV*)self, stash );
 346         RETVAL = self;
 347     OUTPUT:
 348         RETVAL
 349
 350
 351 #
 352 # my $vec = $v1->_substract($v2);
 353 # my $vec = $v1 - $v2;
 354 #
 355 # Return a new LBVXS object, which is the result of $v1 minus $v2.
 356 #
 357 SV*
 358 _substract( v1, v2, variant )
 359         SV*  v1;
 360         SV*  v2;
 361         SV*  variant;
 362     INIT:
 363         IV   dimv1, dimv2, i, val1, val2;
 364         SV*  self;
 365         AV*  my_array;
 366         AV*  v1_array;
 367         AV*  v2_array;
 368         HV*  stash;
 369     CODE:
 370         /* fetch the underlying array of the object */
 371         v1_array = (AV*)SvRV(v1);
 372         v2_array = (AV*)SvRV(v2);
 373         dimv1 = av_len(v1_array);
 374         dimv2 = av_len(v2_array);
 375
 376         /* sanity checks */
 377         if ( dimv1 != dimv2 )
 378             croak("uneven dimensions in vector addition!");
 379
 380         /* create the new array and populate it */
 381         my_array = newAV();
 382         for ( i=0 ; i<=dimv1; i++ ) {
 383             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 384             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 385             av_push( my_array, newSViv(val1-val2) );
 386             }
 387
 388         /* return a blessed reference to the AV */
 389         self  = newRV_noinc( (SV*)my_array );
 390         stash = SvSTASH( (SV*)v1_array );
 391         sv_bless( (SV*)self, stash );
 392         RETVAL = self;
 393     OUTPUT:
 394         RETVAL
 395
 396
 397 #
 398 # my $vec = $v1->_invert;
 399 # my $vec = -$v1;
 400 #
 401 # Subtract $v1 from the origin. Effectively, gives the inverse of the
 402 # original vector. The new vector is the same distance from the origin,
 403 # in the opposite direction.
 404 #
 405 SV*
 406 _invert( v1, v2, variant )
 407         SV*  v1;
 408         SV*  v2;
 409         SV*  variant;
 410     INIT:
 411         IV   dim, i, val;
 412         SV*  self;
 413         AV*  my_array;
 414         AV*  v1_array;
 415         HV*  stash;
 416     CODE:
 417         /* fetch the underlying array of the object */
 418         v1_array = (AV*)SvRV(v1);
 419         dim = av_len(v1_array);
 420
 421         /* create the new array and populate it */
 422         my_array = newAV();
 423         for ( i=0 ; i<=dim; i++ ) {
 424             val = SvIV( *av_fetch(v1_array, i, 0) );
 425             av_push( my_array, newSViv(-val) );
 426             }
 427
 428         /* return a blessed reference to the AV */
 429         self  = newRV_noinc( (SV*)my_array );
 430         stash = SvSTASH( (SV*)v1_array );
 431         sv_bless( (SV*)self, stash );
 432         RETVAL = self;
 433     OUTPUT:
 434         RETVAL
 435
 436
 437
 438 #- inplace math ops
 439
 440 #
 441 # $v1->_add_inplace($v2);
 442 # $v1 += $v2;
 443 #
 444 # Adds $v2 to $v1, and stores the result back into $v1.
 445 #
 446 SV*
 447 _add_inplace( v1, v2, variant )
 448         SV*  v1;
 449         SV*  v2;
 450         SV*  variant;
 451     INIT:
 452         IV   dimv1, dimv2, i, val1, val2;
 453         AV*  v1_array;
 454         AV*  v2_array;
 455     CODE:
 456         /* fetch the underlying array of the object */
 457         v1_array = (AV*)SvRV(v1);
 458         v2_array = (AV*)SvRV(v2);
 459         dimv1 = av_len(v1_array);
 460         dimv2 = av_len(v2_array);
 461
 462         /* sanity checks */
 463         if ( dimv1 != dimv2 )
 464             croak("uneven dimensions in vector addition!");
 465
 466         /* update the array slots */
 467         for ( i=0 ; i<=dimv1; i++ ) {
 468             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 469             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 470             av_store( v1_array, i, newSViv(val1+val2) );
 471             }
 472     OUTPUT:
 473         v1
 474
 475
 476 #
 477 # $v1->_substract_inplace($v2);
 478 # $v1 -= $v2;
 479 #
 480 # Substract $v2 to $v1, and stores the result back into $v1.
 481 #
 482 SV*
 483 _substract_inplace( v1, v2, variant )
 484         SV*  v1;
 485         SV*  v2;
 486         SV*  variant;
 487     INIT:
 488         IV   dimv1, dimv2, i, val1, val2;
 489         AV*  v1_array;
 490         AV*  v2_array;
 491     CODE:
 492         /* fetch the underlying array of the object */
 493         v1_array = (AV*)SvRV(v1);
 494         v2_array = (AV*)SvRV(v2);
 495         dimv1 = av_len(v1_array);
 496         dimv2 = av_len(v2_array);
 497
 498         /* sanity checks */
 499         if ( dimv1 != dimv2 )
 500             croak("uneven dimensions in vector addition!");
 501
 502         /* update the array slots */
 503         for ( i=0 ; i<=dimv1; i++ ) {
 504             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 505             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 506             av_store( v1_array, i, newSViv(val1-val2) );
 507             }
 508     OUTPUT:
 509         v1
 510
 511
 512 #- comparison
 513
 514 #
 515 # my $bool = $v1->_compare($v2);
 516 # my $bool = $v1 <=> $v2;
 517 #
 518 # Check whether the vectors both point at the same spot. Return 0 if they
 519 # do, 1 if they don't.
 520 #
 521 IV
 522 _compare( v1, v2, variant )
 523         SV*  v1;
 524         SV*  v2;
 525         SV*  variant;
 526
 527     INIT:
 528         IV   dimv1, dimv2, i, val1, val2;
 529         AV*  v1_array;
 530         AV*  v2_array;
 531     PPCODE:
 532         /* fetch the underlying array of the object */
 533         v1_array = (AV*)SvRV(v1);
 534         v2_array = (AV*)SvRV(v2);
 535         dimv1 = av_len(v1_array);
 536         dimv2 = av_len(v2_array);
 537
 538         /* sanity checks */
 539         if ( dimv1 != dimv2 )
 540             croak("uneven dimensions in bounds check!");
 541
 542         /* compare the arrays */
 543         for ( i=0 ; i<=dimv1; i++ ) {
 544             val1 = SvIV( *av_fetch(v1_array, i, 0) );
 545             val2 = SvIV( *av_fetch(v2_array, i, 0) );
 546             if ( val1 != val2 ) {
 547                 XPUSHs( sv_2mortal( newSViv(1) ) );
 548                 RETURN;
 549             }
 550         }
 551         XPUSHs( sv_2mortal( newSViv(0) ) );
 552
 553