[system] / trunk / webwork / system / courseScripts / List.pm Repository:
ViewVC logotype

View of /trunk/webwork/system/courseScripts/List.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 160 - (download) (as text) (annotate)
Sun Aug 26 02:22:48 2001 UTC (18 years, 5 months ago) by gage
File size: 19512 byte(s)
Modified the pod documentation

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9