[system] / trunk / pg / lib / List.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/List.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1079 - (download) (as text) (annotate)
Mon Jun 9 17:36:12 2003 UTC (16 years, 7 months ago) by apizer
File size: 19829 byte(s)
removed unneccesary shebang lines

    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 
  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> =&gt; </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> =&gt; </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