t/1-classes/storage-generic-sparse.t

   1 #!perl
   2 #
   3 # This file is part of Language::Befunge.
   4 # Copyright (c) 2001-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::Storage tests for Generic Sparse plugin
  13 #
  14
  15 use strict;
  16 use warnings;
  17
  18 use Test::Exception;
  19 use Test::More tests => 92;
  20
  21 use aliased 'Language::Befunge::Storage::Generic::Sparse' => 'Storage';
  22 use Language::Befunge::Wrapping::LaheySpace;
  23 use aliased 'Language::Befunge::Vector' => 'LBV';
  24 use List::Util qw{ max };
  25
  26
  27 # vars used within the file
  28 my ($href, $l, $s, $str, $v);
  29 my $str1 = 'Foobar baz';  my $lstr1 = length $str1;
  30 my $str2 = 'camel llama'; my $lstr2 = length $str2;
  31 my $wrap = Language::Befunge::Wrapping::LaheySpace->new();
  32
  33
  34 #-- constructor
  35
  36 #- new()
  37 $s = Storage->new(2, Wrapping => $wrap);
  38 isa_ok($s, 'Language::Befunge::Storage');
  39 isa_ok($s, 'Language::Befunge::Storage::Generic::Sparse');
  40 is($s->min, '(0,0)', 'new() initializes storage');
  41 is($s->max, '(0,0)', 'new() initializes storage');
  42 is($s->get_dims, 2, 'get_dims() returns the number passed to new()');
  43
  44
  45 #-- storage update
  46
  47 # clear()
  48 $s = Storage->new(2, Wrapping => $wrap);
  49 $s->store($str1, LBV->new(-2,-2));
  50 $s->store($str1, LBV->new( 2, 2));
  51 $s->clear;
  52 is($s->min, '(0,0)', 'clear() reinits min bounds');
  53 is($s->max, '(0,0)', 'clear() reinits max bounds');
  54 is($s->get_value(LBV->new(2,2)), 32, 'clear() clears previous data');
  55
  56
  57 #- store_binary()
  58 $s = Storage->new(2, Wrapping => $wrap);
  59
  60 # basic store_binary(), defaulting to origin
  61 $s->store_binary( $str1 );
  62 #        0         1         2
  63 #   5432101234567890123456789012345678
  64 #  1
  65 #  0     Foobar baz
  66 #  1
  67 #  2
  68 is($s->min, '(0,0)', 'store_binary() does not grow min bounds if not needed');
  69 is($s->max, '(9,0)', 'store_binary() grows max bounds if needed');
  70 is($s->rectangle(LBV->new(0,0), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
  71 is($s->min, '(0,0)', 'rectangle() does not unnecessarily expand the array');
  72 is($s->max, '(9,0)', 'rectangle() does not unnecessarily expand the array');
  73 is($s->get_value(LBV->new(-1,0)), 32, 'store_binary() does not spill');
  74 is($s->get_value(LBV->new(10,0)), 32, 'store_binary() does not spill');
  75 is($s->min, '(0,0)', 'get_value() does not unnecessarily expand the array');
  76 is($s->max, '(9,0)', 'get_value() does not unnecessarily expand the array');
  77
  78 # store_binary() with a positive offset
  79 $s->store_binary( $str1, LBV->new(4,2) );
  80 #        0         1         2
  81 #   5432101234567890123456789012345678
  82 #  2
  83 #  1
  84 #  0     Foobar baz
  85 #  1
  86 #  2         Foobar baz
  87 #  3
  88 is($s->min,  '(0,0)', 'store_binary() does not grow min bounds if not needed');
  89 is($s->max, '(13,2)', 'store_binary() grows max bounds if needed');
  90 is($s->rectangle(LBV->new(4,2), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
  91 is($s->get_value(LBV->new( 3,2)), 32, 'store_binary() does not spill');
  92 is($s->get_value(LBV->new(14,2)), 32, 'store_binary() does not spill');
  93
  94 # store_binary() with a negative offset
  95 $s->store_binary( $str1, LBV->new(-2,-1) );
  96 #        0         1         2
  97 #   5432101234567890123456789012345678
  98 #  2
  99 #  1   Foobar baz
 100 #  0     Foobar baz
 101 #  1
 102 #  2         Foobar baz
 103 #  3
 104 is($s->min, '(-2,-1)', 'store_binary() grows min bounds if needed');
 105 is($s->max,  '(13,2)', 'store_binary() does not grow max bounds if not needed');
 106 is($s->rectangle(LBV->new(-2,-1), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
 107 is($s->get_value(LBV->new(-3,-1)), 32, 'store_binary() does not spill');
 108 is($s->get_value(LBV->new( 8,-1)), 32, 'store_binary() does not spill');
 109
 110 # store_binary() overwriting
 111 $s->store_binary( $str2, LBV->new(2,0) );
 112 #        0         1         2
 113 #   5432101234567890123456789012345678
 114 #  2
 115 #  1   Foobar baz
 116 #  0     Focamelbllama
 117 #  1
 118 #  2         Foobar baz
 119 #  3
 120 is($s->get_value(LBV->new(2,0)), 99, 'store_binary() overwrites non-space');
 121 is($s->get_value(LBV->new(7,0)), 98, 'store_binary() does not overwrite with spaces');
 122
 123 # store_binary() returns the size inserted
 124 $v = $s->store_binary( $str1 );
 125 is($v, "($lstr1,1)", 'store_binary() returns the inserted size');
 126
 127 # store_binary() does not treat end of lines as such (crlf / lf / cr)
 128 # \n
 129 $str = "$str1\n$str2"; $l = length $str;
 130 $v = $s->store_binary( $str );
 131 is($v, "($l,1)", 'store_binary() does not treat \n as special');
 132 # \r\n
 133 $str = "$str1\r\n$str2"; $l = length $str;
 134 $v = $s->store_binary( $str );
 135 is($v, "($l,1)", 'store_binary() does not treat \r\n as special');
 136 # \r
 137 $str = "$str1\r$str2"; $l = length $str;
 138 $v = $s->store_binary( $str );
 139 is($v, "($l,1)", 'store_binary() does not treat \r as special');
 140
 141
 142 #- store()
 143 $s = Storage->new(2, Wrapping => $wrap);
 144
 145 # basic store(), defaulting to origin
 146 $s->store( $str1 );
 147 #        0         1         2
 148 #   5432101234567890123456789012345678
 149 #  1
 150 #  0     Foobar baz
 151 #  1
 152 #  2
 153 is($s->min, '(0,0)', 'store() does not grow min bounds if not needed');
 154 is($s->max, '(9,0)', 'store() grows max bounds if needed');
 155 is($s->rectangle(LBV->new(0,0), LBV->new($lstr1,1)), $str1, 'store() stores everything');
 156 is($s->get_value(LBV->new(-1,0)), 32, 'store() does not spill');
 157 is($s->get_value(LBV->new(10,0)), 32, 'store() does not spill');
 158
 159 # store() with a positive offset
 160 $s->store( $str1, LBV->new(4,2) );
 161 #        0         1         2
 162 #   5432101234567890123456789012345678
 163 #  2
 164 #  1
 165 #  0     Foobar baz
 166 #  1
 167 #  2         Foobar baz
 168 #  3
 169 is($s->min,  '(0,0)', 'store() does not grow min bounds if not needed');
 170 is($s->max, '(13,2)', 'store() grows max bounds if needed');
 171 is($s->rectangle(LBV->new(4,2), LBV->new($lstr1,1)), $str1, 'store() stores everything');
 172 is($s->get_value(LBV->new( 3,2)), 32, 'store() does not spill');
 173 is($s->get_value(LBV->new(14,2)), 32, 'store() does not spill');
 174
 175 # store() with a negative offset
 176 $s->store( $str1, LBV->new(-2,-1) );
 177 #        0         1         2
 178 #   5432101234567890123456789012345678
 179 #  2
 180 #  1   Foobar baz
 181 #  0     Foobar baz
 182 #  1
 183 #  2         Foobar baz
 184 #  3
 185 is($s->min, '(-2,-1)', 'store() grows min bounds if needed');
 186 is($s->max,  '(13,2)', 'store() does not grow max bounds if not needed');
 187 is($s->rectangle(LBV->new(-2,-1), LBV->new($lstr1,1)), $str1, 'store() stores everything');
 188 is($s->get_value(LBV->new(-3,-1)), 32, 'store() does not spill');
 189 is($s->get_value(LBV->new( 8,-1)), 32, 'store() does not spill');
 190
 191 # store() overwriting
 192 $s->store( $str2, LBV->new(2,0) );
 193 #        0         1         2
 194 #   5432101234567890123456789012345678
 195 #  2
 196 #  1   Foobar baz
 197 #  0     Focamelbllama
 198 #  1
 199 #  2         Foobar baz
 200 #  3
 201 is($s->get_value(LBV->new(2,0)), 99, 'store() overwrites non-space');
 202 is($s->get_value(LBV->new(7,0)), 98, 'store() does not overwrite with spaces');
 203
 204 # store() returns the size inserted
 205 $v = $s->store( "$str1\n    $str2" );
 206 $l = 4 + $lstr2; # 4 spaces before $str2
 207 is($v, "($l,2)", 'store() returns the inserted size');
 208
 209 # store() supports various end of lines (crlf / lf / cr)
 210 $l = max($lstr1, $lstr2);
 211 # \n
 212 $v = $s->store("$str1\n$str2");
 213 is($v, "($l,2)", 'store() supports \n eol');
 214 # \r\n
 215 $v = $s->store( "$str1\r\n$str2" );
 216 is($v, "($l,2)", 'store() supports \r\n eol');
 217 # \r
 218 $v = $s->store("$str1\r$str2");
 219 is($v, "($l,2)", 'store() supports \r eol');
 220
 221
 222 #- set_value()
 223 $s = Storage->new(2, Wrapping => $wrap);
 224 # set_value() grows storage
 225 $s->set_value(LBV->new(8,4), 65);
 226 is($s->min, '(0,0)', 'set_value() does not grow min bounds if not needed');
 227 is($s->max, '(8,4)', 'set_value() grows max bounds if needed');
 228 $s->set_value(LBV->new(-2,-3), 65);
 229 is($s->min, '(-2,-3)', 'set_value() grows min bounds if needed');
 230 is($s->max,   '(8,4)', 'set_value() does not grow max bounds if not needed');
 231 # set_value() sets/overwrites new value
 232 $s->clear;
 233 $v = LBV->new(8,4);
 234 $s->set_value($v, 65);
 235 is($s->get_value($v), 65, 'set_value() sets a new value');
 236 $s->set_value($v, 66);
 237 is($s->get_value($v), 66, 'set_value() overwrites with non-space values');
 238 $s->set_value($v, 32);
 239 is($s->get_value($v), 32, 'set_value() overwrites even with space values');
 240
 241
 242 #-- data retrieval
 243
 244 #- min() already tested plenty of time
 245 #- max() already tested plenty of time
 246
 247 #- get_value() already tested plenty of time
 248 # just need to test default value
 249 $s = Storage->new(2, Wrapping => $wrap);
 250 is($s->get_value(LBV->new(3,4)), 32, 'get_value() defaults to space');
 251
 252
 253 #- get_char()
 254 # basics
 255 $s = Storage->new(2, Wrapping => $wrap);
 256 $v = LBV->new(8,4);
 257 $s->set_value($v, 65);
 258 is($s->get_char($v), 'A', 'get_char() return correct character');
 259 # default value
 260 is($s->get_char(LBV->new(3,2)), ' ', 'get_char() defaults to space');
 261 # utf8 char
 262 $s->set_value($v, 9786); # smiley face
 263 is($s->get_char($v), "<np-0x263a>", 'get_char() return correct character');
 264
 265
 266 #- rectangle()
 267 $s = Storage->new(2, Wrapping => $wrap);
 268 $s->store($str1, LBV->new(-2,-2));
 269 $s->store($str1, LBV->new(-1,-1));
 270 $s->store($str1, LBV->new( 0, 0));
 271 $s->store($str1, LBV->new( 1, 1));
 272 $s->store($str1, LBV->new( 2, 2));
 273 #        0         1         2
 274 #   5432101234567890123456789012345678
 275 #  2   Foobar baz
 276 #  1    Foobar baz
 277 #  0     Foobar baz
 278 #  1      Foobar baz
 279 #  2       Foobar baz
 280 # basic usage
 281 is($s->rectangle(LBV->new(2,-1),LBV->new(5,1)), 'bar b', 'rectangle() returns correct data');
 282 is($s->rectangle(LBV->new(2,-1),LBV->new(9,3)), "bar baz  \nobar baz \noobar baz",
 283    'rectangle() returns correct data even with newlines');
 284 is($s->rectangle(LBV->new(19,1),LBV->new(5,1)), '     ', 'rectangle() returns correct data even with spaces');
 285 # empty row / column
 286 is($s->rectangle(LBV->new(0,0),LBV->new(5,0)), '', 'rectangle() with no height returns empty string');
 287 is($s->rectangle(LBV->new(0,0),LBV->new(0,5)), '', 'rectangle() with no width returns empty string');
 288
 289
 290 #-- misc methods
 291
 292 # labels_lookup()
 293 $s = Storage->new(2, Wrapping => $wrap);
 294 # four directions.
 295 $s->clear;
 296 $s->store( <<'EOF', LBV->new(-2, -1 ));
 297       3
 298       ;
 299       z
 300       a
 301       b
 302       :
 303 2;rab:;:foo;1
 304       :
 305       b
 306       l
 307       a
 308       h
 309       ;
 310       4
 311 EOF
 312 $href = $s->labels_lookup;
 313 isa_ok($href, 'HASH');
 314 is(scalar(keys(%$href)), 4,    'labels_lookup() finds everything');
 315 is($href->{foo}[0],  '(10,5)', 'labels_lookup() finds left-right');
 316 is($href->{bar}[0],  '(-2,5)', 'labels_lookup() finds right-left');
 317 is($href->{bar}[1],  '(-1,0)', 'labels_lookup() deals with right-left');
 318 is($href->{baz}[0],  '(4,-1)', 'labels_lookup() finds bottom-top');
 319 is($href->{baz}[1],  '(0,-1)', 'labels_lookup() deals with bottom-top');
 320 is($href->{blah}[0], '(4,12)', 'labels_lookup() finds top-bottom');
 321 is($href->{blah}[1], '(0,1)',  'labels_lookup() deals with top-bottom');
 322
 323 # wrapping...
 324 $s->clear;
 325 $s->store( <<'EOF', LBV->new(-2, -1 ));
 326 ;1      z  ;   ;:foo
 327 rab:;   a  4      2;
 328         b
 329         :  ;
 330         ;  :
 331            b
 332            l
 333         3  a
 334         ;  h
 335 EOF
 336 $href = $s->labels_lookup;
 337 is(scalar(keys(%$href)), 4,     'labels_lookup() finds everything, even wrapping');
 338 is($href->{foo}[0],  '(-1,-1)', 'labels_lookup() finds left-right');
 339 is($href->{foo}[1],  '(1,0)',   'labels_lookup() deals with left-right');
 340 is($href->{bar}[0],  '(16,0)',  'labels_lookup() finds right-left');
 341 is($href->{bar}[1],  '(-1,0)',  'labels_lookup() deals with right-left');
 342 is($href->{baz}[0],  '(6,6)',   'labels_lookup() finds bottom-top');
 343 is($href->{baz}[1],  '(0,-1)',  'labels_lookup() deals with bottom-top');
 344 is($href->{blah}[0], '(9,0)',   'labels_lookup() finds top-bottom');
 345 is($href->{blah}[1], '(0,1)',   'labels_lookup() deals with top-bottom');
 346
 347 # garbage...
 348 $s->clear;
 349 $s->store( <<'EOF', LBV->new(-2, -1 ));
 350    ;:foo is foo;1
 351      ;not a label;
 352 EOF
 353 $href = $s->labels_lookup;
 354 is(scalar(keys(%$href)), 1,    'labels_lookup() does not get fooled by look-alike labels');
 355 is($href->{foo}[0], '(14,-1)', 'labels_lookup() discards comments');
 356 is($href->{foo}[1], '(1,0)',   'labels_lookup() discards comments');
 357
 358 # double define...
 359 $s->clear;
 360 $s->store( <<'EOF', LBV->new(-2, -1 ));
 361    ;:foo is foo;1
 362    2;another oof:;
 363 EOF
 364 throws_ok(sub { $s->labels_lookup },
 365         qr/^Help! I found two labels 'foo' in the funge space/,
 366     'labels_lookup() chokes on double-defined labels');
 367
 368
 369
 370 __END__
 371
 372
 373
 374 # move ip.
 375 $ls->clear;   # "positive" playfield.
 376 $ls->_set_max(5, 10);
 377 $ip->set_position(LBV->new( 4, 3 ));
 378 $ip->get_delta->set_component(0, 1 );
 379 $ip->get_delta->set_component(1, 0 );
 380 $ls->move_ip_forward( $ip );
 381 is( $ip->get_position->get_component(0), 5, "move_ip_forward respects dx" );
 382 $ls->move_ip_forward( $ip );
 383 is( $ip->get_position->get_component(0), 0, "move_ip_forward wraps xmax" );
 384 $ip->set_position(LBV->new( 4, 3 ));
 385 $ip->get_delta->set_component(0, 7 );
 386 $ip->get_delta->set_component(1, 0 );
 387 $ls->move_ip_forward( $ip );
 388 is( $ip->get_position->get_component(0), 4, "move_ip_forward deals with delta overflowing torus width" );
 389 $ls->move_ip_forward( $ip ); # wrap xmax harder
 390 is( $ip->get_position->get_component(0), 4, "move_ip_forward deals with delta overflowing torus width" );
 391 $ip->set_position(LBV->new( 0, 4 ));
 392 $ip->get_delta->set_component(0, -1 );
 393 $ip->get_delta->set_component(1, 0 );
 394 $ls->move_ip_forward( $ip );
 395 is( $ip->get_position->get_component(0), 5, "move_ip_forward wraps xmin" );
 396
 397 $ip->set_position(LBV->new(2, 9 ));
 398 $ip->get_delta->set_component(0, 0 );
 399 $ip->get_delta->set_component(1, 1 );
 400 $ls->move_ip_forward( $ip );
 401 is( $ip->get_position->get_component(1), 10, "move_ip_forward respects dy" );
 402 $ls->move_ip_forward( $ip );
 403 is( $ip->get_position->get_component(1), 0,  "move_ip_forward wraps ymax" );
 404 $ip->set_position(LBV->new(2, 9 ));
 405 $ip->get_delta->set_component(0, 0 );
 406 $ip->get_delta->set_component(1, 12 );               # apply delta that overflows torus height
 407 $ls->move_ip_forward( $ip );
 408 is( $ip->get_position->get_component(1), 9, "move_ip_forward deals with delta overflowing torus heigth" );
 409 $ls->move_ip_forward( $ip ); # wrap ymax harder
 410 is( $ip->get_position->get_component(1), 9, "move_ip_forward deals with delta overflowing torus heigth" );
 411 $ip->set_position(LBV->new(1, 0 ));
 412 $ip->get_delta->set_component(0, 0 );
 413 $ip->get_delta->set_component(1, -1 );
 414 $ls->move_ip_forward( $ip );
 415 is( $ip->get_position->get_component(1), 10, "move_ip_forward wraps ymin" );
 416 BEGIN { $tests += 10 }
 417
 418 $ls->clear;   # "negative" playfield.
 419 $ls->_set_min(-1, -3);
 420 $ls->_set_max(5, 10);
 421 $ip->set_position(LBV->new(4, 3 ));
 422 $ip->get_delta->set_component(0, 1 );
 423 $ip->get_delta->set_component(1, 0 );
 424 $ls->move_ip_forward( $ip );
 425 is( $ip->get_position->get_component(0), 5, "move_ip_forward respects dx" );
 426 $ls->move_ip_forward( $ip );
 427 is( $ip->get_position->get_component(0), -1, "move_ip_forward wraps xmax" );
 428 $ip->set_position(LBV->new(-1, 4 ));
 429 $ip->get_delta->set_component(0, -1 );
 430 $ip->get_delta->set_component(1, 0 );
 431 $ls->move_ip_forward( $ip );
 432 is( $ip->get_position->get_component(0), 5, "move_ip_forward wraps xmin" );
 433 $ip->set_position(LBV->new(2, 9 ));
 434 $ip->get_delta->set_component(0, 0 );
 435 $ip->get_delta->set_component(1, 1 );
 436 $ls->move_ip_forward( $ip );
 437 is( $ip->get_position->get_component(1), 10, "move_ip_forward respects dy" );
 438 $ls->move_ip_forward( $ip );
 439 is( $ip->get_position->get_component(1), -3, "move_ip_forward wraps ymax" );
 440 $ip->set_position(LBV->new(1, -3 ));
 441 $ip->get_delta->set_component(0, 0 );
 442 $ip->get_delta->set_component(1, -1 );
 443 $ls->move_ip_forward( $ip );
 444 is( $ip->get_position->get_component(1), 10, "move_ip_forward wraps ymin" );
 445 BEGIN { $tests += 6; }
 446
 447 $ls->clear;   # diagonals.
 448 $ls->_set_min(-1, -2);
 449 $ls->_set_max(6, 5);
 450 $ip->set_position(LBV->new(0, 0));
 451 $ip->get_delta->set_component(0,-2);
 452 $ip->get_delta->set_component(1,-3);
 453 $ls->move_ip_forward( $ip );
 454 is( $ip->get_position->get_component(0), 2, "move_ip_forward deals with diagonals" );
 455 is( $ip->get_position->get_component(1), 3, "move_ip_forward deals with diagonals" );
 456 BEGIN { $tests += 2; }
 457
 458
 459
 460
 461 BEGIN { plan tests => $tests };