Parent Directory
| 
Revision Log
Revision 2 - (view) (download) (as text)
| 1 : | sam | 2 | #!/usr/bin/perl -w |
| 2 : | #New highly object-oriented list construct | ||
| 3 : | #This List.pm is the super class for all types of lists | ||
| 4 : | #As of 6/5/2000 the three list sub-classes are Match, Select, Multiple | ||
| 5 : | #RDV | ||
| 6 : | |||
| 7 : | =head1 NAME | ||
| 8 : | |||
| 9 : | List.pm -- super-class for all list structures | ||
| 10 : | |||
| 11 : | =head1 SYNOPSIS | ||
| 12 : | |||
| 13 : | =pod | ||
| 14 : | |||
| 15 : | List.pm is not intended to be used as a stand alone object. | ||
| 16 : | |||
| 17 : | It is a super-class designed to be inherited by sub-classes that, | ||
| 18 : | through small changes, can be used for a variety of different | ||
| 19 : | questions that involve some sort of list of questions and/or answers. | ||
| 20 : | |||
| 21 : | List.pm has been used to construct Match.pm, Select.pm, and Multiple.pm. | ||
| 22 : | |||
| 23 : | These three classes are objects that can be used to create the | ||
| 24 : | following question types: | ||
| 25 : | |||
| 26 : | B<Matching list:> | ||
| 27 : | Given a list of questions and answers, match the correct answers to the | ||
| 28 : | questions. Some answers may be used more than once and some may not be used at | ||
| 29 : | all. The order of the answers is usually random but some answers can be | ||
| 30 : | appended to the end in a set order (i.e. 'None of the above'). Answers are | ||
| 31 : | given corresponding letters as shortcuts to typing in the full answer. (i.e. | ||
| 32 : | the answer to #1 is A). | ||
| 33 : | |||
| 34 : | B<Select list:> | ||
| 35 : | Given a list of questions and (usually) implied answers, give the correct | ||
| 36 : | answer to each question. This is intended mainly for true/false questions or | ||
| 37 : | other types of questions where the answers are short and can therefore be typed | ||
| 38 : | in by the user easily. If a select list is desired but the answers are too long | ||
| 39 : | to really type in, a popup-list of the answers can be used. | ||
| 40 : | |||
| 41 : | B<Multiple choice:> | ||
| 42 : | Given a single question and a list of answers, select the single correct answer. | ||
| 43 : | This structure creates a standard multiple choice question as would be seen on a | ||
| 44 : | standardize test. Extra answers are entered along with the question in a simple | ||
| 45 : | format and (as with Match.pm), if necessary, can be appended in order at the end | ||
| 46 : | (i.e. 'None of the above') | ||
| 47 : | |||
| 48 : | =for html | ||
| 49 : | <P>See <a href="Match">Match.pm</a>, <a href="Select">Select.pm</a>, <a href="Multiple">Multiple.pm</a>, and <a href="PGchoicemacros">PGchoicemacros.pl</a> | ||
| 50 : | |||
| 51 : | |||
| 52 : | =head1 DESCRIPTION | ||
| 53 : | |||
| 54 : | =head2 Variables and methods available to sub-classes | ||
| 55 : | |||
| 56 : | =head3 Variables | ||
| 57 : | |||
| 58 : | questions # array of questions as entered using qa() | ||
| 59 : | answers # array of answers as entered using qa() | ||
| 60 : | extras # array of extras as entered using extra() | ||
| 61 : | |||
| 62 : | selected_q # randomly selected subset of "questions" | ||
| 63 : | selected_a # the answers for the selected questions | ||
| 64 : | selected_e # randomly selected subset of "extras" | ||
| 65 : | |||
| 66 : | ans_rule_len # determines the length of the answer blanks | ||
| 67 : | # default is 4 | ||
| 68 : | |||
| 69 : | slice # index used to select specific questions | ||
| 70 : | shuffle # permutation array which can be applied to slice | ||
| 71 : | # to shuffle the answers | ||
| 72 : | |||
| 73 : | inverted_shuffle # the inverse permutation array | ||
| 74 : | |||
| 75 : | rf_print_q # reference to any subroutine which should | ||
| 76 : | # take ($self, @questions) as parameters and | ||
| 77 : | # output the questions in a formatted string. | ||
| 78 : | # If you want to change the way questions are | ||
| 79 : | # printed, write your own print method and set | ||
| 80 : | # this equal to a reference to to that method | ||
| 81 : | # (i.e. $sl->rf_print_q = ~~&printing_routine_q) | ||
| 82 : | |||
| 83 : | rf_print_a # reference to any subroutine which should | ||
| 84 : | # take ($self, @answers) as parameters and | ||
| 85 : | # output the answers in a formatted string. | ||
| 86 : | # If you want to change the way answers are | ||
| 87 : | # printed, write your own print method and set | ||
| 88 : | # this equal to a reference to to that method | ||
| 89 : | # (i.e. $sl->rf_print_a = ~~&printing_routine_a) | ||
| 90 : | |||
| 91 : | =head3 Methods | ||
| 92 : | |||
| 93 : | qa( array ) # accepts an array of strings which can be used | ||
| 94 : | # for questions and answers | ||
| 95 : | |||
| 96 : | extra( array ) # accepts an array of strings which can be used | ||
| 97 : | # as extra answers | ||
| 98 : | |||
| 99 : | print_q # yields a formatted string of question to be | ||
| 100 : | # matched with answer blanks | ||
| 101 : | print_a # yields a formatted string of answers | ||
| 102 : | |||
| 103 : | choose([3, 4], 1) # chooses questions indexed 3 and 4 and one other | ||
| 104 : | # randomly | ||
| 105 : | choose_extra([3, 4], 1) # choooses extra answers indexed 3 and 4 and one | ||
| 106 : | # other | ||
| 107 : | makeLast( array ) # accepts an array of strings (like qa) which will | ||
| 108 : | # be forced to the end of the list of answers. | ||
| 109 : | |||
| 110 : | ra_correct_ans # outputs a reference to the array of correct answers | ||
| 111 : | correct_ans # outputs a concatenated string of correct answers (only for Multiple) | ||
| 112 : | |||
| 113 : | =head2 Usage | ||
| 114 : | |||
| 115 : | None -- see SYNOPSIS above | ||
| 116 : | |||
| 117 : | |||
| 118 : | =cut | ||
| 119 : | |||
| 120 : | BEGIN { | ||
| 121 : | be_strict(); | ||
| 122 : | } | ||
| 123 : | #use strict; | ||
| 124 : | |||
| 125 : | package List; | ||
| 126 : | |||
| 127 : | |||
| 128 : | |||
| 129 : | @List::ISA = qw( Exporter ); | ||
| 130 : | |||
| 131 : | my %fields = ( | ||
| 132 : | questions => undef, | ||
| 133 : | answers => undef, | ||
| 134 : | extras => undef, | ||
| 135 : | selected_q => undef, | ||
| 136 : | selected_a => undef, | ||
| 137 : | selected_e => undef, | ||
| 138 : | ans_rule_len => undef, | ||
| 139 : | ra_pop_up_list => undef, | ||
| 140 : | rf_print_q => undef, | ||
| 141 : | rf_print_a => undef, | ||
| 142 : | slice => undef, | ||
| 143 : | shuffle => undef, | ||
| 144 : | inverted_shuffle => undef, | ||
| 145 : | rand_gen => undef, | ||
| 146 : | ); | ||
| 147 : | |||
| 148 : | #used to initialize variables and create an instance of the class | ||
| 149 : | sub new { | ||
| 150 : | my $class = shift; | ||
| 151 : | my $seed = shift; | ||
| 152 : | |||
| 153 : | warn "List requires a random number: new List(random(1,2000,1)" unless defined $seed; | ||
| 154 : | |||
| 155 : | my $self = { _permitted => \%fields, | ||
| 156 : | |||
| 157 : | questions => [], | ||
| 158 : | answers => [], | ||
| 159 : | extras => [], | ||
| 160 : | selected_q => [], | ||
| 161 : | selected_a => [], | ||
| 162 : | selected_e => [], | ||
| 163 : | ans_rule_len => 4, | ||
| 164 : | ra_pop_up_list => [no_answer =>' ?', T => 'True', F => 'False'], | ||
| 165 : | rf_print_q => 0, | ||
| 166 : | rf_print_a => 0, | ||
| 167 : | slice => [], | ||
| 168 : | shuffle => [], | ||
| 169 : | inverted_shuffle => [], | ||
| 170 : | rand_gen => new PGrandom, | ||
| 171 : | }; | ||
| 172 : | |||
| 173 : | bless $self, $class; | ||
| 174 : | |||
| 175 : | $self->{rand_gen}->srand($seed); | ||
| 176 : | |||
| 177 : | $self->{rf_print_q} = shift; | ||
| 178 : | $self->{rf_print_a} = shift; | ||
| 179 : | |||
| 180 : | return $self; | ||
| 181 : | } | ||
| 182 : | |||
| 183 : | #AUTOLOAD allows variables to be set and accessed like methods returning the value of the variable | ||
| 184 : | sub AUTOLOAD { | ||
| 185 : | my $self = shift; | ||
| 186 : | my $type = ref($self) or die "$self is not an object"; | ||
| 187 : | |||
| 188 : | # $AUTOLOAD is sent in by Perl and is the full name of the object (i.e. main::blah::blah_more) | ||
| 189 : | my $name = $List::AUTOLOAD; | ||
| 190 : | $name =~ s/.*://; #strips fully-qualified portion | ||
| 191 : | |||
| 192 : | unless ( exists $self->{'_permitted'}->{$name} ) { die "Can't find '$name' field in object of class '$type'"; } | ||
| 193 : | |||
| 194 : | if (@_) { | ||
| 195 : | return $self->{$name} = shift; #set the variable to the first parameter | ||
| 196 : | } else { | ||
| 197 : | return $self->($name); #if no parameters just return the value | ||
| 198 : | } | ||
| 199 : | } | ||
| 200 : | |||
| 201 : | sub DESTROY { | ||
| 202 : | # doing nothing about destruction, hope that isn't dangerous | ||
| 203 : | } | ||
| 204 : | |||
| 205 : | |||
| 206 : | # *** Utility methods *** | ||
| 207 : | |||
| 208 : | |||
| 209 : | #choose k random numbers out of n | ||
| 210 : | sub NchooseK { | ||
| 211 : | my $self = shift; | ||
| 212 : | my ($n, $k) = @_; | ||
| 213 : | |||
| 214 : | die "method NchooseK: n = $n cannot be less than k=$k\n | ||
| 215 : | You probably did a 'choose($k)' with only $n questions!" if $k > $n; | ||
| 216 : | |||
| 217 : | my @array = 0..($n-1); | ||
| 218 : | my @out = (); | ||
| 219 : | |||
| 220 : | while (@out < $k) { | ||
| 221 : | push(@out, splice(@array, $self->{rand_gen}->random(0, $#array, 1), 1) ); | ||
| 222 : | } | ||
| 223 : | |||
| 224 : | return @out; | ||
| 225 : | } | ||
| 226 : | |||
| 227 : | #return an array of random numbers | ||
| 228 : | sub shuffle { | ||
| 229 : | my $self = shift; | ||
| 230 : | my $i = @_; | ||
| 231 : | my @out = $self->NchooseK($i, $i); | ||
| 232 : | |||
| 233 : | return @out; | ||
| 234 : | } | ||
| 235 : | |||
| 236 : | |||
| 237 : | # *** Utility subroutines *** | ||
| 238 : | |||
| 239 : | |||
| 240 : | #swap subscripts with their respective values | ||
| 241 : | sub invert { | ||
| 242 : | my @array = @_; | ||
| 243 : | my @out = (); | ||
| 244 : | |||
| 245 : | for (my $i=0; $i<@array; $i++) { | ||
| 246 : | $out[$array[$i]] = $i; | ||
| 247 : | } | ||
| 248 : | |||
| 249 : | return @out; | ||
| 250 : | } | ||
| 251 : | |||
| 252 : | #slice of the alphabet | ||
| 253 : | sub ALPHABET { | ||
| 254 : | return ('A'..'ZZ')[@_]; | ||
| 255 : | } | ||
| 256 : | |||
| 257 : | #given a universe of subscripts and a subset of the universe, | ||
| 258 : | #return the complement of that set in the universe | ||
| 259 : | sub complement { | ||
| 260 : | my $ra_univ = shift; | ||
| 261 : | my $ra_set = shift; | ||
| 262 : | my @univ = @$ra_univ; | ||
| 263 : | my @set = @$ra_set; | ||
| 264 : | |||
| 265 : | my %set = (); | ||
| 266 : | |||
| 267 : | foreach my $i (@set) { | ||
| 268 : | $set{$i} = 1; | ||
| 269 : | } | ||
| 270 : | |||
| 271 : | my @out = (); | ||
| 272 : | |||
| 273 : | foreach my $i (@univ) { | ||
| 274 : | push(@out, $i) unless exists( $set{$i} ); | ||
| 275 : | } | ||
| 276 : | |||
| 277 : | return @out; | ||
| 278 : | } | ||
| 279 : | |||
| 280 : | |||
| 281 : | |||
| 282 : | # *** Input and Output subroutines *** | ||
| 283 : | #From here down are the ones that should be overloaded by sub-classes | ||
| 284 : | |||
| 285 : | #Input answers | ||
| 286 : | #defaults to inputting 'question', 'answer', 'question', etc (should be overloaded for other types of questions) | ||
| 287 : | sub qa { | ||
| 288 : | my $self = shift; | ||
| 289 : | my @questANDanswer = @_; | ||
| 290 : | |||
| 291 : | while (@questANDanswer) { | ||
| 292 : | push (@{ $self->{questions} }, shift(@questANDanswer) ); | ||
| 293 : | push (@{ $self->{answers} }, shift(@questANDanswer) ); | ||
| 294 : | } | ||
| 295 : | } | ||
| 296 : | |||
| 297 : | #Input extra answers | ||
| 298 : | sub extra { | ||
| 299 : | my $self = shift; | ||
| 300 : | push(@{ $self->{extras} }, @_); #pushing allows multiple calls without overwriting old "extras" | ||
| 301 : | } | ||
| 302 : | |||
| 303 : | |||
| 304 : | #Output questions | ||
| 305 : | #Doesn't do actual output, refers to method given in call to 'new' (rf_print_q) | ||
| 306 : | sub print_q { | ||
| 307 : | my $self = shift; | ||
| 308 : | |||
| 309 : | &{ $self->{rf_print_q} }( $self, @{ $self->{selected_q} } ); | ||
| 310 : | } | ||
| 311 : | |||
| 312 : | #Output answers | ||
| 313 : | #Doesn't do actual output, refers to method given in call to 'new' (rf_print_a) | ||
| 314 : | sub print_a { | ||
| 315 : | my $self = shift; | ||
| 316 : | |||
| 317 : | &{ $self->{rf_print_a} }( $self, @{ $self->{selected_a} } ); | ||
| 318 : | } | ||
| 319 : | |||
| 320 : | #return array of answers to be checked against the students answers | ||
| 321 : | #defaults to returning the actual selected answers (should be overloaded for other types of answers) | ||
| 322 : | sub ra_correct_ans { | ||
| 323 : | my $self = shift; | ||
| 324 : | return $self->{selected_a}; | ||
| 325 : | } | ||
| 326 : | |||
| 327 : | #Match and Select return references to arrays while Multiple justs returns a string | ||
| 328 : | #so Match and Select use ra_correct_ans while Multiple uses correct_ans | ||
| 329 : | sub correct_ans { | ||
| 330 : | warn "Match and/or Select do not use correct_ans.\nYou should use ra_correct_ans instead."; | ||
| 331 : | } | ||
| 332 : | |||
| 333 : | # *** Question and Answer Manipulation Subroutines *** | ||
| 334 : | |||
| 335 : | |||
| 336 : | #calls methods that deal with list specific methods of picking random questions and answers | ||
| 337 : | #mainly exists for backward compatibility and to hide some of the activity from the naive user | ||
| 338 : | sub choose { | ||
| 339 : | my $self = shift; | ||
| 340 : | my @input = @_; | ||
| 341 : | |||
| 342 : | $self->getRandoms(scalar(@{$self->{questions}}), @input); #pick random numbers | ||
| 343 : | $self->selectQA(); #select questions and answers | ||
| 344 : | $self->dumpExtra(); #dump extra answers into "extras" | ||
| 345 : | $self->condense(); #eliminate duplicate answers" | ||
| 346 : | } | ||
| 347 : | |||
| 348 : | #randomly inserts the selected extra answers into selected_a and | ||
| 349 : | #updates inverted_shuffle accordingly | ||
| 350 : | sub choose_extra { | ||
| 351 : | my $self = shift; | ||
| 352 : | my @input = @_; | ||
| 353 : | |||
| 354 : | $self->getRandoms(scalar(@{ $self->{extras} }), @input); | ||
| 355 : | $self->{selected_e} = [ @{ $self->{extras} }[ @{ $self->{slice} }[ @{ $self->{shuffle} } ] ] ]; | ||
| 356 : | my $length = 0; | ||
| 357 : | |||
| 358 : | my $random = 0; | ||
| 359 : | foreach my $extra_ans ( invert(@{ $self->{shuffle} }) ) { | ||
| 360 : | #warn "Selected Answers: @{ $self->{selected_a} }<BR> | ||
| 361 : | # Inverted Shuffle: @{ $self->{inverted_shuffle} }<BR> | ||
| 362 : | # Random: $random"; | ||
| 363 : | $random = $self->{rand_gen}->random(0, scalar(@{ $self->{selected_a} }), 1); | ||
| 364 : | for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { | ||
| 365 : | @{ $self->{inverted_shuffle} }[$pos]++ unless @{ $self->{inverted_shuffle} }[$pos] < $random; | ||
| 366 : | } | ||
| 367 : | my @temp = ( @{ $self->{selected_a} }[0..$random-1], @{ $self->{selected_e} }[$extra_ans], @{$self->{selected_a} }[$random..$#{ $self->{selected_a} } ] ); | ||
| 368 : | @{ $self->{selected_a} } = @temp; | ||
| 369 : | } | ||
| 370 : | } | ||
| 371 : | |||
| 372 : | #create random @slice and @shuffle to randomize questions and answers | ||
| 373 : | sub getRandoms { | ||
| 374 : | my $self = shift; | ||
| 375 : | my $N = shift; | ||
| 376 : | my @input = @_; | ||
| 377 : | my $K = 0; | ||
| 378 : | |||
| 379 : | my @fixed_choices = (); # questions forced by the user | ||
| 380 : | foreach my $i (@input) { #input is of the form ([3, 5, 6], 3) | ||
| 381 : | if (ref($i) eq 'ARRAY') { | ||
| 382 : | push(@fixed_choices, @{$i}); | ||
| 383 : | } else { | ||
| 384 : | $K += $i; | ||
| 385 : | } | ||
| 386 : | } | ||
| 387 : | |||
| 388 : | # my $N = @{ $self->{questions} }; | ||
| 389 : | my @remaining = complement( [0..$N-1], [@fixed_choices] ); | ||
| 390 : | |||
| 391 : | my @slice = @fixed_choices; | ||
| 392 : | push (@slice, @remaining[ $self->NchooseK(scalar(@remaining), $K) ] ); #slice of remaing choices | ||
| 393 : | @slice = @slice[ $self->NchooseK( scalar(@slice), scalar(@slice) ) ]; #randomize the slice (the questions) | ||
| 394 : | |||
| 395 : | #shuffle will be used to randomize the answers a second time (so they don't coincide with the questions) | ||
| 396 : | my @shuffle = $self->NchooseK( scalar(@slice), scalar(@slice) ); | ||
| 397 : | |||
| 398 : | $self->{slice} = \@slice; #keep track of the slice and shuffle | ||
| 399 : | $self->{shuffle} = \@shuffle; | ||
| 400 : | } | ||
| 401 : | |||
| 402 : | #select questions and answers according to slice and shuffle | ||
| 403 : | sub selectQA { | ||
| 404 : | my $self = shift; | ||
| 405 : | |||
| 406 : | $self->{selected_q} = [ @{ $self->{questions} }[ @{ $self->{slice} } ] ]; | ||
| 407 : | $self->{selected_a} = [ @{ $self->{answers} }[@{ $self->{slice} }[@{ $self->{shuffle} } ] ] ]; | ||
| 408 : | $self->{inverted_shuffle} = [ invert(@{ $self->{shuffle} }) ]; | ||
| 409 : | } | ||
| 410 : | |||
| 411 : | #dump unused answers into list of extra answers | ||
| 412 : | sub dumpExtra { | ||
| 413 : | my $self = shift; | ||
| 414 : | my @more_extras = complement([0..scalar(@{ $self->{answers} })-1], [@{ $self->{slice} }]); | ||
| 415 : | push( @{ $self->{extras} }, @{ $self->{answers} }[@more_extras] ); | ||
| 416 : | } | ||
| 417 : | |||
| 418 : | #Allows answers to be added to the end of the selected answers | ||
| 419 : | #This can be used to force answers like "None of the above" and/or "All of the above" to still occur at the | ||
| 420 : | #end of the list instead of being randomized like the rest of the answers | ||
| 421 : | sub makeLast { | ||
| 422 : | my $self = shift; | ||
| 423 : | my @input = @_; | ||
| 424 : | |||
| 425 : | push(@{ $self->{selected_a} }, @input); | ||
| 426 : | $self->condense(); #make sure that the user has not accidentally forced a duplicate answer | ||
| 427 : | #note: condense was changed to eliminate the first occurence of a duplicate | ||
| 428 : | #instead of the last occurence so that it could be used in this case and | ||
| 429 : | #would not negate the fact that one of the answers needs to be at the end | ||
| 430 : | } | ||
| 431 : | |||
| 432 : | #Eliminates duplicates answers and rearranges inverted_shuffle so that all questions with the same answer | ||
| 433 : | #point to one and only one copy of that answer | ||
| 434 : | sub old_condense { | ||
| 435 : | my $self = shift; | ||
| 436 : | for (my $outer = 0; $outer < @{ $self->{selected_a} }; $outer++) { | ||
| 437 : | for (my $inner = $outer+1; $inner < @{ $self->{selected_a} }; $inner++) { | ||
| 438 : | if (@{ $self->{selected_a} }[$outer] eq @{ $self->{selected_a} }[$inner]) { | ||
| 439 : | #then delete the duplicate answer at subscript $outer | ||
| 440 : | @{ $self->{selected_a} } = ( @{ $self->{selected_a} }[0..$outer-1], @{ $self->{selected_a} }[$outer+1..$#{ $self->{selected_a} }] ); | ||
| 441 : | |||
| 442 : | #the values of inverted_shuffle point to the position elements in selected_a | ||
| 443 : | #so in order to delete something from selected_a, each element with a position | ||
| 444 : | #greater than $outer must have its position be decremented by one | ||
| 445 : | $inner--; #$inner must be greater than outer so decrement $inner first | ||
| 446 : | for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { | ||
| 447 : | if ( @{ $self->{inverted_shuffle} }[$pos] == $outer ) { | ||
| 448 : | @{ $self->{inverted_shuffle} }[$pos] = $inner; | ||
| 449 : | } elsif ( @{ $self->{inverted_shuffle} }[$pos] > $outer ) { | ||
| 450 : | @{ $self->{inverted_shuffle} }[$pos]--; | ||
| 451 : | } | ||
| 452 : | } | ||
| 453 : | #we just changed a bunch of pointers so we need to go back over the same answers again | ||
| 454 : | #(so we decrement $inner (which we already did) and $outer to counter-act the for loop)) | ||
| 455 : | #this could probably be done slightly less hackish with while loops instead of for loops | ||
| 456 : | #$outer--; | ||
| 457 : | } | ||
| 458 : | } | ||
| 459 : | } | ||
| 460 : | } | ||
| 461 : | |||
| 462 : | #re-written RDV 10/4/2000 | ||
| 463 : | #Eliminates duplicate answers and rearranges inverted_shuffle so that all questions with the same answer | ||
| 464 : | #point to one and only one copy of that answer | ||
| 465 : | sub condense { | ||
| 466 : | my $self = shift; | ||
| 467 : | my ($outer, $inner) = (0, 0); | ||
| 468 : | my $repeat = 0; | ||
| 469 : | |||
| 470 : | while ($outer < @{ $self->{selected_a} }) { | ||
| 471 : | $inner = $outer + 1; | ||
| 472 : | $repeat = 0; #loop again if we find a match | ||
| 473 : | while ($inner < @{ $self->{selected_a}}) { | ||
| 474 : | $repeat = 0; #loop again if we find a match | ||
| 475 : | if (@{ $self->{selected_a} }[$outer] eq @{$self->{selected_a} }[$inner]) { | ||
| 476 : | |||
| 477 : | #then delete the duplicate answer at subscript $outer by combining everything before and after it | ||
| 478 : | @{ $self->{selected_a} } = ( @{ $self->{selected_a} }[0..$outer-1], @{ $self->{selected_a} }[$outer+1..$#{ $self->{selected_a} }] ); | ||
| 479 : | |||
| 480 : | #the values of inverted_shuffle to point the _subscript_ of elements in selected_a | ||
| 481 : | #so in order to delete something from selected_a, each element with a subscript | ||
| 482 : | #greater than $outer (where the deletion occurred) must have its position decremented by one | ||
| 483 : | #This also means we need to "slide" $inner down so that it points to the new position | ||
| 484 : | #of the duplicate answer | ||
| 485 : | $inner--; | ||
| 486 : | |||
| 487 : | for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { | ||
| 488 : | if ( @{ $self->{inverted_shuffle} }[$pos] == $outer) { | ||
| 489 : | @{ $self->{inverted_shuffle} }[$pos] = $inner; | ||
| 490 : | } elsif ( @{ $self->{inverted_shuffle} }[$pos] > $outer ) { | ||
| 491 : | @{ $self->{inverted_shuffle} }[$pos]--; | ||
| 492 : | } | ||
| 493 : | } | ||
| 494 : | |||
| 495 : | #because we just changed the element that $outer points to | ||
| 496 : | #we need to run throught the loop to make sure that the new value at $outer has | ||
| 497 : | #no duplicates as well | ||
| 498 : | #This means that we don't want to increment either counter (and we need to reset $inner) | ||
| 499 : | $repeat = 1; | ||
| 500 : | $inner = $outer + 1; | ||
| 501 : | } | ||
| 502 : | $inner++ unless $repeat; | ||
| 503 : | } | ||
| 504 : | $outer++ unless $repeat; | ||
| 505 : | } | ||
| 506 : | } | ||
| 507 : | |||
| 508 : | |||
| 509 : | # This condense didn't repeat the inner loop after deleting the element at $outer (so that $outer now pointed to a new value) | ||
| 510 : | # so if the new value at $outer also had a duplicate then it was just skipped. | ||
| 511 : | # This shouldn't work but i'll leave it in for a while just in case | ||
| 512 : | |||
| 513 : | ##Eliminates duplicates answers and rearranges inverted_shuffle so that all questions with the same answer | ||
| 514 : | ##point to one and only one copy of that answer | ||
| 515 : | #sub old_condense { | ||
| 516 : | # my $self = shift; | ||
| 517 : | # for (my $outer = 0; $outer < @{ $self->{selected_a} }; $outer++) { | ||
| 518 : | # for (my $inner = $outer+1; $inner < @{ $self->{selected_a} }; $inner++) { | ||
| 519 : | # if (@{ $self->{selected_a} }[$outer] eq @{ $self->{selected_a} }[$inner]) { | ||
| 520 : | # #then delete the duplicate answer at subscript $outer | ||
| 521 : | # @{ $self->{selected_a} } = ( @{ $self->{selected_a} }[0..$outer-1], @{ $self->{selected_a} }[$outer | ||
| 522 : | # | ||
| 523 : | # #the values of inverted_shuffle point to the position elements in selected_a | ||
| 524 : | # #so in order to delete something from selected_a, each element with a position | ||
| 525 : | # #greater than $outer must have its position be decremented by one | ||
| 526 : | # $inner--; #$inner must be greater than outer so decrement $inner first | ||
| 527 : | # for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { | ||
| 528 : | # if ( @{ $self->{inverted_shuffle} }[$pos] == $outer ) { | ||
| 529 : | # @{ $self->{inverted_shuffle} }[$pos] = $inner; | ||
| 530 : | # } elsif ( @{ $self->{inverted_shuffle} }[$pos] > $outer ) { | ||
| 531 : | # @{ $self->{inverted_shuffle} }[$pos]--; | ||
| 532 : | # } | ||
| 533 : | # } | ||
| 534 : | # } | ||
| 535 : | # } | ||
| 536 : | # } | ||
| 537 : | #} | ||
| 538 : | sub pretty_print { | ||
| 539 : | my $r_input = shift; | ||
| 540 : | my $out = ''; | ||
| 541 : | if ( not ref($r_input) ) { | ||
| 542 : | $out = $r_input; # not a reference | ||
| 543 : | } elsif ("$r_input" =~/hash/i ) { # this will pick up objects whose '$self' is hash and so works better than ref($r_iput). | ||
| 544 : | local($^W) = 0; | ||
| 545 : | $out .= "$r_input " ."<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">"; | ||
| 546 : | foreach my $key (sort keys %$r_input ) { | ||
| 547 : | $out .= "<tr><TD> $key</TD><TD> => </td><td>".pretty_print($r_input->{$key}) . "</td></tr>"; | ||
| 548 : | } | ||
| 549 : | $out .="</table>"; | ||
| 550 : | } elsif (ref($r_input) eq 'ARRAY' ) { | ||
| 551 : | my @array = @$r_input; | ||
| 552 : | $out .= "( " ; | ||
| 553 : | while (@array) { | ||
| 554 : | $out .= pretty_print(shift @array) . " , "; | ||
| 555 : | } | ||
| 556 : | $out .= " )"; | ||
| 557 : | } elsif (ref($r_input) eq 'CODE') { | ||
| 558 : | $out = "$r_input"; | ||
| 559 : | # } elsif (ref($r_input) =~/list/i or ref($r_input) =~/match/i or ref($r_input) =~/multiple/i) { | ||
| 560 : | # local($^W) = 0; | ||
| 561 : | # $out .= ref($r_input) . " <BR>" ."<TABLE BGCOLOR = \"#FFFFFF\">"; | ||
| 562 : | # foreach my $key (sort keys %$r_input ) { | ||
| 563 : | # $out .= "<tr><TD> $key</TD><TD> => </td><td>".pretty_print($r_input->{$key}) . "</td></tr>"; | ||
| 564 : | # } | ||
| 565 : | # $out .="</table>"; | ||
| 566 : | } else { | ||
| 567 : | $out = $r_input; | ||
| 568 : | } | ||
| 569 : | $out; | ||
| 570 : | } | ||
| 571 : | |||
| 572 : | 1; |
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |