t/1-classes/storage-generic-vec.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 Vec plugin
  13 #
  14
  15 use strict;
  16 use warnings;
  17
  18 use Test::Exception;
  19 use Test::More tests => 104;
  20
  21 use Language::Befunge::Storage::Generic::Vec;
  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 = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
  38 isa_ok($s, 'Language::Befunge::Storage');
  39 isa_ok($s, 'Language::Befunge::Storage::Generic::Vec');
  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 # _offset
  46 $$s{min} = LBV->new(0, 0);
  47 $$s{max} = LBV->new(2, 4);
  48 is($s->_offset(LBV->new(0, 0)), 0, 'offset returns origin correctly');
  49 is($s->_offset(LBV->new(1, 0)), 1, 'offset increments correctly for X axis');
  50 is($s->_offset(LBV->new(0, 1)), 3, 'offset increments correctly for Y axis');
  51 $$s{min} = LBV->new(-1, -1);
  52 $$s{max} = LBV->new(1, 3);
  53 is($s->_offset(LBV->new(-1, -1)), 0, 'offset returns origin correctly');
  54 is($s->_offset(LBV->new(0, -1)), 1, 'offset increments correctly for X axis');
  55 is($s->_offset(LBV->new(-1, 0)), 3, 'offset increments correctly for Y axis');
  56 $s->clear();
  57
  58
  59 #-- storage update
  60
  61 # clear()
  62 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
  63 $s->store($str1, LBV->new(-2,-2));
  64 $s->store($str1, LBV->new( 2, 2));
  65 $s->clear;
  66 is($s->min, '(0,0)', 'clear() reinits min bounds');
  67 is($s->max, '(0,0)', 'clear() reinits max bounds');
  68 is($s->get_value(LBV->new(2,2)), 32, 'clear() clears previous data');
  69
  70
  71 #- store_binary()
  72 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
  73
  74 # basic store_binary(), defaulting to origin
  75 $s->store_binary( $str1 );
  76 #        0         1         2
  77 #   5432101234567890123456789012345678
  78 #  1
  79 #  0     Foobar baz
  80 #  1
  81 #  2
  82 is($s->min, '(0,0)', 'store_binary() does not grow min bounds if not needed');
  83 is($s->max, '(9,0)', 'store_binary() grows max bounds if needed');
  84 is($s->rectangle(LBV->new(0,0), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
  85 is($s->min, '(0,0)', 'rectangle() does not unnecessarily expand the array');
  86 is($s->max, '(9,0)', 'rectangle() does not unnecessarily expand the array');
  87 is($s->get_value(LBV->new(-1,0)), 32, 'store_binary() does not spill');
  88 is($s->get_value(LBV->new(10,0)), 32, 'store_binary() does not spill');
  89 is($s->min, '(0,0)', 'get_value() does not unnecessarily expand the array');
  90 is($s->max, '(9,0)', 'get_value() does not unnecessarily expand the array');
  91
  92 # store_binary() with a positive offset
  93 $s->store_binary( $str1, LBV->new(4,2) );
  94 #        0         1         2
  95 #   5432101234567890123456789012345678
  96 #  2
  97 #  1
  98 #  0     Foobar baz
  99 #  1
 100 #  2         Foobar baz
 101 #  3
 102 is($s->min,  '(0,0)', 'store_binary() does not grow min bounds if not needed');
 103 is($s->max, '(13,2)', 'store_binary() grows max bounds if needed');
 104 is($s->rectangle(LBV->new(4,2), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
 105 is($s->get_value(LBV->new( 3,2)), 32, 'store_binary() does not spill');
 106 is($s->get_value(LBV->new(14,2)), 32, 'store_binary() does not spill');
 107
 108 # store_binary() with a negative offset
 109 $s->store_binary( $str1, LBV->new(-2,-1) );
 110 #        0         1         2
 111 #   5432101234567890123456789012345678
 112 #  2
 113 #  1   Foobar baz
 114 #  0     Foobar baz
 115 #  1
 116 #  2         Foobar baz
 117 #  3
 118 is($s->min, '(-2,-1)', 'store_binary() grows min bounds if needed');
 119 is($s->max,  '(13,2)', 'store_binary() does not grow max bounds if not needed');
 120 is($s->rectangle(LBV->new(-2,-1), LBV->new($lstr1,1)), $str1, 'store_binary() stores everything');
 121 is($s->get_value(LBV->new(-3,-1)), 32, 'store_binary() does not spill');
 122 is($s->get_value(LBV->new( 8,-1)), 32, 'store_binary() does not spill');
 123
 124 # store_binary() overwriting
 125 $s->store_binary( $str2, LBV->new(2,0) );
 126 #        0         1         2
 127 #   5432101234567890123456789012345678
 128 #  2
 129 #  1   Foobar baz
 130 #  0     Focamelbllama
 131 #  1
 132 #  2         Foobar baz
 133 #  3
 134 is($s->get_value(LBV->new(2,0)), 99, 'store_binary() overwrites non-space');
 135 is($s->get_value(LBV->new(7,0)), 98, 'store_binary() does not overwrite with spaces');
 136
 137 # store_binary() returns the size inserted
 138 $v = $s->store_binary( $str1 );
 139 is($v, "($lstr1,1)", 'store_binary() returns the inserted size');
 140
 141 # store_binary() does not treat end of lines as such (crlf / lf / cr)
 142 # \n
 143 $str = "$str1\n$str2"; $l = length $str;
 144 $v = $s->store_binary( $str );
 145 is($v, "($l,1)", 'store_binary() does not treat \n as special');
 146 # \r\n
 147 $str = "$str1\r\n$str2"; $l = length $str;
 148 $v = $s->store_binary( $str );
 149 is($v, "($l,1)", 'store_binary() does not treat \r\n as special');
 150 # \r
 151 $str = "$str1\r$str2"; $l = length $str;
 152 $v = $s->store_binary( $str );
 153 is($v, "($l,1)", 'store_binary() does not treat \r as special');
 154
 155
 156 #- store()
 157 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
 158
 159 # basic store(), defaulting to origin
 160 $s->store( $str1 );
 161 #        0         1         2
 162 #   5432101234567890123456789012345678
 163 #  1
 164 #  0     Foobar baz
 165 #  1
 166 #  2
 167 is($s->min, '(0,0)', 'store() does not grow min bounds if not needed');
 168 is($s->max, '(9,0)', 'store() grows max bounds if needed');
 169 is($s->rectangle(LBV->new(0,0), LBV->new($lstr1,1)), $str1, 'store() stores everything');
 170 is($s->get_value(LBV->new(-1,0)), 32, 'store() does not spill');
 171 is($s->get_value(LBV->new(10,0)), 32, 'store() does not spill');
 172
 173 # store() with a positive offset
 174 $s->store( $str1, LBV->new(4,2) );
 175 #        0         1         2
 176 #   5432101234567890123456789012345678
 177 #  2
 178 #  1
 179 #  0     Foobar baz
 180 #  1
 181 #  2         Foobar baz
 182 #  3
 183 is($s->min,  '(0,0)', 'store() does not grow min bounds if not needed');
 184 is($s->max, '(13,2)', 'store() grows max bounds if needed');
 185 is($s->rectangle(LBV->new(4,2), LBV->new($lstr1,1)), $str1, 'store() stores everything');
 186 is($s->get_value(LBV->new( 3,2)), 32, 'store() does not spill');
 187 is($s->get_value(LBV->new(14,2)), 32, 'store() does not spill');
 188
 189 # store() with a negative offset
 190 $s->store( $str1, LBV->new(-2,-1) );
 191 #        0         1         2
 192 #   5432101234567890123456789012345678
 193 #  2
 194 #  1   Foobar baz
 195 #  0     Foobar baz
 196 #  1
 197 #  2         Foobar baz
 198 #  3
 199 is($s->min, '(-2,-1)', 'store() grows min bounds if needed');
 200 is($s->max,  '(13,2)', 'store() does not grow max bounds if not needed');
 201 is($s->rectangle(LBV->new(-2,-1), LBV->new($lstr1,1)), $str1, 'store() stores everything');
 202 is($s->get_value(LBV->new(-3,-1)), 32, 'store() does not spill');
 203 is($s->get_value(LBV->new( 8,-1)), 32, 'store() does not spill');
 204
 205 # store() overwriting
 206 $s->store( $str2, LBV->new(2,0) );
 207 #        0         1         2
 208 #   5432101234567890123456789012345678
 209 #  2
 210 #  1   Foobar baz
 211 #  0     Focamelbllama
 212 #  1
 213 #  2         Foobar baz
 214 #  3
 215 is($s->get_value(LBV->new(2,0)), 99, 'store() overwrites non-space');
 216 is($s->get_value(LBV->new(7,0)), 98, 'store() does not overwrite with spaces');
 217
 218 # store() returns the size inserted
 219 $v = $s->store( "$str1\n    $str2" );
 220 $l = 4 + $lstr2; # 4 spaces before $str2
 221 is($v, "($l,2)", 'store() returns the inserted size');
 222
 223 # store() supports various end of lines (crlf / lf / cr)
 224 $l = max($lstr1, $lstr2);
 225 # \n
 226 $v = $s->store("$str1\n$str2");
 227 is($v, "($l,2)", 'store() supports \n eol');
 228 # \r\n
 229 $v = $s->store( "$str1\r\n$str2" );
 230 is($v, "($l,2)", 'store() supports \r\n eol');
 231 # \r
 232 $v = $s->store("$str1\r$str2");
 233 is($v, "($l,2)", 'store() supports \r eol');
 234
 235
 236 #- set_value()
 237 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
 238 # set_value() grows storage
 239 $s->set_value(LBV->new(8,4), 65);
 240 is($s->min, '(0,0)', 'set_value() does not grow min bounds if not needed');
 241 is($s->max, '(8,4)', 'set_value() grows max bounds if needed');
 242 $s->set_value(LBV->new(-2,-3), 65);
 243 is($s->min, '(-2,-3)', 'set_value() grows min bounds if needed');
 244 is($s->max,   '(8,4)', 'set_value() does not grow max bounds if not needed');
 245 # set_value() sets/overwrites new value
 246 $s->clear;
 247 $v = LBV->new(8,4);
 248 $s->set_value($v, 65);
 249 is($s->get_value($v), 65, 'set_value() sets a new value');
 250 $s->set_value($v, 66);
 251 is($s->get_value($v), 66, 'set_value() overwrites with non-space values');
 252 $s->set_value($v, 32);
 253 is($s->get_value($v), 32, 'set_value() overwrites even with space values');
 254
 255
 256 #-- data retrieval
 257
 258 #- min() already tested plenty of time
 259 #- max() already tested plenty of time
 260
 261 #- get_value() already tested plenty of time
 262 # just need to test default value
 263 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
 264 is($s->get_value(LBV->new(3,4)), 32, 'get_value() defaults to space');
 265
 266
 267 #- get_char()
 268 # basics
 269 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
 270 $v = LBV->new(8,4);
 271 $s->set_value($v, 65);
 272 is($s->get_char($v), 'A', 'get_char() return correct character');
 273 # default value
 274 is($s->get_char(LBV->new(3,2)), ' ', 'get_char() defaults to space');
 275 # utf8 char
 276 $s->set_value($v, 9786); # smiley face
 277 is($s->get_char($v), "<np-0x263a>", 'get_char() return correct character');
 278
 279
 280 #- rectangle()
 281 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
 282 $s->store($str1, LBV->new(-2,-2));
 283 $s->store($str1, LBV->new(-1,-1));
 284 $s->store($str1, LBV->new( 0, 0));
 285 $s->store($str1, LBV->new( 1, 1));
 286 $s->store($str1, LBV->new( 2, 2));
 287 #        0         1         2
 288 #   5432101234567890123456789012345678
 289 #  2   Foobar baz
 290 #  1    Foobar baz
 291 #  0     Foobar baz
 292 #  1      Foobar baz
 293 #  2       Foobar baz
 294 # basic usage
 295 is($s->rectangle(LBV->new(2,-1),LBV->new(5,1)), 'bar b', 'rectangle() returns correct data');
 296 is($s->rectangle(LBV->new(2,-1),LBV->new(9,3)), "bar baz  \nobar baz \noobar baz",
 297    'rectangle() returns correct data even with newlines');
 298 is($s->rectangle(LBV->new(19,1),LBV->new(5,1)), '     ', 'rectangle() returns correct data even with spaces');
 299 # empty row / column
 300 is($s->rectangle(LBV->new(0,0),LBV->new(5,0)), '', 'rectangle() with no height returns empty string');
 301 is($s->rectangle(LBV->new(0,0),LBV->new(0,5)), '', 'rectangle() with no width returns empty string');
 302
 303
 304 #-- misc methods
 305
 306 # labels_lookup()
 307 $s = Language::Befunge::Storage::Generic::Vec->new(2, Wrapping => $wrap);
 308 # four directions.
 309 $s->clear;
 310 $s->store( <<'EOF', LBV->new(-2, -1 ));
 311       3
 312       ;
 313       z
 314       a
 315       b
 316       :
 317 2;rab:;:foo;1
 318       :
 319       b
 320       l
 321       a
 322       h
 323       ;
 324       4
 325 EOF
 326 $href = $s->labels_lookup;
 327 isa_ok($href, 'HASH');
 328 is(scalar(keys(%$href)), 4,    'labels_lookup() finds everything');
 329 is($href->{foo}[0],  '(10,5)', 'labels_lookup() finds left-right');
 330 is($href->{bar}[0],  '(-2,5)', 'labels_lookup() finds right-left');
 331 is($href->{bar}[1],  '(-1,0)', 'labels_lookup() deals with right-left');
 332 is($href->{baz}[0],  '(4,-1)', 'labels_lookup() finds bottom-top');
 333 is($href->{baz}[1],  '(0,-1)', 'labels_lookup() deals with bottom-top');
 334 is($href->{blah}[0], '(4,12)', 'labels_lookup() finds top-bottom');
 335 is($href->{blah}[1], '(0,1)',  'labels_lookup() deals with top-bottom');
 336
 337 # wrapping...
 338 $s->clear;
 339 $s->store( <<'EOF', LBV->new(-2, -1 ));
 340 ;1      z  ;   ;:foo
 341 rab:;   a  4      2;
 342         b
 343         :  ;
 344         ;  :
 345            b
 346            l
 347         3  a
 348         ;  h
 349 EOF
 350 $href = $s->labels_lookup;
 351 is(scalar(keys(%$href)), 4,     'labels_lookup() finds everything, even wrapping');
 352 is($href->{foo}[0],  '(-1,-1)', 'labels_lookup() finds left-right');
 353 is($href->{foo}[1],  '(1,0)',   'labels_lookup() deals with left-right');
 354 is($href->{bar}[0],  '(16,0)',  'labels_lookup() finds right-left');
 355 is($href->{bar}[1],  '(-1,0)',  'labels_lookup() deals with right-left');
 356 is($href->{baz}[0],  '(6,6)',   'labels_lookup() finds bottom-top');
 357 is($href->{baz}[1],  '(0,-1)',  'labels_lookup() deals with bottom-top');
 358 is($href->{blah}[0], '(9,0)',   'labels_lookup() finds top-bottom');
 359 is($href->{blah}[1], '(0,1)',   'labels_lookup() deals with top-bottom');
 360
 361 # garbage...
 362 $s->clear;
 363 $s->store( <<'EOF', LBV->new(-2, -1 ));
 364    ;:foo is foo;1
 365      ;not a label;
 366 EOF
 367 $href = $s->labels_lookup;
 368 is(scalar(keys(%$href)), 1,    'labels_lookup() does not get fooled by look-alike labels');
 369 is($href->{foo}[0], '(14,-1)', 'labels_lookup() discards comments');
 370 is($href->{foo}[1], '(1,0)',   'labels_lookup() discards comments');
 371
 372 # double define...
 373 $s->clear;
 374 $s->store( <<'EOF', LBV->new(-2, -1 ));
 375    ;:foo is foo;1
 376    2;another oof:;
 377 EOF
 378 throws_ok(sub { $s->labels_lookup },
 379     qr/^Help! I found two labels 'foo' in the funge space/,
 380     'labels_lookup() chokes on double-defined labels');
 381
 382 # _copy
 383 my $n = $s->_copy();
 384 is($$s{torus}, $$n{torus}, "torids are equal (at first)");
 385 $s->expand(LBV->new(0, 1));
 386 $n->expand(LBV->new(0,-2));
 387 isnt($$s{torus}, $$n{torus}, "torids are now separate and distinct");
 388 is($$s{min}, "(-2,-1)", "s has old min");
 389 is($$n{min}, "(-2,-2)", "n has new min");
 390 is($$s{max}, "(15,1)" , "s has new max");
 391 is($$n{max}, "(15,0)" , "n has old max");