Parent Directory
| 
Revision Log
This is a renaming of the List.pm module so that it doesn't conflict with the MathObjects List
1 2 #New highly object-oriented ChoiceList construct 3 #This ChoiceList.pm is the super class for all types of ChoiceLists 4 #As of 6/5/2000 the three ChoiceList sub-classes are Match, Select, Multiple 5 #RDV 6 7 =head1 NAME 8 9 ChoiceList.pm -- super-class for all ChoiceList structures 10 11 =head1 SYNOPSIS 12 13 =pod 14 15 ChoiceList.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 ChoiceList.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 ChoiceList; 135 136 137 138 @ChoiceList::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 "ChoiceList requires a random number: new ChoiceList(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 = $ChoiceList::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 #internal 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 #internal 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 #internal 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 #internal 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 300 =head3 qa 301 Usage: $ml->qa( qw( question1 answer1 question2 answer2 ) ); 302 303 =cut 304 305 sub qa { 306 my $self = shift; 307 my @questANDanswer = @_; 308 309 while (@questANDanswer) { 310 push (@{ $self->{questions} }, shift(@questANDanswer) ); 311 push (@{ $self->{answers} }, shift(@questANDanswer) ); 312 } 313 } 314 315 #Input extra answers -- not to be confused with access method extras below 316 sub extra { 317 my $self = shift; 318 push(@{ $self->{extras} }, @_); #pushing allows multiple calls without overwriting old "extras" 319 } 320 321 322 #Output questions 323 #Doesn't do actual output, refers to method given in call to 'new' (rf_print_q) 324 325 sub print_q { 326 my $self = shift; 327 328 &{ $self->{rf_print_q} }( $self, @{ $self->{selected_q} } ); 329 } 330 331 #Output answers 332 #Doesn't do actual output, refers to method given in call to 'new' (rf_print_a) 333 sub print_a { 334 my $self = shift; 335 336 &{ $self->{rf_print_a} }( $self, @{ $self->{selected_a} } ); 337 } 338 339 #return array of answers to be checked against the students answers 340 #defaults to returning the actual selected answers (should be overloaded for other types of answers) 341 sub ra_correct_ans { 342 my $self = shift; 343 return $self->{selected_a}; 344 } 345 346 =head3 cmp 347 348 Usage ANS($ml -> cmp); 349 350 provides a MathObject like comparison method 351 returns a string of comparison methods for checking the list object 352 353 =cut 354 355 sub cmp { 356 my $self = shift; 357 my @answers = @{$self->{selected_a}}; 358 @answers = map {Value::makeValue($_)} @answers; # make sure answers are all MathObjects 359 @answers = map {$_->cmp} @answers; # replace the MathObjects by their AnswerEvaluators 360 return @answers; 361 } 362 363 #Match and Select return references to arrays while Multiple justs returns a string 364 #so Match and Select use ra_correct_ans while Multiple uses correct_ans 365 sub correct_ans { 366 warn "Match and/or Select do not use correct_ans.\nYou should use ra_correct_ans instead."; 367 } 368 369 # *** Question and Answer Manipulation Subroutines *** 370 371 372 #calls methods that deal with list specific methods of picking random questions and answers 373 #mainly exists for backward compatibility and to hide some of the activity from the naive user 374 sub choose { 375 my $self = shift; 376 my @input = @_; 377 378 $self->getRandoms(scalar(@{$self->{questions}}), @input); #pick random numbers 379 $self->selectQA(); #select questions and answers 380 $self->dumpExtra(); #dump extra answers into "extras" 381 $self->condense(); #eliminate duplicate answers" 382 } 383 384 #randomly inserts the selected extra answers into selected_a and 385 #updates inverted_shuffle accordingly 386 sub choose_extra { 387 my $self = shift; 388 my @input = @_; 389 390 $self->getRandoms(scalar(@{ $self->{extras} }), @input); 391 $self->{selected_e} = [ @{ $self->{extras} }[ @{ $self->{slice} }[ @{ $self->{shuffle} } ] ] ]; 392 my $length = 0; 393 394 my $random = 0; 395 foreach my $extra_ans ( invert(@{ $self->{shuffle} }) ) { 396 #warn "Selected Answers: @{ $self->{selected_a} }<BR> 397 # Inverted Shuffle: @{ $self->{inverted_shuffle} }<BR> 398 # Random: $random"; 399 $random = $self->{rand_gen}->random(0, scalar(@{ $self->{selected_a} }), 1); 400 for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { 401 @{ $self->{inverted_shuffle} }[$pos]++ unless @{ $self->{inverted_shuffle} }[$pos] < $random; 402 } 403 my @temp = ( @{ $self->{selected_a} }[0..$random-1], @{ $self->{selected_e} }[$extra_ans], @{$self->{selected_a} }[$random..$#{ $self->{selected_a} } ] ); 404 @{ $self->{selected_a} } = @temp; 405 } 406 } 407 408 #create random @slice and @shuffle to randomize questions and answers 409 sub getRandoms { 410 my $self = shift; 411 my $N = shift; 412 my @input = @_; 413 my $K = 0; 414 415 my @fixed_choices = (); # questions forced by the user 416 foreach my $i (@input) { #input is of the form ([3, 5, 6], 3) 417 if (ref($i) eq 'ARRAY') { 418 push(@fixed_choices, @{$i}); 419 } else { 420 $K += $i; 421 } 422 } 423 424 # my $N = @{ $self->{questions} }; 425 my @remaining = complement( [0..$N-1], [@fixed_choices] ); 426 427 my @slice = @fixed_choices; 428 push (@slice, @remaining[ $self->NchooseK(scalar(@remaining), $K) ] ); #slice of remaing choices 429 @slice = @slice[ $self->NchooseK( scalar(@slice), scalar(@slice) ) ]; #randomize the slice (the questions) 430 431 #shuffle will be used to randomize the answers a second time (so they don't coincide with the questions) 432 my @shuffle = $self->NchooseK( scalar(@slice), scalar(@slice) ); 433 434 $self->{slice} = \@slice; #keep track of the slice and shuffle 435 $self->{shuffle} = \@shuffle; 436 } 437 438 #select questions and answers according to slice and shuffle 439 sub selectQA { 440 my $self = shift; 441 442 $self->{selected_q} = [ @{ $self->{questions} }[ @{ $self->{slice} } ] ]; 443 $self->{selected_a} = [ @{ $self->{answers} }[@{ $self->{slice} }[@{ $self->{shuffle} } ] ] ]; 444 $self->{inverted_shuffle} = [ invert(@{ $self->{shuffle} }) ]; 445 } 446 447 #dump unused answers into list of extra answers 448 sub dumpExtra { 449 my $self = shift; 450 my @more_extras = complement([0..scalar(@{ $self->{answers} })-1], [@{ $self->{slice} }]); 451 push( @{ $self->{extras} }, @{ $self->{answers} }[@more_extras] ); 452 } 453 454 #Allows answers to be added to the end of the selected answers 455 #This can be used to force answers like "None of the above" and/or "All of the above" to still occur at the 456 #end of the list instead of being randomized like the rest of the answers 457 sub makeLast { 458 my $self = shift; 459 my @input = @_; 460 461 push(@{ $self->{selected_a} }, @input); 462 $self->condense(); #make sure that the user has not accidentally forced a duplicate answer 463 #note: condense was changed to eliminate the first occurence of a duplicate 464 #instead of the last occurence so that it could be used in this case and 465 #would not negate the fact that one of the answers needs to be at the end 466 } 467 468 #Eliminates duplicates answers and rearranges inverted_shuffle so that all questions with the same answer 469 #point to one and only one copy of that answer 470 # sub old_condense { 471 # my $self = shift; 472 # for (my $outer = 0; $outer < @{ $self->{selected_a} }; $outer++) { 473 # for (my $inner = $outer+1; $inner < @{ $self->{selected_a} }; $inner++) { 474 # if (@{ $self->{selected_a} }[$outer] eq @{ $self->{selected_a} }[$inner]) { 475 # #then delete the duplicate answer at subscript $outer 476 # @{ $self->{selected_a} } = ( @{ $self->{selected_a} }[0..$outer-1], @{ $self->{selected_a} }[$outer+1..$#{ $self->{selected_a} }] ); 477 # 478 # #the values of inverted_shuffle point to the position elements in selected_a 479 # #so in order to delete something from selected_a, each element with a position 480 # #greater than $outer must have its position be decremented by one 481 # $inner--; #$inner must be greater than outer so decrement $inner first 482 # for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { 483 # if ( @{ $self->{inverted_shuffle} }[$pos] == $outer ) { 484 # @{ $self->{inverted_shuffle} }[$pos] = $inner; 485 # } elsif ( @{ $self->{inverted_shuffle} }[$pos] > $outer ) { 486 # @{ $self->{inverted_shuffle} }[$pos]--; 487 # } 488 # } 489 # #we just changed a bunch of pointers so we need to go back over the same answers again 490 # #(so we decrement $inner (which we already did) and $outer to counter-act the for loop)) 491 # #this could probably be done slightly less hackish with while loops instead of for loops 492 # #$outer--; 493 # } 494 # } 495 # } 496 # } 497 498 #re-written RDV 10/4/2000 499 #Eliminates duplicate answers and rearranges inverted_shuffle so that all questions with the same answer 500 #point to one and only one copy of that answer 501 sub condense { 502 my $self = shift; 503 my ($outer, $inner) = (0, 0); 504 my $repeat = 0; 505 506 while ($outer < @{ $self->{selected_a} }) { 507 $inner = $outer + 1; 508 $repeat = 0; #loop again if we find a match 509 while ($inner < @{ $self->{selected_a}}) { 510 $repeat = 0; #loop again if we find a match 511 if (@{ $self->{selected_a} }[$outer] eq @{$self->{selected_a} }[$inner]) { 512 513 #then delete the duplicate answer at subscript $outer by combining everything before and after it 514 @{ $self->{selected_a} } = ( @{ $self->{selected_a} }[0..$outer-1], @{ $self->{selected_a} }[$outer+1..$#{ $self->{selected_a} }] ); 515 516 #the values of inverted_shuffle to point the _subscript_ of elements in selected_a 517 #so in order to delete something from selected_a, each element with a subscript 518 #greater than $outer (where the deletion occurred) must have its position decremented by one 519 #This also means we need to "slide" $inner down so that it points to the new position 520 #of the duplicate answer 521 $inner--; 522 523 for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { 524 if ( @{ $self->{inverted_shuffle} }[$pos] == $outer) { 525 @{ $self->{inverted_shuffle} }[$pos] = $inner; 526 } elsif ( @{ $self->{inverted_shuffle} }[$pos] > $outer ) { 527 @{ $self->{inverted_shuffle} }[$pos]--; 528 } 529 } 530 531 #because we just changed the element that $outer points to 532 #we need to run throught the loop to make sure that the new value at $outer has 533 #no duplicates as well 534 #This means that we don't want to increment either counter (and we need to reset $inner) 535 $repeat = 1; 536 $inner = $outer + 1; 537 } 538 $inner++ unless $repeat; 539 } 540 $outer++ unless $repeat; 541 } 542 } 543 544 ########################## 545 # Access methods 546 ########################## 547 sub questions { 548 my $self = shift; 549 my $type = ref($self) || die "$self is not an object"; 550 unless (exists $self->{questions} ) { 551 die "Can't find questions field in object of class $type"; 552 } 553 554 if (@_) { 555 return $self->{questions} = shift; 556 } else { 557 return $self->{questions} 558 } 559 } 560 561 sub answers { 562 my $self = shift; 563 my $type = ref($self) || die "$self is not an object"; 564 unless (exists $self->{answers} ) { 565 die "Can't find answers field in object of class $type"; 566 } 567 568 if (@_) { 569 return $self->{answers} = shift; 570 } else { 571 return $self->{answers} 572 } 573 } 574 sub extras { 575 my $self = shift; 576 my $type = ref($self) || die "$self is not an object"; 577 unless (exists $self->{extras} ) { 578 die "Can't find extras field in object of class $type"; 579 } 580 581 if (@_) { 582 return $self->{extras} = shift; 583 } else { 584 return $self->{extras} 585 } 586 } 587 sub selected_q { 588 my $self = shift; 589 my $type = ref($self) || die "$self is not an object"; 590 unless (exists $self->{selected_q} ) { 591 die "Can't find selected_q field in object of class $type"; 592 } 593 594 if (@_) { 595 return $self->{selected_q} = shift; 596 } else { 597 return $self->{selected_q} 598 } 599 } 600 sub selected_a { 601 my $self = shift; 602 my $type = ref($self) || die "$self is not an object"; 603 unless (exists $self->{selected_a} ) { 604 die "Can't find selected_a field in object of class $type"; 605 } 606 607 if (@_) { 608 return $self->{selected_a} = shift; 609 } else { 610 return $self->{selected_a} 611 } 612 } 613 sub selected_e { 614 my $self = shift; 615 my $type = ref($self) || die "$self is not an object"; 616 unless (exists $self->{selected_e} ) { 617 die "Can't find selected_e field in object of class $type"; 618 } 619 620 if (@_) { 621 return $self->{selected_e} = shift; 622 } else { 623 return $self->{selected_e} 624 } 625 } 626 sub ans_rule_len { 627 my $self = shift; 628 my $type = ref($self) || die "$self is not an object"; 629 unless (exists $self->{ans_rule_len} ) { 630 die "Can't find ans_rule_len field in object of class $type"; 631 } 632 633 if (@_) { 634 return $self->{ans_rule_len} = shift; 635 } else { 636 return $self->{ans_rule_len} 637 } 638 } 639 sub ra_pop_up_list { 640 my $self = shift; 641 my $type = ref($self) || die "$self is not an object"; 642 unless (exists $self->{ra_pop_up_list} ) { 643 die "Can't find ra_pop_up_list field in object of class $type"; 644 } 645 646 if (@_) { 647 return $self->{ra_pop_up_list} = shift; 648 } else { 649 return $self->{ra_pop_up_list} 650 } 651 } 652 sub rf_print_q { 653 my $self = shift; 654 my $type = ref($self) || die "$self is not an object"; 655 unless (exists $self->{rf_print_q} ) { 656 die "Can't find rf_print_q field in object of class $type"; 657 } 658 659 if (@_) { 660 return $self->{rf_print_q} = shift; 661 } else { 662 return $self->{rf_print_q} 663 } 664 } 665 sub rf_print_a { 666 my $self = shift; 667 my $type = ref($self) || die "$self is not an object"; 668 unless (exists $self->{rf_print_a} ) { 669 die "Can't find rf_print_a field in object of class $type"; 670 } 671 672 if (@_) { 673 return $self->{rf_print_a} = shift; 674 } else { 675 return $self->{rf_print_a} 676 } 677 } 678 sub slice { 679 my $self = shift; 680 my $type = ref($self) || die "$self is not an object"; 681 unless (exists $self->{slice} ) { 682 die "Can't find slice field in object of class $type"; 683 } 684 685 if (@_) { 686 return $self->{slice} = shift; 687 } else { 688 return $self->{slice} 689 } 690 } 691 692 sub inverted_shuffle { 693 my $self = shift; 694 my $type = ref($self) || die "$self is not an object"; 695 unless (exists $self->{inverted_shuffle} ) { 696 die "Can't find inverted_shuffle field in object of class $type"; 697 } 698 699 if (@_) { 700 return $self->{inverted_shuffle} = shift; 701 } else { 702 return $self->{inverted_shuffle} 703 } 704 } 705 sub rand_gen { 706 my $self = shift; 707 my $type = ref($self) || die "$self is not an object"; 708 unless (exists $self->{rand_gen} ) { 709 die "Can't find rand_gen field in object of class $type"; 710 } 711 712 if (@_) { 713 return $self->{rand_gen} = shift; 714 } else { 715 return $self->{rand_gen} 716 } 717 } 718 719 720 721 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |