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