t/1-classes/ip.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::IP tests
  13 #
  14
  15 use strict;
  16 use warnings;
  17
  18 use Test::More tests => 132;
  19 use Language::Befunge::IP;
  20
  21 my ($ip, $clone);
  22
  23
  24 #-- constructor
  25
  26 # new()
  27 $ip = Language::Befunge::IP->new(3);
  28 isa_ok($ip,          "Language::Befunge::IP");
  29 is($ip->get_dims, 3, "can specify the number of dims");
  30 is($ip->get_id,   0, "unique ids begin with zero");
  31 $ip = Language::Befunge::IP->new;
  32 is($ip->get_dims, 2, "dims default to 2");
  33 is($ip->get_id,   1, "each IP gets a unique id");
  34
  35
  36 #-- accessors
  37
  38 $ip->get_position->set_component(0,36);
  39 is( $ip->get_position->get_component(0), 36 );
  40 $ip->get_position->set_component(1,27);
  41 is( $ip->get_position->get_component(1), 27 );
  42 $ip->set_position(Language::Befunge::Vector->new(4, 6));
  43 is( $ip->get_position->get_component(0), 4 );
  44 is( $ip->get_position->get_component(1), 6 );
  45 $ip->get_delta->set_component(0,15);
  46 is( $ip->get_delta->get_component(0), 15 );
  47 $ip->get_delta->set_component(1,-4);
  48 is( $ip->get_delta->get_component(1), -4 );
  49 $ip->get_storage->set_component(0, -5 );
  50 is( $ip->get_storage->get_component(0), -5 );
  51 $ip->get_storage->set_component(0, 16 );
  52 is( $ip->get_storage->get_component(0), 16 );
  53 $ip->set_string_mode( 1 );
  54 is( $ip->get_string_mode, 1 );
  55 $ip->set_end( 1 );
  56 is( $ip->get_end, 1 );
  57 $ip->set_data({}); # meaningless, only to test accessors
  58 $ip->set_libs([]); # meaningless, only to test accessors
  59 $ip->set_ss([]);   # meaningless, only to test accessors
  60
  61
  62 #-- stack operations
  63
  64 is( $ip->spop, 0, "empty stack returns a 0" );
  65 is( $ip->spop_gnirts, "", "empty stack returns empty gnirts" );
  66 is( $ip->svalue(5), 0); # empty stack should return a 0.
  67 $ip->spush( 45 );
  68 is( $ip->spop, 45);
  69 $ip->spush( 65, 32, 78, 14, 0, 103, 110, 105, 114, 116, 83 );
  70 is( $ip->svalue(2),  116 );
  71 is( $ip->svalue(-2), 116 );
  72 is( $ip->svalue(1),  83 );
  73 is( $ip->svalue(-1), 83 );
  74 is( $ip->scount, 11 );
  75 is( $ip->spop_gnirts, "String" );
  76 is( $ip->scount, 4 );
  77 $ip->spush_vec(Language::Befunge::Vector->new(4, 5));
  78 is( $ip->scount, 6);
  79 is( $ip->spop, 5 );
  80 is( $ip->spop, 4 );
  81 $ip->spush(18, 74);
  82 my $v = $ip->spop_vec;
  83 is( ref($v), 'Language::Befunge::Vector' );
  84 my ($x, $y) = $v->get_all_components;
  85 is( $x, 18 );
  86 is( $y, 74 );
  87 ($x, $y) = $ip->spop_mult(2);
  88 is( $x, 78 );
  89 is( $y, 14 );
  90 $ip->spush_args( "foo", 7, "bar" );
  91 is( $ip->scount, 11 );
  92 is( $ip->spop, 98 );
  93 is( $ip->spop, 97 );
  94 is( $ip->spop, 114 );
  95 is( $ip->spop, 0 );
  96 is( $ip->spop, 7 );
  97 is( $ip->spop_gnirts, "foo" );
  98 $ip->sclear;
  99 is( $ip->scount, 0 );
 100
 101
 102 #-- stack stack
 103
 104 # The following table gives the line number where the
 105 # corresponding test is done.
 106 #
 107 # create = $ip->ss_create
 108 # remove = $ip->ss_remove
 109 # transfer = $ip->ss_transfer
 110 #
 111 # enough means there's enough values in the start stack to perform the
 112 # action. not enough means there's not enough values in the start
 113 # stack to perform the action (filled with zeroes).
 114 #
 115 #                   enough   not enough
 116 # create   (<0)      106         X
 117 # create   (=0)      136         X
 118 # create   (>0)       96        141
 119 # remove   (<0)      121         X
 120 # remove   (=0)      156         X
 121 # remove   (>0)      164        127
 122 # transfer (<0)      161        110
 123 # transfer (=0)      153         X
 124 # transfer (>0)      102        146
 125 $ip->sclear;
 126 $ip->spush( 11, 12, 13, 14, 15, 16, 17, 18, 19 );
 127 is( $ip->scount, 9 );             # toss = (11,12,13,14,15,16,17,18,19)
 128 is( $ip->ss_count, 0 );
 129 $ip->ss_create( 2 );              # create new toss, filled with values (enough).
 130 is( $ip->scount, 2 );             # toss = (18,19)
 131 is( $ip->soss_count, 7 );         # soss = (11,12,13,14,15,16,17)
 132 is( $ip->ss_count, 1 );
 133 is( $ip->spop, 19 );              # toss = (18)
 134 is( $ip->soss_pop, 17 );          # soss = (11,12,13,14,15,16)
 135 $ip->ss_transfer( 2 );            # move elems from soss to toss (enough).
 136 is( $ip->scount, 3 );             # toss = (18,16,15)
 137 is( $ip->soss_count, 4 );         # soss = (11,12,13,14)
 138 is( $ip->spop, 15 );              # toss = (18,16)
 139 $ip->ss_create( -3 );             # create new toss, fill soss with zeroes.
 140 is( $ip->scount, 0 );             # toss = ()
 141 is( $ip->soss_count, 5 );         # soss = (18,16,0,0,0)
 142 is( $ip->ss_count, 2 );
 143 is( join("",$ip->ss_sizes), "054" );
 144 is( $ip->spop, 0 );               # toss = ()
 145 $ip->spush(0, 0);
 146 $ip->ss_transfer( -10 );          # move elems from toss to soss (not enough).
 147 is( $ip->scount, 0 );             # toss = ()
 148 is( $ip->soss_count, 15 );        # soss = (18,17,0,0,0,0,0,0,0,0,0,0,0,0)
 149 $ip->soss_push( 15 );             # soss = (18,17,0,0,0,0,0,0,0,0,0,0,0,0,15)
 150 is( $ip->soss_pop, 15 );          # soss = (18,17,0,0,0,0,0,0,0,0,0,0)
 151 $ip->soss_clear;                  # soss = ()
 152 is( $ip->soss_pop, 0, "soss_pop returns a 0 on empty soss" );
 153 is( $ip->soss_count, 0 );
 154 $ip->spush( 16, 17 );             # toss = (16, 17)
 155 $ip->soss_push( 13, 14, 15, 16 ); # soss = (13,14,15,16)
 156 $ip->ss_remove( -1 );             # destroy toss, remove elems.
 157 is( $ip->ss_count, 1 );
 158 is( $ip->scount, 3 );             # toss = (13,14,15)
 159 is( $ip->spop, 15 );              # toss = (13,14)
 160 is( $ip->spop, 14 );              # toss = (13)
 161 $ip->spush( 14, 15 );
 162 $ip->ss_remove( 5 );              # destroy toss, push values (not enough).
 163 is( $ip->ss_count, 0 );
 164 is( $ip->scount, 9 );             # toss = (11,12,13,14,0,0,13,14,15)
 165 is( $ip->spop, 15 );              # toss = (11,12,13,14,0,0,13,14)
 166 is( $ip->spop, 14 );              # toss = (11,12,13,14,0,0,13)
 167 is( $ip->spop, 13 );              # toss = (11,12,13,14,0,0)
 168 is( $ip->spop, 0 );               # toss = (11,12,13,14,0)
 169 is( $ip->spop, 0 );               # toss = (11,12,13,14)
 170 is( $ip->spop, 14 );              # toss = (11,12,13)
 171 $ip->ss_create( 0 );              # create new toss, no values filled.
 172 is( $ip->scount, 0 );             # toss = ()
 173 is( $ip->soss_count, 3 );         # soss = (11,12,13)
 174 is( $ip->ss_count, 1 );
 175 $ip->spush( 78 );                 # toss = (78)
 176 $ip->ss_create( 3 );              # create new toss, filled with values (not enough).
 177 is( $ip->scount, 3 );             # toss = (0,0,78)
 178 is( $ip->soss_count, 0 );         # soss = ()
 179 is( $ip->ss_count, 2 );
 180 $ip->soss_push( 45 );             # soss = (45)
 181 $ip->ss_transfer( 3 );            # move elems from soss to toss (not enough).
 182 is( $ip->scount, 6 );             # toss = (0,0,78,45,0,0)
 183 is( $ip->soss_count, 0 );         # soss = ()
 184 is( $ip->spop, 0 );               # toss = (0,0,78,45,0)
 185 is( $ip->spop, 0 );               # toss = (0,0,78,45)
 186 is( $ip->spop, 45 );              # toss = (0,0,78)
 187 $ip->soss_push( 12 );             # soss = (12)
 188 $ip->ss_transfer( 0 );            # move 0 elems.
 189 is( $ip->scount, 3 );
 190 is( $ip->soss_count, 1 );
 191 $ip->ss_remove( 0 );              # destroy toss, no values moved.
 192 is( $ip->scount, 1 );             # toss = (12)
 193 is( $ip->soss_count, 3 );         # soss = (11,12,13)
 194 is( $ip->ss_count, 1 );
 195 $ip->spush( 18 );                 # toss = (12,18)
 196 $ip->ss_transfer( -1 );           # move elems from toss to soss (enough).
 197 is( $ip->scount, 1 );             # toss = (12)
 198 is( $ip->soss_count, 4 );         # soss = (11,12,13,18)
 199 $ip->ss_remove( 1 );              # destroy toss, values filled (enough).
 200 is( $ip->scount, 5 );             # toss = (11,12,13,18,12)
 201 is( $ip->ss_count, 0 );
 202 is( $ip->spop, 12 );              # toss = (11,12,13,18)
 203 is( $ip->spop, 18 );              # toss = (11,12,13)
 204 is( $ip->spop, 13 );              # toss = (11,12)
 205 is( $ip->spop, 12 );              # toss = (11)
 206 $ip->ss_create( 0 );              # toss = () soss = (11)
 207 $ip->soss_push_vec( Language::Befunge::Vector->new(34, 48) );
 208 is( $ip->soss_pop, 48 );
 209 is( $ip->soss_pop, 34 );
 210 $ip->soss_push_vec( Language::Befunge::Vector->new(49, 53) );
 211 $v = $ip->soss_pop_vec;
 212 is( ref($v), 'Language::Befunge::Vector' );
 213 is( $v, "(49,53)" );
 214 $ip->ss_remove( -3 );             # destroy toss, remove elems
 215 is( $ip->scount, 0, "ss_remove can clear completely the soss-to-be-toss" );
 216
 217
 218 #-- cardinal directions
 219
 220 $ip->dir_go_east;  is($ip->get_delta->as_string,  '(1,0)', "go_east changes delta");
 221 $ip->dir_go_west;  is($ip->get_delta->as_string, '(-1,0)', "go_west changes delta");
 222 $ip->dir_go_north; is($ip->get_delta->as_string, '(0,-1)', "go_north changes delta");
 223 $ip->dir_go_south; is($ip->get_delta->as_string,  '(0,1)', "go_south changes delta");
 224
 225
 226 #-- random direction
 227
 228 $ip->set_delta( Language::Befunge::Vector->new(3,2) );
 229 my %wanted = ( map {$_=>undef} '(0,1)', '(0,-1)', '(1,0)', '(-1,0)' );
 230 my $iter=0;
 231 while ( keys %wanted ) {
 232     $iter++;
 233     $ip->dir_go_away;
 234     delete $wanted{ $ip->get_delta->as_string };
 235 }
 236 is(keys %wanted, 0, "go_away went north/east/south/west (in $iter iterations)");
 237
 238
 239 #-- turn left
 240
 241 # cardinal directions
 242 $ip->dir_go_east;
 243 $ip->dir_turn_left; is($ip->get_delta->as_string, '(0,-1)', "turn left when going east works");
 244 $ip->dir_turn_left; is($ip->get_delta->as_string, '(-1,0)', "turn left when going north works");
 245 $ip->dir_turn_left; is($ip->get_delta->as_string,  '(0,1)', "turn left when going west works");
 246 $ip->dir_turn_left; is($ip->get_delta->as_string,  '(1,0)', "turn left when going south works");
 247
 248 # non-cardinal delta
 249 $ip->set_delta( Language::Befunge::Vector->new(3,2) );
 250 $ip->dir_turn_left; is($ip->get_delta->as_string,  '(2,-3)', "turn left on non-cardinal delta works/1");
 251 $ip->dir_turn_left; is($ip->get_delta->as_string, '(-3,-2)', "turn left on non-cardinal delta works/2");
 252 $ip->dir_turn_left; is($ip->get_delta->as_string,  '(-2,3)', "turn left on non-cardinal delta works/3");
 253 $ip->dir_turn_left; is($ip->get_delta->as_string,   '(3,2)', "turn left on non-cardinal delta works/4");
 254
 255
 256 #-- turn right
 257
 258 # cardinal directions
 259 $ip->dir_go_east;
 260 $ip->dir_turn_right; is($ip->get_delta->as_string,  '(0,1)', "turn right when going east works");
 261 $ip->dir_turn_right; is($ip->get_delta->as_string, '(-1,0)', "turn right when going south works");
 262 $ip->dir_turn_right; is($ip->get_delta->as_string, '(0,-1)', "turn right when going west works");
 263 $ip->dir_turn_right; is($ip->get_delta->as_string,  '(1,0)', "turn right when going north works");
 264
 265 # non-cardinal delta
 266 $ip->set_delta( Language::Befunge::Vector->new(3,2) );
 267 $ip->dir_turn_right; is($ip->get_delta->as_string,  '(-2,3)', "turn right on non-cardinal delta works/1");
 268 $ip->dir_turn_right; is($ip->get_delta->as_string, '(-3,-2)', "turn right on non-cardinal delta works/2");
 269 $ip->dir_turn_right; is($ip->get_delta->as_string,  '(2,-3)', "turn right on non-cardinal delta works/3");
 270 $ip->dir_turn_right; is($ip->get_delta->as_string,   '(3,2)', "turn right on non-cardinal delta works/4");
 271
 272
 273 #-- reverse
 274
 275 # cardinal directions
 276 $ip->dir_go_east;
 277 $ip->dir_reverse; is($ip->get_delta->as_string, '(-1,0)', "reverse from east works");
 278 $ip->dir_reverse; is($ip->get_delta->as_string,  '(1,0)', "reverse from west works");
 279
 280 # non-cardinal delta
 281 $ip->set_delta( Language::Befunge::Vector->new(2, -3) );
 282 $ip->dir_reverse; is($ip->get_delta->as_string, '(-2,3)', "reverse on non-cardinal works/1");
 283 $ip->dir_reverse; is($ip->get_delta->as_string, '(2,-3)', "reverse on non-cardinal works/2");
 284
 285
 286 #-- cloning
 287 $ip = Language::Befunge::IP->new;
 288 $ip->spush( 1, 5, 6 );
 289 $clone = $ip->clone;
 290 isnt($ip->get_id, $clone->get_id, "clone change the IP unique id");
 291 is($ip->spop,                  6, "clone did not changed the original IP");
 292 is($clone->spop,               6, "clone also cloned the stack");
 293
 294
 295 #-- extension data
 296 $ip->extdata( "HELO", "foobar" );
 297 is($ip->extdata("HELO"), 'foobar', "extdata() restore previously saved data");
 298
 299
 300
 301