t/1-vector.t

   1 #!perl
   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 # Language::Befunge::Vector::XS tests
  13 # taken from Language::Befunge::Vector
  14 #
  15
  16 use strict;
  17 use warnings;
  18 use Config;
  19
  20 use Test::More tests => 151;
  21
  22 use Language::Befunge::Vector::XS;
  23
  24
  25 # check prereq for test
  26 eval "use Test::Exception";
  27 my $has_test_exception = defined($Test::Exception::VERSION);
  28
  29
  30 my ($v1, $v2, $v3, $v4, @coords);
  31 my $v2d = Language::Befunge::Vector::XS->new(3,4);
  32 my $v3d = Language::Befunge::Vector::XS->new(5,6,7);
  33
  34
  35 # -- CONSTRUCTORS
  36
  37 # new()
  38 $v1 = Language::Befunge::Vector::XS->new(7,8,9);
  39 isa_ok($v1,                          "Language::Befunge::Vector::XS");
  40 is($v1->get_dims,                 3, "three dimensions");
  41 is($v1->get_component(0),         7, "X is correct");
  42 is($v1->get_component(1),         8, "Y is correct");
  43 is($v1->get_component(2),         9, "Z is correct");
  44 is($v1->as_string,        '(7,8,9)', "stringifies back to (7,8,9)");
  45 is("$v1",                 '(7,8,9)', "overloaded stringify back to (7,8,9)");
  46 SKIP: {
  47     skip "need Test::Exception", 1 unless $has_test_exception;
  48         throws_ok(sub { Language::Befunge::Vector::XS->new() },
  49                 qr/Usage/, "LBV::XS->new needs a defined 'dimensions' argument");
  50 }
  51
  52
  53 # new_zeroes()
  54 $v1 = Language::Befunge::Vector::XS->new_zeroes(4);
  55 isa_ok($v1,                            "Language::Befunge::Vector::XS");
  56 is($v1->get_dims,                   4, "four dimensions");
  57 is($v1->get_component(0),           0, "X is correct");
  58 is($v1->get_component(1),           0, "Y is correct");
  59 is($v1->get_component(2),           0, "Z is correct");
  60 is($v1->get_component(3),           0, "T is correct");
  61 is("$v1",                 '(0,0,0,0)', "all values are 0");
  62 SKIP: {
  63     skip "need Test::Exception", 2 unless $has_test_exception;
  64         throws_ok(sub { Language::Befunge::Vector::XS->new_zeroes() },
  65                 qr/Usage/, "LBV::XS->new_zeroes needs a defined 'dimensions' argument");
  66         throws_ok(sub { Language::Befunge::Vector::XS->new_zeroes(0) },
  67                 qr/Usage/, "LBV::XS->new_zeroes needs a non-zero 'dimensions' argument");
  68 }
  69
  70
  71 # copy()
  72 $v1 = Language::Befunge::Vector::XS->new(2,3,4,5);
  73 $v4 = Language::Befunge::Vector::XS->new(6,7,8,9);
  74 $v2 = $v1->copy;
  75 $v3 = $v1;
  76 is("$v1", "$v2", "v1 has been copied");
  77 $v1 += $v4;
  78 is("$v1", "(8,10,12,14)", "v1 has had v4 added");
  79 is("$v2",    "(2,3,4,5)", "v2 hasn't changed");
  80 is("$v3",    "(2,3,4,5)", "v3 hasn't changed");
  81
  82
  83
  84 # -- PUBLIC METHODS
  85
  86 #- accessors
  87
  88 # get_dims() has already been tested above...
  89
  90
  91 # get_component()
  92 # regular behaviour is tested all over this script.
  93 $v1 = Language::Befunge::Vector::XS->new(2,3);
  94 SKIP: {
  95     skip "need Test::Exception", 2 unless $has_test_exception;
  96         throws_ok(sub { $v2d->get_component(-1) },
  97                 qr/No such dimension/, "get_component() checks min dimension");
  98         throws_ok(sub { $v1->get_component(2) },
  99                 qr/No such dimension/, "get_component() checks max dimension");
 100 }
 101
 102
 103 # get_all_components()
 104 $v1 = Language::Befunge::Vector::XS->new(2,3,4,5);
 105 my @list = $v1->get_all_components;
 106 is(scalar @list, 4, "get_all_components() returned 4 elements");
 107 is($list[0], 2, "X is 2");
 108 is($list[1], 3, "Y is 3");
 109 is($list[2], 4, "Z is 4");
 110 is($list[3], 5, "T is 5");
 111
 112
 113 # as_string() is already tested above.
 114
 115
 116 #- mutators
 117
 118 # clear()
 119 $v1 = Language::Befunge::Vector::XS->new(2,3,4,5);
 120 $v1->clear;
 121 is("$v1",                 '(0,0,0,0)', "clear() sets all values are 0");
 122 is($v1->get_component(0),           0, "X is now 0");
 123 is($v1->get_component(1),           0, "Y is now 0");
 124 is($v1->get_component(2),           0, "Z is now 0");
 125 is($v1->get_component(3),           0, "T is now 0");
 126
 127
 128 # set_component()
 129 $v1 = Language::Befunge::Vector::XS->new(2,3,4,5);
 130 $v1->set_component(0,9);
 131 $v1->set_component(1,6);
 132 is($v1->as_string,        "(9,6,4,5)", "set_component() works");
 133 is($v1->get_component(0),           9, "X is now 9");
 134 is($v1->get_component(1),           6, "Y is now 6");
 135 is($v1->get_component(2),           4, "Z is still 4");
 136 is($v1->get_component(3),           5, "T is still 5");
 137 SKIP: {
 138     skip "need Test::Exception", 2 unless $has_test_exception;
 139         throws_ok(sub { $v1->set_component(-1, 0) },
 140                 qr/No such dimension/, "set_component() checks min dimension");
 141         throws_ok(sub { $v1->set_component(4, 0) },
 142                 qr/No such dimension/, "set_component() checks max dimension");
 143 }
 144
 145
 146 #- other methods
 147
 148 # bounds_check()
 149 $v1 = Language::Befunge::Vector::XS->new(-1, -1);
 150 $v2 = Language::Befunge::Vector::XS->new( 2,  2);
 151 @coords = ( [1,1], [-1,1], [1,-1], [-1,-1], [2,1], [1,2], [2,2] );
 152 foreach my $coords ( @coords ) {
 153     $v3 = Language::Befunge::Vector::XS->new(@$coords);
 154     ok($v3->bounds_check($v1, $v2), "$v3 is within bounds");
 155 }
 156 @coords = ( [3,3], [3,1], [1,3], [-2,1], [1,-2], [-2,-2] );
 157 foreach my $coords ( @coords ) {
 158     $v3 = Language::Befunge::Vector::XS->new(@$coords);
 159     ok(!$v3->bounds_check($v1, $v2), "$v3 is within bounds");
 160 }
 161 SKIP: {
 162     skip "need Test::Exception", 3 unless $has_test_exception;
 163         throws_ok(sub { $v3d->bounds_check($v1, $v2) },
 164                 qr/uneven dimensions/, "bounds_check() catches wrong dimension in first arg");
 165         throws_ok(sub { $v1->bounds_check($v3d, $v2) },
 166                 qr/uneven dimensions/, "bounds_check() catches wrong dimension in second arg");
 167         throws_ok(sub { $v1->bounds_check($v2, $v3d) },
 168                 qr/uneven dimensions/, "bounds_check() catches wrong dimension in third arg");
 169 }
 170
 171
 172 # rasterize
 173 $v1 = Language::Befunge::Vector::XS->new(-1, -1, -1);
 174 $v2 = Language::Befunge::Vector::XS->new(1, 1, 1);
 175 my @expectations = (
 176     [-1, -1, -1], [ 0, -1, -1], [ 1, -1, -1],
 177     [-1,  0, -1], [ 0,  0, -1], [ 1,  0, -1],
 178     [-1,  1, -1], [ 0,  1, -1], [ 1,  1, -1],
 179     [-1, -1,  0], [ 0, -1,  0], [ 1, -1,  0],
 180     [-1,  0,  0], [ 0,  0,  0], [ 1,  0,  0],
 181     [-1,  1,  0], [ 0,  1,  0], [ 1,  1,  0],
 182     [-1, -1,  1], [ 0, -1,  1], [ 1, -1,  1],
 183     [-1,  0,  1], [ 0,  0,  1], [ 1,  0,  1],
 184     [-1,  1,  1], [ 0,  1,  1], [ 1,  1,  1]);
 185 for($v3 = $v1->copy; scalar @expectations; $v3 = $v3->rasterize($v1, $v2)) {
 186     my $expect = shift @expectations;
 187     $expect = Language::Befunge::Vector::XS->new(@$expect);
 188     is($v3, $expect, "next one is $expect");
 189     is(ref($v3), "Language::Befunge::Vector::XS", "retval is also a LBVXS");
 190 }
 191 is($v3, undef, "rasterize returns undef at end of loop");
 192
 193
 194 # _xs_rasterize_ptr
 195 my $ptr = Language::Befunge::Vector::XS::_xs_rasterize_ptr();
 196 ok(defined($ptr), "rasterize pointer is defined");
 197 is(length($ptr), $Config{ptrsize}, "rasterize pointer is the right size");
 198
 199
 200
 201 #- math ops
 202
 203 # addition
 204 $v1 = Language::Befunge::Vector::XS->new(4,5,6);
 205 $v2 = Language::Befunge::Vector::XS->new(1,2,3);
 206 $v3 = $v1 + $v2;
 207 is("$v1",   '(4,5,6)', "addition doesn't change v1");
 208 is("$v2",   '(1,2,3)', "addition doesn't change v2");
 209 isa_ok($v3,            "Language::Befunge::Vector::XS");
 210 is("$v3",   '(5,7,9)', "v3 is v1 plus v2");
 211 SKIP: {
 212     skip "need Test::Exception", 1 unless $has_test_exception;
 213         throws_ok(sub { my $blah = $v2d + $v3d },
 214                 qr/uneven dimensions/, "misaligned vector arithmetic (+)");
 215 }
 216
 217
 218 # substraction
 219 $v1 = Language::Befunge::Vector::XS->new(4,5,6);
 220 $v2 = Language::Befunge::Vector::XS->new(3,2,1);
 221 $v3 = $v1 - $v2;
 222 is("$v1",   '(4,5,6)', "substraction doesn't change v1");
 223 is("$v2",   '(3,2,1)', "substraction doesn't change v2");
 224 isa_ok($v3,            "Language::Befunge::Vector::XS");
 225 is("$v3",   '(1,3,5)', "v3 is v1 minus v2");
 226 SKIP: {
 227     skip "need Test::Exception", 1 unless $has_test_exception;
 228         throws_ok(sub { my $blah = $v2d - $v3d },
 229                 qr/uneven dimensions/, "misaligned vector arithmetic (-)");
 230 }
 231
 232
 233 # inversion
 234 $v1 = Language::Befunge::Vector::XS->new(4,5,6);
 235 $v2 = -$v1;
 236 is("$v1",      '(4,5,6)', "inversion doesn't change v1");
 237 is("$v2",   '(-4,-5,-6)', "inversion doesn't change v2");
 238
 239
 240 #- inplace math ops
 241
 242 # inplace addition
 243 $v1 = Language::Befunge::Vector::XS->new(4,5,6);
 244 $v2 = Language::Befunge::Vector::XS->new(1,2,3);
 245 $v1 += $v2;
 246 is("$v1", "(5,7,9)", "inplace addition changes v1");
 247 is("$v2", "(1,2,3)", "inplace addition doesn't change v2");
 248 SKIP: {
 249     skip "need Test::Exception", 1 unless $has_test_exception;
 250         throws_ok(sub { $v2d += $v3d },
 251                 qr/uneven dimensions/, "misaligned vector arithmetic (+=)");
 252 }
 253
 254
 255 # inplace substraction
 256 $v1 = Language::Befunge::Vector::XS->new(4,5,6);
 257 $v2 = Language::Befunge::Vector::XS->new(3,2,1);
 258 $v1 -= $v2;
 259 is("$v1", "(1,3,5)", "inplace substraction changes v1");
 260 is("$v2", "(3,2,1)", "inplace substraction doesn't change v2");
 261 SKIP: {
 262     skip "need Test::Exception", 1 unless $has_test_exception;
 263         throws_ok(sub { $v2d -= $v3d },
 264                 qr/uneven dimensions/, "misaligned vector arithmetic (-=)");
 265 }
 266
 267
 268 #- comparison
 269
 270 # equality
 271 $v1 = Language::Befunge::Vector::XS->new(1,2,3);
 272 $v2 = Language::Befunge::Vector::XS->new(1,2,3);
 273 ok($v1 == $v1, "v1 == v1");
 274 ok($v1 == $v2, "v1 == v2");
 275 ok($v2 == $v1, "v2 == v1");
 276 @coords = ( [0,2,3], [1,0,3], [1,2,0] );
 277 foreach my $coords ( @coords ) {
 278     $v3 = Language::Befunge::Vector::XS->new(@$coords);
 279     ok(!($v1 == $v3), "!(v1 == $v3)");
 280     ok(!($v2 == $v3), "!(v2 == $v3)");
 281 }
 282 SKIP: {
 283     skip "need Test::Exception", 1 unless $has_test_exception;
 284         throws_ok(sub { $v2d == $v3d },
 285                 qr/uneven dimensions/, "misaligned vector arithmetic (==)");
 286 }
 287
 288
 289 # inequality
 290 $v1 = Language::Befunge::Vector::XS->new(1,2,3);
 291 $v2 = Language::Befunge::Vector::XS->new(1,2,3);
 292 ok(!($v1 != $v1), "!(v1 != v1)");
 293 ok(!($v1 != $v2), "!(v1 != v2)");
 294 ok(!($v2 != $v1), "!(v2 != v1)");
 295 @coords = ( [0,2,3], [1,0,3], [1,2,0] );
 296 foreach my $coords ( @coords ) {
 297     $v3 = Language::Befunge::Vector::XS->new(@$coords);
 298     ok($v1 != $v3, "v1 != $v3)");
 299     ok($v2 != $v3, "v2 != $v3)");
 300 }
 301 SKIP: {
 302     skip "need Test::Exception", 1 unless $has_test_exception;
 303         throws_ok(sub { $v2d != $v3d },
 304                 qr/uneven dimensions/, "misaligned vector arithmetic (!=)");
 305 }
 306
 307
 308