Parent Directory
| 
Revision Log
Added a ->cmp method for checking the answers. It needs further improvement but it is a first step toward making the List elements more compatible with MathObjects. The ->cmp method will be inherited by the Select, Match and so forth objects
1 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 #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 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 # This condense didn't repeat the inner loop after deleting the element at $outer (so that $outer now pointed to a new value) 546 # so if the new value at $outer also had a duplicate then it was just skipped. 547 # This shouldn't work but i'll leave it in for a while just in case 548 549 ##Eliminates duplicates answers and rearranges inverted_shuffle so that all questions with the same answer 550 ##point to one and only one copy of that answer 551 #sub old_condense { 552 # my $self = shift; 553 # for (my $outer = 0; $outer < @{ $self->{selected_a} }; $outer++) { 554 # for (my $inner = $outer+1; $inner < @{ $self->{selected_a} }; $inner++) { 555 # if (@{ $self->{selected_a} }[$outer] eq @{ $self->{selected_a} }[$inner]) { 556 # #then delete the duplicate answer at subscript $outer 557 # @{ $self->{selected_a} } = ( @{ $self->{selected_a} }[0..$outer-1], @{ $self->{selected_a} }[$outer 558 # 559 # #the values of inverted_shuffle point to the position elements in selected_a 560 # #so in order to delete something from selected_a, each element with a position 561 # #greater than $outer must have its position be decremented by one 562 # $inner--; #$inner must be greater than outer so decrement $inner first 563 # for (my $pos = 0; $pos < @{ $self->{inverted_shuffle} }; $pos++) { 564 # if ( @{ $self->{inverted_shuffle} }[$pos] == $outer ) { 565 # @{ $self->{inverted_shuffle} }[$pos] = $inner; 566 # } elsif ( @{ $self->{inverted_shuffle} }[$pos] > $outer ) { 567 # @{ $self->{inverted_shuffle} }[$pos]--; 568 # } 569 # } 570 # } 571 # } 572 # } 573 #} 574 # sub pretty_print { 575 # my $r_input = shift; 576 # my $out = ''; 577 # if ( not ref($r_input) ) { 578 # $out = $r_input; # not a reference 579 # } elsif ("$r_input" =~/hash/i ) { # this will pick up objects whose '$self' is hash and so works better than ref($r_iput). 580 # local($^W) = 0; 581 # $out .= "$r_input " ."<TABLE border = \"2\" cellpadding = \"3\" BGCOLOR = \"#FFFFFF\">"; 582 # foreach my $key (sort keys %$r_input ) { 583 # $out .= "<tr><TD> $key</TD><TD> => </td><td>".pretty_print($r_input->{$key}) . "</td></tr>"; 584 # } 585 # $out .="</table>"; 586 # } elsif (ref($r_input) eq 'ARRAY' ) { 587 # my @array = @$r_input; 588 # $out .= "( " ; 589 # while (@array) { 590 # $out .= pretty_print(shift @array) . " , "; 591 # } 592 # $out .= " )"; 593 # } elsif (ref($r_input) eq 'CODE') { 594 # $out = "$r_input"; 595 # # } elsif (ref($r_input) =~/list/i or ref($r_input) =~/match/i or ref($r_input) =~/multiple/i) { 596 # # local($^W) = 0; 597 # # $out .= ref($r_input) . " <BR>" ."<TABLE BGCOLOR = \"#FFFFFF\">"; 598 # # foreach my $key (sort keys %$r_input ) { 599 # # $out .= "<tr><TD> $key</TD><TD> => </td><td>".pretty_print($r_input->{$key}) . "</td></tr>"; 600 # # } 601 # # $out .="</table>"; 602 # } else { 603 # $out = $r_input; 604 # } 605 # $out; 606 # } 607 608 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |