Annotation of loncom/homework/default_homework.lcpm, revision 1.139

1.42      albertel    1: # The LearningOnline Network with CAPA 
1.1       harris41    2: # used by lonxml::xmlparse() as input variable $safeinit to Apache::run::run()
1.42      albertel    3: #
1.139   ! raeburn     4: # $Id: default_homework.lcpm,v 1.138 2008/09/06 21:39:15 raeburn Exp $
1.42      albertel    5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.20      harris41   28: #
1.76      albertel   29: 
1.25      albertel   30: #init some globals
1.38      albertel   31: $hidden::RANDOMINIT=0;
1.22      ng         32: $pi=atan2(1,1)*4;
                     33: $rad2deg=180.0/$pi;
                     34: $deg2rad=$pi/180.0;
1.44      matthew    35: $"=' ';
1.116     albertel   36: use strict;
                     37: {
                     38:     my $n = 0;
                     39:     my $total = 0;
                     40:     my $num_left = 0;
                     41:     my @order;
                     42:     my $type;
                     43: 
                     44:     sub init_permutation {
                     45: 	my ($size,$requested_type) = @_;
                     46: 	@order = (0..$size-1);
                     47: 	$n = $size;
                     48: 	$type = $requested_type;
                     49: 	if ($type eq 'ordered') {
                     50: 	    $total = $num_left = 1;
                     51: 	} elsif ($type eq 'unordered') {
                     52: 	    $total = $num_left = &factorial($size);
                     53: 	} else {
                     54: 	    die("Unkown type: $type");
                     55: 	}
                     56:     }
                     57: 
                     58:     sub get_next_permutation {
                     59: 	if ($num_left == $total) {
                     60: 	    $num_left--;
1.117     albertel   61: 	    return \@order;
1.116     albertel   62: 	}
                     63: 
                     64: 	# Find largest index j with a[j] < a[j+1]
                     65: 
                     66: 	my $j = scalar(@order) - 2;
                     67: 	while ($order[$j] > $order[$j+1]) {
                     68: 	    $j--;
                     69: 	}
                     70: 
                     71: 	# Find index k such that a[k] is smallest integer
                     72: 	# greater than a[j] to the right of a[j]
                     73: 
                     74: 	my $k = scalar(@order) - 1;
                     75: 	while ($order[$j] > $order[$k]) {
                     76: 	    $k--;
                     77: 	}
                     78: 
                     79: 	# Interchange a[j] and a[k]
                     80: 
                     81: 	@order[($k,$j)] = @order[($j,$k)];
                     82: 
                     83: 	# Put tail end of permutation after jth position in increasing order
                     84: 
                     85: 	my $r = scalar(@order) - 1;
                     86: 	my $s = $j + 1;
                     87: 
                     88: 	while ($r > $s) {
                     89: 	    @order[($s,$r)]=@order[($r,$s)];
                     90: 	    $r--;
                     91: 	    $s++;
                     92: 	}
                     93: 
                     94: 	$num_left--;
1.117     albertel   95: 	return(\@order);
1.116     albertel   96:     }
                     97:     
                     98:     sub get_permutations_left {
                     99: 	return $num_left;
                    100:     }
                    101: }
1.3       albertel  102: 
1.91      albertel  103: sub check_commas {
                    104:     my ($response)=@_;
                    105:     #print("$response ");
                    106:     my @numbers=split(',',$response);
                    107:     #print(" numbers ".join('-',@numbers)." ");
                    108:     if (scalar(@numbers) > 1) {
                    109:         #print(" numbers[0] ".$numbers[0]." "); 
                    110: 	if (length($numbers[0]) > 3 || length($numbers[0]) == 0) { return -1; }
                    111: 	shift(@numbers);
                    112: 	#print(" numbers ".scalar(@numbers)." ");
                    113: 	while (scalar(@numbers) > 1) {
                    114: 	    #print(" numbers ".join('-',@numbers)." ");
                    115: 	    if (length($numbers[0]) != 3) { return -2; }
                    116: 	    shift(@numbers);
                    117: 	}
                    118: 	my ($number)=split('\.',$numbers[0]);
                    119: 	#print(" number ".$number." ");
                    120: 	#print(" numbers[0] ".$numbers[0]." ");
                    121: 	if (length($number) != 3) { return -3; }
                    122:     } else {
                    123: 	my ($number)=split('\.',$numbers[0]);
                    124: 	if (length($number) > 3) { return -4; }
                    125:     }
                    126:     return 1;
                    127: }
                    128: 
1.117     albertel  129: 
1.7       albertel  130: sub caparesponse_check {
1.74      albertel  131:     my ($answer,$response)=@_;
1.73      albertel  132:     #not properly used yet: calc
                    133:     #not to be used: $ans_fmt
1.74      albertel  134:     my $type=$LONCAPA::CAPAresponse_args{'type'};
                    135:     my $tol=$LONCAPA::CAPAresponse_args{'tol'};
                    136:     my $sig=$LONCAPA::CAPAresponse_args{'sig'};
1.88      albertel  137:     my $ans_fmt=$LONCAPA::CAPAresponse_args{'format'};
1.74      albertel  138:     my $unit=$LONCAPA::CAPAresponse_args{'unit'};
                    139:     my $calc=$LONCAPA::CAPAresponse_args{'calc'};
                    140:     my $samples=$LONCAPA::CAPAresponse_args{'samples'};
1.73      albertel  141:     
                    142:     my $tol_type=''; # gets it's value from whether tol has a % or not done
                    143:     my $sig_lbound=''; #done
                    144:     my $sig_ubound=''; #done
                    145: 
                    146: 
                    147:     #type's definitons come from capaParser.h
1.116     albertel  148: 
1.73      albertel  149:     #remove leading and trailing whitespace
                    150:     if (!defined($response)) {
                    151: 	$response='';
                    152:     }
                    153:     if ($response=~ /^\s|\s$/) {
                    154: 	$response=~ s:^\s+|\s+$::g;
1.119     albertel  155: 	&LONCAPA_INTERNAL_DEBUG("Removed ws now :$response:");
1.73      albertel  156:     }
1.116     albertel  157: 
1.117     albertel  158:     #&LONCAPA_INTERNAL_DEBUG(" type is $type ");
1.100     albertel  159:     if ($type eq 'cs' || $type eq 'ci') {
1.130     www       160: 	#for string answers make sure all places spaces occur, there is 
1.76      albertel  161:         #really only 1 space, in both the answer and the response
                    162: 	$answer=~s/ +/ /g;
                    163: 	$response=~s/ +/ /g;
1.100     albertel  164:     } elsif ($type eq 'mc') {
                    165: 	$answer=~s/[\s,]//g;
                    166: 	$response=~s/[\s,]//g;
1.76      albertel  167:     }
1.91      albertel  168:     if ($type eq 'float' && $unit=~/\$/) {
1.126     www       169: 	if ($response!~/^\$|\$$/)  { return ('NO_UNIT', undef); }
1.88      albertel  170: 	$response=~s/\$//g;
                    171:     }
1.91      albertel  172:     if ($type eq 'float' && $unit=~/\,/ && (&check_commas($response)<0)) {
                    173: 	return "COMMA_FAIL:";
                    174:     }
1.88      albertel  175:     $ans_fmt=~s/\W//g;
1.91      albertel  176:     $unit=~s/[\$,]//g;
                    177:     if ($type eq 'float') { $response=~s/,//g; }
1.88      albertel  178: 
1.117     albertel  179:     if (length($response) > 500) { return ('TOO_LONG',undef); }
1.73      albertel  180: 
                    181:     if ($type eq '' ) {
1.119     albertel  182: 	&LONCAPA_INTERNAL_DEBUG("Didn't find a type :$type: defaulting");
1.73      albertel  183: 	if ( $answer eq ($answer *1.0)) { $type = 2;
                    184: 				      } else { $type = 3; }
                    185:     } else {
1.107     albertel  186: 	if    ($type eq 'cs')    { $type = 4; }
1.73      albertel  187: 	elsif ($type eq 'ci')    { $type = 3 }
                    188: 	elsif ($type eq 'mc')    { $type = 5; }
                    189: 	elsif ($type eq 'fml')   { $type = 8; }
1.107     albertel  190:         elsif ($type eq 'math')  { $type = 9; }
1.73      albertel  191: 	elsif ($type eq 'subj')  { $type = 7; }
                    192: 	elsif ($type eq 'float') { $type = 2; }
                    193: 	elsif ($type eq 'int')   { $type = 1; }
1.117     albertel  194: 	else { return ('ERROR', "Unknown type of answer: $type") }
1.73      albertel  195:     }
                    196: 
                    197:     my $points;
                    198:     my $id_list;
                    199:     #formula type setup the sample points
                    200:     if ($type eq '8') {
                    201: 	($id_list,$points)=split(/@/,$samples);
1.119     albertel  202: 	&LONCAPA_INTERNAL_DEBUG("Found :$id_list:$points: points in $samples");
1.73      albertel  203:     }
                    204:     if ($tol eq '') {
                    205: 	$tol=0.0;
                    206: 	$tol_type=1; #TOL_ABSOLUTE
                    207:     } else {
                    208: 	if ($tol =~ /%$/) {
                    209: 	    chop $tol;
                    210: 	    $tol_type=2; #TOL_PERCENTAGE
                    211: 	} else {
                    212: 	    $tol_type=1; #TOL_ABSOLUTE
                    213: 	}
                    214:     }
                    215: 
1.85      albertel  216:     ($sig_ubound,$sig_lbound)=&LONCAPA_INTERNAL_get_sigrange($sig);
                    217: 
1.73      albertel  218:     my $reterror="";
1.107     albertel  219:     my $result;
1.125     www       220:     if ((($type eq '9') || ($type eq '8')) && ($response=~/\=/)) { return ('BAD_FORMULA','Please submit just an expression, not an equation.'); }
1.107     albertel  221:     if ($type eq '9') {
1.108     www       222:       $result = &maxima_check(&maxima_cas_formula_fix($response),&maxima_cas_formula_fix($answer),\$reterror);
1.107     albertel  223:     } else {
1.109     albertel  224: 	if ($type eq '8') { # fml type
                    225: 	    $response = &capa_formula_fix($response);
                    226: 	    $answer   = &capa_formula_fix($answer);
                    227: 	}
                    228:        $result = &caparesponse_capa_check_answer($response,$answer,$type,
1.73      albertel  229: 						 $tol_type,$tol,
                    230: 						 $sig_lbound,$sig_ubound,
                    231: 						 $ans_fmt,$unit,$calc,$id_list,
                    232: 						 $points,$external::randomseed,
                    233: 						 \$reterror);
1.107     albertel  234:     }
1.73      albertel  235:     if    ($result == '1') { $result='EXACT_ANS'; } 
                    236:     elsif ($result == '2') { $result='APPROX_ANS'; }
                    237:     elsif ($result == '3') { $result='SIG_FAIL'; }
                    238:     elsif ($result == '4') { $result='UNIT_FAIL'; }
                    239:     elsif ($result == '5') { $result='NO_UNIT'; }
                    240:     elsif ($result == '6') { $result='UNIT_OK'; }
                    241:     elsif ($result == '7') { $result='INCORRECT'; }
                    242:     elsif ($result == '8') { $result='UNIT_NOTNEEDED'; }
                    243:     elsif ($result == '9') { $result='ANS_CNT_NOT_MATCH'; }
                    244:     elsif ($result =='10') { $result='SUB_RECORDED'; }
                    245:     elsif ($result =='11') { $result='BAD_FORMULA'; }
1.94      albertel  246:     elsif ($result =='12' && !$response) { $result='MISSING_ANSWER'; }
                    247:     elsif ($result =='12') { $result='WANTED_NUMERIC'; }
1.77      albertel  248:     elsif ($result =='13') { $result='UNIT_INVALID_INSTRUCTOR'; }
                    249:     elsif ($result =='141') { $result='UNIT_INVALID_STUDENT'; }
                    250:     elsif ($result =='142') { $result='UNIT_INVALID_STUDENT'; }
                    251:     elsif ($result =='143') { $result='UNIT_INVALID_STUDENT'; }
                    252:     elsif ($result =='15') { $result='UNIT_IRRECONCIBLE'; }
1.73      albertel  253:     else  {$result = "ERROR: Unknown Result:$result:$@:";}
                    254: 
1.119     albertel  255:     &LONCAPA_INTERNAL_DEBUG("RetError $reterror: Answer $answer: Response $response:  type-$type|$tol|$tol_type|$sig:$sig_lbound:$sig_ubound|$unit|");
                    256:     &LONCAPA_INTERNAL_DEBUG(" $answer $response $result ");
1.139   ! raeburn   257:     return ($result,$reterror);
1.37      albertel  258: }
                    259: 
1.73      albertel  260: 
1.37      albertel  261: sub caparesponse_check_list {
1.139   ! raeburn   262:     my ($tag) = @_;
1.119     albertel  263:     my $responses=$LONCAPA::CAPAresponse_args{'response'};
1.105     albertel  264:     &LONCAPA_INTERNAL_DEBUG("args ".join(':',%LONCAPA::CAPAresponse_args));
1.74      albertel  265:     my $type = $LONCAPA::CAPAresponse_args{'type'};
1.133     www       266:     my $answerunit=$LONCAPA::CAPAresponse_args{'unit'};
                    267:     &LONCAPA_INTERNAL_DEBUG("Got type :$type: answer unit :$answerunit:\n");
1.119     albertel  268:     
                    269:     my $num_input_lines =
                    270: 	scalar(@{$LONCAPA::CAPAresponse_answer->{'answers'}});
1.120     albertel  271:     
                    272:     if ($type ne '' ) {
1.119     albertel  273: 	if (scalar(@$responses) < $num_input_lines) {
1.105     albertel  274: 	    return 'MISSING_ANSWER';
                    275: 	}
1.119     albertel  276: 	if (scalar(@$responses) > $num_input_lines) {
                    277: 	    return 'EXTRA_ANSWER';
                    278: 	}
                    279: 
                    280:     }
                    281: 
                    282:     foreach my $which (0..($num_input_lines-1)) {
                    283: 	my $answer_size = 
                    284: 	    scalar(@{$LONCAPA::CAPAresponse_answer->{'answers'}[$which]});
                    285: 	if ($type ne '' 
                    286: 	    && $answer_size > 1) {
                    287: 	    $responses->[$which]=[split(/,/,$responses->[$which])];
                    288: 	} else {
                    289: 	    $responses->[$which]=[$responses->[$which]];
                    290: 	}
                    291:     }
                    292:     foreach my $which (0..($num_input_lines-1)) {
                    293: 	my $answer_size = 
                    294: 	    scalar(@{$LONCAPA::CAPAresponse_answer->{'answers'}[$which]});
                    295: 	my $response_size = 
                    296: 	    scalar(@{$responses->[$which]});
                    297: 	if ($answer_size > $response_size) {
                    298: 	    return 'MISSING_ANSWER';
                    299: 	}
                    300: 	if ($answer_size < $response_size) {
1.105     albertel  301: 	    return 'EXTRA_ANSWER';
                    302: 	}
1.73      albertel  303:     }
1.119     albertel  304: 
                    305:     &LONCAPA_INTERNAL_DEBUG("Initial final response :$responses->[0][-1]:");
1.105     albertel  306:     my $unit;
1.139   ! raeburn   307:     if (($type eq 'float') || (($type eq '') && (($tag ne 'stringresponse') && ($tag ne 'stringhint')) ) ) {
1.73      albertel  308: 	#for numerical problems split off the unit
1.128     www       309: #	if ( $responses->[0][-1]=~ /(.*[^\s])\s+([^\s]+)/ ) {
1.132     www       310:         if ( $responses->[0][-1]=~ /^([\d\.\,\s\$]*(?:(?:[xX\*]10[\^\*]*|[eE]*)[\+\-]*\d*)*(?:^|\S)\d+)([\$\s\w\^\*\/\(\)\+\-]*[^\d\.\s\,][\$\s\w\^\*\/\(\)\+\-]*)$/ ) {
1.119     albertel  311: 	    $responses->[0][-1]=$1;
1.128     www       312: 	    $unit=&capa_formula_fix($2);
                    313:             &LONCAPA_INTERNAL_DEBUG("Found unit :$unit:");
1.73      albertel  314: 	}
                    315:     }
1.119     albertel  316:     &LONCAPA_INTERNAL_DEBUG("Final final response :$responses->[0][-1]:$unit:");
1.73      albertel  317:     $unit=~s/\s//;
1.133     www       318:     foreach my $response (@$responses) {
                    319:        foreach my $element (@$response) {	
1.138     raeburn   320:           if (($type eq 'float') || (($type eq '') && ($unit ne ''))) {
                    321:               $element =~ s/\s//g;
                    322:           }
1.133     www       323:           my $appendunit=$unit;
                    324:           if ($unit=~/\%/) {
                    325:              $element=$element/100;
                    326:              $appendunit=~s/\%//;
                    327:           }    
                    328:           if (($element==0) && ($unit!~/\w/) && ($answerunit=~/\w/)) {
                    329:              $appendunit=$answerunit;
                    330:           }
                    331:           $element .= " $appendunit";
                    332:           &LONCAPA_INTERNAL_DEBUG("Made response element :$element:");
                    333:        }
1.119     albertel  334:     }
                    335:     
1.117     albertel  336:     foreach my $thisanswer (@{ $LONCAPA::CAPAresponse_answer->{'answers'} }) {
                    337: 	if (!defined($thisanswer)) {
                    338: 	    return ('ERROR','answer was undefined');
                    339: 	}
                    340:     }
                    341: 
                    342: 
1.121     albertel  343: #    &LONCAPA_INTERNAL_DEBUG(&LONCAPA_INTERNAL_Dumper($responses));
1.117     albertel  344:     my %memoized;
                    345:     if ($LONCAPA::CAPAresponse_answer->{'type'}  eq 'ordered') {
1.119     albertel  346: 	for (my $i=0; $i<scalar(@$responses);$i++) {
1.117     albertel  347: 	    my $answer   = $LONCAPA::CAPAresponse_answer->{'answers'}[$i];
1.119     albertel  348: 	    my $response = $responses->[$i];
1.117     albertel  349: 	    my $key = "$answer\0$response";
1.119     albertel  350: 	    my (@awards,@msgs);
                    351: 	    for (my $j=0; $j<scalar(@$response); $j++) { 
                    352: 		my ($award,$msg) = &caparesponse_check($answer->[$j],
                    353: 						       $response->[$j]);
                    354: 		push(@awards,$award);
                    355: 		push(@msgs,  $msg);
                    356: 	    }
                    357: 	    my ($award,$msg) = 
                    358: 		&LONCAPA_INTERNAL_FINALIZEAWARDS(\@awards,\@msgs);
                    359: 	    $memoized{$key} = [$award,$msg];
1.117     albertel  360: 	}
                    361:     } else {
1.119     albertel  362: 	#FIXME broken with unorder responses where one is a <value>
                    363:         #      and the other is a <vector> (need to delay parse til
                    364:         #      inside the loop?)
                    365: 	foreach my $response (@$responses) {
                    366: 	    my $response_size = scalar(@{$response});
1.117     albertel  367: 	    foreach my $answer (@{ $LONCAPA::CAPAresponse_answer->{'answers'} }) {
                    368: 		my $key = "$answer\0$response";
1.119     albertel  369: 		my $answer_size =  scalar(@{$answer});
                    370: 		my ($award,$msg);
                    371: 		if ($answer_size > $response_size) {
                    372: 		    $award = 'MISSING_ANSWER';
                    373: 		} elsif ($answer_size < $response_size) {
                    374: 		    $award = 'EXTRA_ANSWER';
                    375: 		} else {
                    376: 		    my (@awards,@msgs);
                    377: 		    for (my $j=0; $j<scalar(@$response); $j++) {
                    378: 			my ($award,$msg) = &caparesponse_check($answer->[$j],
                    379: 							       $response->[$j]);
                    380: 			push(@awards,$award);
                    381: 			push(@msgs,  $msg);
                    382: 		    }
                    383: 		    ($award,$msg) = 
                    384: 			&LONCAPA_INTERNAL_FINALIZEAWARDS(\@awards,\@msgs);
                    385: 		}
                    386: 		$memoized{$key} = [$award,$msg];
1.117     albertel  387: 	    }
                    388: 	}
                    389:     }
                    390: 
1.116     albertel  391:     my ($final_award,$final_msg);
1.119     albertel  392:     &init_permutation(scalar(@$responses),
1.116     albertel  393: 		      $LONCAPA::CAPAresponse_answer->{'type'});
1.117     albertel  394: 
1.118     albertel  395:     # possible FIXMEs
                    396:     # - significant time is spent calling non-safe space routine
                    397:     #   from safe space
                    398:     # - early outs could be possible with classifying awards is to stratas
                    399:     #   and stopping as so as hitting the top strata 
                    400:     # - some early outs also might be possible with check ing the 
                    401:     #   memoized hash of results (is correct even possible? etc.)
                    402: 
1.117     albertel  403:     my (@final_awards,@final_msg);
1.116     albertel  404:     while( &get_permutations_left() ) {
1.117     albertel  405: 	my $order = &get_next_permutation();
1.116     albertel  406: 	my (@awards, @msgs, $i);
                    407: 	foreach my $thisanswer (@{ $LONCAPA::CAPAresponse_answer->{'answers'} }) {
1.119     albertel  408: 	    my $key = "$thisanswer\0".$responses->[$order->[$i]];
1.117     albertel  409: 	    push(@awards,$memoized{$key}[0]);
                    410: 	    push(@msgs,$memoized{$key}[1]);
1.116     albertel  411: 	    $i++;
1.119     albertel  412: 
1.116     albertel  413: 	}
1.119     albertel  414: 	&LONCAPA_INTERNAL_DEBUG(" all awards ".join(':',@awards));
                    415: 
1.116     albertel  416: 	my ($possible_award,$possible_msg) = 
                    417: 	    &LONCAPA_INTERNAL_FINALIZEAWARDS(\@awards,\@msgs);
1.119     albertel  418: 	&LONCAPA_INTERNAL_DEBUG(" pos awards ".$possible_award);
1.117     albertel  419: 	push(@final_awards,$possible_award);
                    420: 	push(@final_msg,$possible_msg);
1.73      albertel  421:     }
1.117     albertel  422: 
1.119     albertel  423:     &LONCAPA_INTERNAL_DEBUG(" all final_awards ".join(':',@final_awards));
1.117     albertel  424:     my ($final_award,$final_msg) = 
                    425: 	&LONCAPA_INTERNAL_FINALIZEAWARDS(\@final_awards,\@final_msg,undef,1);
1.116     albertel  426:     return ($final_award,$final_msg);
1.7       albertel  427: }
                    428: 
1.124     www       429: sub cas {
1.137     www       430:     my ($system,$input,$library)=@_;
1.124     www       431:     my $output;
                    432:     if ($system eq 'maxima') {
1.137     www       433:        $output=&maxima_eval($input,$library);
                    434:     } else {
                    435:        $output='Error: unrecognized CAS';
1.124     www       436:     }
                    437:     return $output;
                    438: }
                    439: 
1.4       albertel  440: sub tex {
1.73      albertel  441:     if ( $external::target eq "tex" ) {
                    442: 	return $_[0];
                    443:     } else {
                    444: 	return $_[1];
                    445:     }
1.4       albertel  446: }
                    447: 
1.24      ng        448: sub var_in_tex {
1.73      albertel  449:     if ( $external::target eq "tex" ) {
                    450: 	return $_[0];
                    451:     } else {
                    452: 	return "";
                    453:     }
1.24      ng        454: }
                    455: 
1.4       albertel  456: sub web {
1.73      albertel  457:     if ( $external::target eq "tex" ) {
                    458: 	return $_[1];
1.26      ng        459:     } else {
1.73      albertel  460: 	if ( $external::target eq "web" || $external::target eq "answer") {
                    461: 	    return $_[2];
                    462: 	} else {
                    463: 	    return $_[0];
                    464: 	}
1.4       albertel  465:     }
                    466: }
                    467: 
1.24      ng        468: sub html {
1.73      albertel  469:     if ( $external::target eq "web" ) {
                    470: 	return shift;
                    471:     }
1.24      ng        472: }
                    473: 
1.1       harris41  474: sub hinton {
1.73      albertel  475:     return 0;
1.1       harris41  476: }
                    477: 
                    478: sub random {
1.61      albertel  479:     my ($start,$end,$step)=@_;
                    480:     if ( ! $hidden::RANDOMINIT ) {
                    481: 	if ($external::randomseed == 0) { $external::randomseed=1; }
                    482: 	if ($external::randomseed =~/,/) {
1.84      albertel  483: 	    my ($num1,$num2)=split(/,/,$external::randomseed);
                    484: 	    &random_set_seed(1,abs($num1));
                    485: 	} elsif ($external::randomseed =~/:/) {
                    486: 	    my ($num1,$num2)=split(/:/,$external::randomseed);
1.61      albertel  487: 	    &random_set_seed(abs($num1),abs($num2));
                    488: 	} else {
                    489: 	    &random_set_seed(1,int(abs($external::randomseed)));
                    490: 	}
                    491: 	&math_random_uniform();
                    492: 	$hidden::RANDOMINIT=1;
                    493:     }
                    494:     if (!defined($step)) { $step=1; }
                    495:     my $num=1+int(($end-$start)/$step);
                    496:     my $result=$start + int(&math_random_uniform() * $num)*$step;
                    497:     return $result;
1.1       harris41  498: }
                    499: 
1.26      ng        500: sub random_normal {
1.73      albertel  501:     my ($item_cnt,$seed,$av,$std_dev) = @_;
                    502:     my @oldseed=&random_get_seed();
                    503:     my @retArray;
                    504:     &random_set_seed_from_phrase($seed);
                    505:     @retArray=&math_random_normal($item_cnt,$av,$std_dev);
                    506:     &random_set_seed(@oldseed);
                    507:     return @retArray;
1.26      ng        508: }
                    509: 
                    510: sub random_beta {
1.73      albertel  511:     my ($item_cnt,$seed,$aa,$bb) = @_;
                    512:     my @oldseed=&random_get_seed();
                    513:     my @retArray;
                    514:     &random_set_seed_from_phrase($seed);
                    515:     @retArray=&math_random_beta($item_cnt,$aa,$bb);
                    516:     &random_set_seed(@oldseed);
                    517:     return @retArray;
1.26      ng        518: }
                    519: 
                    520: sub random_gamma {
1.73      albertel  521:     my ($item_cnt,$seed,$a,$r) = @_;
                    522:     my @oldseed=&random_get_seed();
                    523:     my @retArray;
                    524:     &random_set_seed_from_phrase($seed);
                    525:     @retArray=&math_random_gamma($item_cnt,$a,$r);
                    526:     &random_set_seed(@oldseed);
                    527:     return @retArray;
1.26      ng        528: }
                    529: 
                    530: sub random_exponential {
1.73      albertel  531:     my ($item_cnt,$seed,$av) = @_;
                    532:     my @oldseed=&random_get_seed();
                    533:     my @retArray;
                    534:     &random_set_seed_from_phrase($seed);
                    535:     @retArray=&math_random_exponential($item_cnt,$av);
                    536:     &random_set_seed(@oldseed);
                    537:     return @retArray;
1.26      ng        538: }
                    539: 
                    540: sub random_poisson {
1.73      albertel  541:     my ($item_cnt,$seed,$mu) = @_;
                    542:     my @oldseed=&random_get_seed();
                    543:     my @retArray;
                    544:     &random_set_seed_from_phrase($seed);
                    545:     @retArray=&math_random_poisson($item_cnt,$mu);
                    546:     &random_set_seed(@oldseed);
                    547:     return @retArray;
1.26      ng        548: }
                    549: 
                    550: sub random_chi {
1.73      albertel  551:     my ($item_cnt,$seed,$df) = @_;
                    552:     my @oldseed=&random_get_seed();
                    553:     my @retArray;
                    554:     &random_set_seed_from_phrase($seed);
                    555:     @retArray=&math_random_chi_square($item_cnt,$df);
                    556:     &random_set_seed(@oldseed);
                    557:     return @retArray;
1.26      ng        558: }
                    559: 
                    560: sub random_noncentral_chi {
1.73      albertel  561:     my ($item_cnt,$seed,$df,$nonc) = @_;
                    562:     my @oldseed=&random_get_seed();
                    563:     my @retArray;
                    564:     &random_set_seed_from_phrase($seed);
                    565:     @retArray=&math_random_noncentral_chi_square($item_cnt,$df,$nonc);
                    566:     &random_set_seed(@oldseed);
                    567:     return @retArray;
1.26      ng        568: }
                    569: 
                    570: sub random_f {
1.73      albertel  571:     my ($item_cnt,$seed,$dfn,$dfd) = @_;
                    572:     my @oldseed=&random_get_seed();
                    573:     my @retArray;
                    574:     &random_set_seed_from_phrase($seed);
                    575:     @retArray=&math_random_f($item_cnt,$dfn,$dfd);
                    576:     &random_set_seed(@oldseed);
                    577:     return @retArray;
1.26      ng        578: }
                    579: 
                    580: sub random_noncentral_f {
1.73      albertel  581:     my ($item_cnt,$seed,$dfn,$dfd,$nonc) = @_;
                    582:     my @oldseed=&random_get_seed();
                    583:     my @retArray;
                    584:     &random_set_seed_from_phrase($seed);
                    585:     @retArray=&math_random_noncentral_f($item_cnt,$dfn,$dfd,$nonc);
                    586:     &random_set_seed(@oldseed);
                    587:     return @retArray;
1.26      ng        588: }
                    589: 
                    590: sub random_multivariate_normal {
1.73      albertel  591:     my ($item_cnt,$seed,$mean,$covar) = @_;
                    592:     my @oldseed=&random_get_seed();
                    593:     &random_set_seed_from_phrase($seed);
1.87      albertel  594:     my @retArray=&math_random_multivariate_normal($item_cnt,@$mean,@$covar);
1.73      albertel  595:     &random_set_seed(@oldseed);
                    596:     return @retArray;
1.26      ng        597: }
                    598: 
                    599: sub random_multinomial {
1.73      albertel  600:     my ($item_cnt,$seed,@p) = @_;
                    601:     my @oldseed=&random_get_seed();
                    602:     my @retArray;
                    603:     &random_set_seed_from_phrase($seed);
1.87      albertel  604:     my @retArray=&math_random_multinomial($item_cnt,@p);
1.73      albertel  605:     &random_set_seed(@oldseed);
                    606:     return @retArray;
1.26      ng        607: }
                    608: 
                    609: sub random_permutation {
1.73      albertel  610:     my ($seed,@inArray) = @_;
                    611:     my @oldseed=&random_get_seed();
                    612:     my @retArray;
                    613:     &random_set_seed_from_phrase($seed);
                    614:     @retArray=&math_random_permutation(@inArray);
                    615:     &random_set_seed(@oldseed);
                    616:     return @retArray;
1.26      ng        617: }
                    618: 
                    619: sub random_uniform {
1.73      albertel  620:     my ($item_cnt,$seed,$low,$high) = @_;
                    621:     my @oldseed=&random_get_seed();
                    622:     my @retArray;
                    623:     &random_set_seed_from_phrase($seed);
                    624:     @retArray=&math_random_uniform($item_cnt,$low,$high);
                    625:     &random_set_seed(@oldseed);
                    626:     return @retArray;
1.26      ng        627: }
                    628: 
                    629: sub random_uniform_integer {
1.73      albertel  630:     my ($item_cnt,$seed,$low,$high) = @_;
                    631:     my @oldseed=&random_get_seed();
                    632:     my @retArray;
                    633:     &random_set_seed_from_phrase($seed);
                    634:     @retArray=&math_random_uniform_integer($item_cnt,$low,$high);
                    635:     &random_set_seed(@oldseed);
                    636:     return @retArray;
1.26      ng        637: }
                    638: 
                    639: sub random_binomial {
1.73      albertel  640:     my ($item_cnt,$seed,$nt,$p) = @_;
                    641:     my @oldseed=&random_get_seed();
                    642:     my @retArray;
                    643:     &random_set_seed_from_phrase($seed);
                    644:     @retArray=&math_random_binomial($item_cnt,$nt,$p);
                    645:     &random_set_seed(@oldseed);
                    646:     return @retArray;
1.26      ng        647: }
                    648: 
                    649: sub random_negative_binomial {
1.73      albertel  650:     my ($item_cnt,$seed,$ne,$p) = @_;
                    651:     my @oldseed=&random_get_seed();
                    652:     my @retArray;
                    653:     &random_set_seed_from_phrase($seed);
                    654:     @retArray=&math_random_negative_binomial($item_cnt,$ne,$p);
                    655:     &random_set_seed(@oldseed);
                    656:     return @retArray;
1.26      ng        657: }
                    658: 
1.103     albertel  659: sub abs { CORE::abs(shift) }
                    660: sub sin { CORE::sin(shift) }
                    661: sub cos { CORE::cos(shift) }
                    662: sub exp { CORE::exp(shift) }
                    663: sub int { CORE::int(shift) }
                    664: sub log { CORE::log(shift) }
                    665: sub atan2 { CORE::atan2($_[0],$_[1]) }
                    666: sub sqrt { CORE::sqrt(shift) }
1.23      ng        667: 
1.59      albertel  668: sub tan  { CORE::sin($_[0]) / CORE::cos($_[0]) }
1.21      harris41  669: #sub atan { atan2($_[0], 1); }
                    670: #sub acos { atan2(sqrt(1 - $_[0] * $_[0]), $_[0] ); }
                    671: #sub asin { atan2($_[0], sqrt(1- $_[0] * $_[0]) );  }
1.22      ng        672: 
1.59      albertel  673: sub log10 { CORE::log($_[0])/CORE::log(10); }
1.22      ng        674: 
1.20      harris41  675: sub factorial {
1.59      albertel  676:     my $input = CORE::int(shift);
1.20      harris41  677:     return "Error - unable to take factorial of an negative number ($input)" if $input < 0;
                    678:     return "Error - factorial result is greater than system limit ($input)" if $input > 170;
                    679:     return 1 if $input == 0;
                    680:     my $result = 1; 
                    681:     for (my $i=2; $i<=$input; $i++) { $result *= $i }
                    682:     return $result;
                    683: }
                    684: 
                    685: sub sgn {
                    686:     return -1 if $_[0] < 0;
                    687:     return 0 if $_[0] == 0;
                    688:     return 1 if $_[0] > 0;
                    689: }
                    690: 
                    691: sub min {
                    692:     my @sorted = sort { $a <=> $b || $a cmp $b } @_;
                    693:     return shift @sorted;
                    694: }
                    695: 
                    696: sub max {
                    697:     my @sorted = sort { $a <=> $b || $a cmp $b } @_;
                    698:     return pop @sorted;
                    699: }
1.1       harris41  700: 
1.20      harris41  701: sub roundto {
                    702:     my ($input,$n) = @_;
                    703:     return sprintf('%.'.$n.'f',$input);
                    704: }
                    705: 
                    706: sub to_string {
                    707:     my ($input,$n) = @_;
1.26      ng        708:     return sprintf($input) if $n eq "";
                    709:     $n = '.'.$n if $n !~ /^\./;
1.20      harris41  710:     return sprintf('%'.$n,$input) if $n ne "";
                    711: }
                    712: 
                    713: sub sub_string {
                    714:     my ($str,$start,$len) = @_;
                    715:     return substr($str,$start-1,$len);
                    716: }
1.1       harris41  717: 
                    718: sub pow   {return $_[0] ** $_[1]; }
1.59      albertel  719: sub ceil  {return (($_[0]-CORE::int($_[0]))== 0.0) ? $_[0] : (($_[0] > 0) ? (CORE::int($_[0])+ 1) : CORE::int($_[0])); }
                    720: sub floor  {return (($_[0]-CORE::int($_[0]))== 0.0) ? $_[0] : (($_[0] > 0) ? CORE::int($_[0]) : (CORE::int($_[0])-1)); }
1.27      ng        721: #sub floor {return int($_[0]); }
1.1       harris41  722: 
1.2       albertel  723: sub format {
1.73      albertel  724:     my ($value,$fmt)=@_;
1.81      albertel  725:     my ($dollarmode,$commamode,$alwaysperiod,$options);
                    726:     if ($fmt =~ /^([^\d]*)(.*)/) { $options=$1; $fmt=$2; } 
                    727:     #if ($options =~ /\$/) { $dollamode=1; }
                    728:     #if ($options =~ /,/)  { $commamode=1; }
1.82      albertel  729:     if ($options =~ /\./) { $alwaysperiod=1; }
1.99      ng        730:     my $result;
1.97      albertel  731:     if ($fmt=~/s$/i) {
                    732: 	$result=&format_significant_figures($value,$fmt);
                    733:     } else {
                    734: 	$fmt=~s/e/E/g;
1.99      ng        735: 	$result=sprintf('%.'.$fmt,$value);
1.97      albertel  736: 	if ($alwaysperiod && $fmt eq '0f') { $result .='.'; }
                    737: 	$result=~s/(E[+-]*)0/$1/;
                    738:     }
1.81      albertel  739:     #if ($dollarmode) {$result=&dollarformat($result);}
                    740:     #if ($commamode) {$result=&commaformat($result);}
1.73      albertel  741:     return $result;
1.46      albertel  742: }
                    743: 
1.75      albertel  744: sub chemparse {
                    745:     my ($reaction) = @_;
1.96      albertel  746:     my @tokens = split(/(\s\+|\->|<=>|<\-|\.)/,$reaction);
1.75      albertel  747:     my $formula = '';
                    748:     foreach my $token (@tokens) {
                    749: 	if ($token eq '->' ) {
                    750: 	    $formula .= '<m>\ensuremath{\rightarrow}</m> ';
                    751: 	    next;
                    752: 	}
1.96      albertel  753: 	if ($token eq '<-' ) {
                    754: 	    $formula .= '<m>\ensuremath{\leftarrow}</m> ';
                    755: 	    next;
                    756: 	}  
1.75      albertel  757: 	if ($token eq '<=>') {
                    758: 	    if ($external::target eq 'web' &&
                    759: 		&EXT('request.browser.unicode')) {
1.76      albertel  760: 		$formula .= '&#8652; ';
1.75      albertel  761: 	    } else {
                    762: 		$formula .= &web('<=> ','<m>\ensuremath{\rightleftharpoons}</m> ',
1.95      albertel  763: 				 '&lt;=&gt; ');
1.75      albertel  764: 	    }
                    765: 	    next;
                    766: 	}
1.96      albertel  767: 	if ($token eq '.') {
                    768: 	  $formula =~ s/(\&nbsp\;| )$//;
                    769: 	  $formula .= '&middot;';
                    770: 	  next;
                    771: 	}
                    772: 	$token =~ /^\s*([\d|\/]*(?:&frac\d\d)?)(.*)/;
1.90      albertel  773:         $formula .= $1 if ($1 ne '1');  # stoichiometric coefficient
1.75      albertel  774: 	
                    775: 	my $molecule = $2;
                    776: 	# subscripts
1.78      albertel  777: 	$molecule =~ s|(?<=[a-zA-Z\)\]\s])(\d+)|<sub>$1</sub>|g;
1.75      albertel  778: 	# superscripts
                    779: 	$molecule =~ s|\^(\d*[+\-]*)|<sup>$1</sup>|g;
                    780: 	# strip whitespace
                    781: 	$molecule =~ s/\s*//g;
                    782: 	# forced space
                    783: 	$molecule =~ s/_/ /g;
1.96      albertel  784: 	$molecule =~ s/-/&minus;/g;
1.75      albertel  785: 	$formula .= $molecule.'&nbsp;';
                    786:     }
                    787:     # get rid of trailing space
1.87      albertel  788:     $formula =~ s/(\&nbsp\;| )$//;
1.75      albertel  789:     return &xmlparse($formula);
                    790: }
                    791: 
1.46      albertel  792: sub prettyprint {
1.73      albertel  793:     my ($value,$fmt,$target)=@_;
                    794:     my $result;
                    795:     if (!$target) { $target = $external::target; }
1.75      albertel  796:     if ($fmt =~ /chem/i) { return(&chemparse($value)); }
1.81      albertel  797:     my ($dollarmode,$commamode,$alwaysperiod,$options);
                    798:     if ($fmt =~ /^([^\d]*)(.*)/) { $options=$1; $fmt=$2; } 
1.86      albertel  799:     if ($options =~ /\$/) { $dollarmode=1; }
1.81      albertel  800:     if ($options =~ /,/)  { $commamode=1; }
                    801:     if ($options =~ /\./) { $alwaysperiod=1; }
1.97      albertel  802:     if ($fmt=~/s$/i) {
                    803: 	$value=&format_significant_figures($value,$fmt);
                    804:     } elsif ($fmt) {
                    805: 	$value=sprintf('%.'.$fmt,$value);
                    806:     }
1.81      albertel  807:     if ($alwaysperiod && $fmt eq '0f') {
                    808: 	if ($target eq 'tex') {
                    809: 	    $value .='\\ensuremath{.}';
                    810: 	} else {
                    811: 	    $value .='.';
                    812: 	}
                    813:     }
1.73      albertel  814:     if ($value =~ /([0-9\.\-\+]+)E([0-9\-\+]+)/i ) {
                    815: 	my $frac=$1;
                    816: 	if ($dollarmode) { $frac=&dollarformat($frac); }
1.80      albertel  817: 	if ($commamode) { $frac=&commaformat($frac); }
1.73      albertel  818: 	my $exponent=$2;
                    819: 	$exponent=~s/^\+0*//;
                    820: 	$exponent=~s/^-0*/-/;
                    821: 	$exponent=~s/^-0*/-/;
                    822: 	if ($exponent eq '-') { undef($exponent); }
                    823: 	if ($exponent) {
                    824: 	    if ($target eq 'web') {
                    825: 		$result=$frac.'&#215;10<sup>'.$exponent.'</sup>';
                    826: 	    } elsif ($target eq 'tex') {
                    827: 		$result='\ensuremath{'.$frac.'\times 10^{'.$exponent.'}}';
                    828: 	    } else {
                    829: 		$result=$value;
                    830: 	    }
                    831: 	} else {
                    832: 	    $result=$frac;
                    833: 	}
                    834:     } else {
1.48      albertel  835: 	$result=$value;
1.86      albertel  836: 	if    ($dollarmode) { $result=&dollarformat($result,$target); }
                    837: 	elsif ($commamode)  { $result=&commaformat($result,$target); }
1.46      albertel  838:     }
1.73      albertel  839:     return $result;
1.48      albertel  840: }
                    841: 
1.80      albertel  842: sub commaformat {
1.73      albertel  843:     my ($number,$target) = @_;
                    844:     if ($number =~ /\./) {
1.102     albertel  845: 	while ($number =~ /([^0-9]*)([0-9]+)([^\.,][^\.,][^\.,])([,0-9]*\.[0-9]*)$/) {
                    846: 	    $number = $1.$2.','.$3.$4;
1.73      albertel  847: 	}
                    848:     } else {
1.102     albertel  849: 	while ($number =~ /^([^0-9]*)([0-9]+)([^,][^,][^,])([,0-9]*)$/) {
                    850: 	    $number = $1.$2.','.$3.$4;
1.73      albertel  851: 	}
                    852:     }
1.80      albertel  853:     return $number;
                    854: }
                    855: 
                    856: sub dollarformat {
                    857:     my ($number,$target) = @_;
                    858:     if (!$target) { $target = $external::target; }
                    859:     $number=&commaformat($number,$target);
1.73      albertel  860:     if ($target eq 'tex') {
                    861: 	$number='\$'.$number; #' stupid emacs
                    862:     } else {
                    863: 	$number='$'.$number; #' stupid emacs
                    864:     }
                    865:     return $number; 
1.2       albertel  866: }
1.5       albertel  867: 
1.97      albertel  868: # format of form ns or nS where n is an integer
                    869: sub format_significant_figures {
                    870:     my ($number,$format) = @_; 
                    871:     return '0' if ($number == 0);
                    872:     # extract number of significant figures needed
                    873:     my ($sig) = ($format =~ /(\d+)s/i);
                    874:     # arbitrary choice - suggestions ?? or throw error message?
                    875:     $sig = 3 if ($sig eq '');
                    876:     # save the minus sign
                    877:     my $sign = ($number < 0) ? '-' : '';
                    878:     $number = abs($number);
                    879:     # needed to correct for a number greater than 1 (or
                    880:     my $power = ($number < 1) ? 0 : 1;
                    881:     # could round up. Take the integer part of log10.
                    882:     my $x10 = int(log($number)/log(10));
                    883:     # find number with values left of decimal pt = # of sign figs.
                    884:     my $xsig = $number*10**($sig-$x10-$power);
                    885:     # get just digits left of decimal pt - also rounds off correctly
                    886:     my $xint  = sprintf('%.0f',$xsig);
                    887:     # save any trailing zero's
                    888:     my ($zeros) = ($xint =~ /(0+)$/);
                    889:     # return number to original magnitude
                    890:     my $numSig = $xint*10**($x10-$sig+$power);
                    891:     # insert trailing zero's if have decimal point
                    892:     $numSig =~ s/^(\d+)\.(\d+)(\e?(.*)?)$/$1\.$2$zeros$3/;
1.98      albertel  893:     # put a decimal pt for number ending with 0 and length = # of sig fig
                    894:     $numSig.='.' if (length($numSig) == $sig && $numSig =~ /0$/);
                    895:     if (length($numSig) < $sig) {
                    896: 	$numSig.='.'.substr($zeros,0,($sig-length($numSig)));
                    897:     }
1.97      albertel  898:     # return number with sign
                    899:     return $sign.$numSig;
                    900: 
                    901: }
                    902: 
1.5       albertel  903: sub map {
1.27      ng        904:     my ($phrase,$dest,$source)=@_;
1.51      albertel  905:     my @oldseed=&random_get_seed();
1.27      ng        906:     my @seed = &random_seed_from_phrase($phrase);
                    907:     &random_set_seed(@seed);
                    908:     my $destct = scalar(@$dest);
1.28      ng        909:     if (!$source) {
                    910: 	my @output;
                    911: 	my @idx = &math_random_permuted_index($destct);
                    912: 	my $ctr = 0;
                    913: 	while ($ctr < $destct) {
                    914: 	    $output[$ctr] = $$dest[$idx[$ctr]];
1.27      ng        915: 	    $ctr++;
1.28      ng        916: 	}
1.51      albertel  917:         &random_set_seed(@oldseed);
1.28      ng        918: 	return @output;
1.27      ng        919:     } else {
1.28      ng        920: 	my $num = scalar(@$source);
                    921: 	my @idx = &math_random_permuted_index($num);
                    922: 	my $ctr = 0;
                    923: 	my $tot = $num;
                    924: 	$tot = $destct if $destct < $num;
                    925: 	if (ref($$dest[0])) {
                    926: 	    while ($ctr < $tot) {
                    927: 		${$$dest[$ctr]} = $$source[$idx[$ctr]];
                    928: 	        $ctr++;
                    929:             }
                    930:         } else {
                    931: 	    while ($ctr < $tot) {
                    932: 		$$dest[$ctr] = $$source[$idx[$ctr]];
                    933: 		$ctr++;
                    934: 	    }
                    935: 	}
1.27      ng        936:     }
1.56      albertel  937:     &random_set_seed(@oldseed);
1.51      albertel  938:     return '';
1.27      ng        939: }
                    940: 
                    941: sub rmap {
                    942:     my ($phrase,$dest,$source)=@_;
1.51      albertel  943:     my @oldseed=&random_get_seed();
1.27      ng        944:     my @seed = &random_seed_from_phrase($phrase);
                    945:     &random_set_seed(@seed);
                    946:     my $destct = scalar(@$dest);
1.28      ng        947:     if (!$source) {
                    948: 	my @idx = &math_random_permuted_index($destct);
                    949: 	my $ctr = 0;
                    950: 	my @r_idx;
                    951: 	while ($ctr < $destct) {
                    952: 	    $r_idx[$idx[$ctr]] = $ctr;
                    953: 	    $ctr++;
                    954: 	}
                    955: 	my @output;
                    956: 	$ctr = 0;
                    957: 	while ($ctr < $destct) {
                    958: 	    $output[$ctr] = $$dest[$r_idx[$ctr]];
1.27      ng        959: 	    $ctr++;
1.28      ng        960: 	}
1.51      albertel  961:         &random_set_seed(@oldseed);
1.28      ng        962: 	return @output;
1.27      ng        963:     } else {
1.28      ng        964: 	my $num = scalar(@$source);
                    965: 	my @idx = &math_random_permuted_index($num);
                    966: 	my $ctr = 0;
                    967: 	my $tot = $num;
                    968: 	$tot = $destct if $destct < $num;
                    969: 	my @r_idx;
1.27      ng        970: 	while ($ctr < $tot) {
1.28      ng        971: 	    $r_idx[$idx[$ctr]] = $ctr;
1.27      ng        972: 	    $ctr++;
1.28      ng        973: 	}
                    974: 	$ctr = 0;
                    975: 	if (ref($$dest[0])) {
                    976: 	    while ($ctr < $tot) {
                    977: 		${$$dest[$ctr]} = $$source[$r_idx[$ctr]];
                    978: 	        $ctr++;
                    979:             }
                    980:         } else {
                    981: 	    while ($ctr < $tot) {
                    982: 		$$dest[$ctr] = $$source[$r_idx[$ctr]];
                    983: 		$ctr++;
                    984: 	    }
                    985: 	}
1.6       albertel  986:     }
1.51      albertel  987:     &random_set_seed(@oldseed);
                    988:     return '';
1.5       albertel  989: }
1.22      ng        990: 
1.23      ng        991: sub capa_id { return }
                    992: 
                    993: sub problem { return }
                    994: 
1.22      ng        995: sub name{
1.73      albertel  996:     my $fullname = &EXT('environment.lastname').', '.&EXT('environment.firstname').' '.&EXT('environment.middlename');
                    997:     $fullname = "" if $fullname eq ",  ";
                    998:     $fullname =~ s/\%2d/-/g;
                    999:     return $fullname;
1.22      ng       1000: }
                   1001: 
                   1002: sub student_number { 
1.73      albertel 1003:     my $id = &EXT('environment.id');
                   1004:     $id = '' if $id eq "";
                   1005:     return $id;
1.22      ng       1006: }
                   1007: 
                   1008: sub class {
1.73      albertel 1009:     my $course = &EXT('course.description');
                   1010:     $course = '' if $course eq "";
                   1011:     return $course;
1.22      ng       1012: }
                   1013: 
1.112     www      1014: sub firstname {
                   1015:     my $firstname = &EXT('environment.firstname');
                   1016:     $firstname = '' if $firstname eq "";
                   1017:     return $firstname;
                   1018: }
                   1019:                                                                                 
                   1020: sub lastname {
                   1021:     my $lastname = &EXT('environment.lastname');
                   1022:     $lastname = '' if $lastname eq "";
                   1023:     return $lastname;
                   1024: }
                   1025: 
1.22      ng       1026: sub sec { 
1.73      albertel 1027:     my $sec = &EXT('request.course.sec');
                   1028:     $sec = '' if $sec eq "";
                   1029:     return $sec;
1.22      ng       1030: }
                   1031: 
1.136     www      1032: sub submission {
                   1033:    my ($partid,$responseid,$subnumber)=@_;
                   1034:    my $sub='';
                   1035:    if ($subnumber) { $sub=$subnumber.':'; }
                   1036:    return &EXT('user.resource.'.$sub.'resource.'.$partid.'.'.$responseid.'.submission');
                   1037: }
                   1038: 
                   1039: sub currentpart {
                   1040:    return $external::part;
                   1041: }
                   1042: 
1.135     www      1043: sub eval_time {
                   1044:    my ($timestamp)=@_;
                   1045:    unless ($timestamp) { return ''; }
                   1046:    return &locallocaltime($timestamp);
                   1047: }
                   1048: 
1.23      ng       1049: sub open_date { 
1.134     www      1050:     my ($partid)=@_;
                   1051:     unless ($partid) { $partid=0; }
1.135     www      1052:     return &eval_time(&EXT('resource.'.$partid.'.opendate'));
1.23      ng       1053: }
                   1054: 
1.134     www      1055: sub due_date {
                   1056:     my ($partid)=@_;
                   1057:     unless ($partid) { $partid=0; } 
1.135     www      1058:     return &eval_time(&EXT('resource.'.$partid.'.duedate'));
1.23      ng       1059: }
                   1060: 
                   1061: sub answer_date { 
1.134     www      1062:     my ($partid)=@_;
                   1063:     unless ($partid) { $partid=0; }
1.135     www      1064:     return &eval_time(&EXT('resource.'.$partid.'.answerdate'));
1.24      ng       1065: }
                   1066: 
1.136     www      1067: sub open_date_epoch {
                   1068:     my ($partid)=@_;
                   1069:     unless ($partid) { $partid=0; }
                   1070:     return &EXT('resource.'.$partid.'.opendate');
                   1071: }
                   1072: 
                   1073: sub due_date_epoch {
                   1074:     my ($partid)=@_;
                   1075:     unless ($partid) { $partid=0; }
                   1076:     return &EXT('resource.'.$partid.'.duedate');
                   1077: }
                   1078: 
                   1079: sub answer_date_epoch {
                   1080:     my ($partid)=@_;
                   1081:     unless ($partid) { $partid=0; }
                   1082:     return &EXT('resource.'.$partid.'.answerdate');
                   1083: }
                   1084: 
1.24      ng       1085: sub array_moments {
1.73      albertel 1086:     my @input=@_;
                   1087:     my (@output,$N);
                   1088:     $N=scalar (@input);
                   1089:     $output[0]=$N;
                   1090:     if ($N <= 1) {
                   1091: 	$output[1]=$input[0];
                   1092: 	$output[1]="Input array not defined" if ($N == 0);
                   1093: 	$output[2]="variance undefined for N<=1";
                   1094: 	$output[3]="skewness undefined for N<=1";
                   1095: 	$output[4]="kurtosis undefined for N<=1";
                   1096: 	return @output;
                   1097:     }
                   1098:     my $sum=0;
                   1099:     foreach my $line (@input) {
                   1100: 	$sum+=$line;
                   1101:     }
                   1102:     $output[1] = $sum/$N;
                   1103:     my ($x,$sdev,$var,$skew,$kurt) = 0;
                   1104:     foreach my $line (@input) {
                   1105: 	$x=$line-$output[1];
                   1106: 	$var+=$x**2;
                   1107: 	$skew+=$x**3;
                   1108: 	$kurt+=$x**4;
                   1109:     }
                   1110:     $output[2]=$var/($N-1);
                   1111:     $sdev=CORE::sqrt($output[2]);
                   1112:     if ($sdev == 0) {
                   1113: 	$output[3]="inf-variance=0";
                   1114: 	$output[4]="inf-variance=0";
                   1115: 	return @output;
                   1116:     }
                   1117:     $output[3]=$skew/($sdev**3*$N);
                   1118:     $output[4]=$kurt/($sdev**4*$N)-3;
1.24      ng       1119:     return @output;
                   1120: }
1.5       albertel 1121: 
                   1122: sub choose {
1.73      albertel 1123:     my $num = $_[0];
                   1124:     return $_[$num];
1.5       albertel 1125: }
1.23      ng       1126: 
1.101     albertel 1127: #&sum1(1,$x,sub { &sum1($_[0],2*$_[0], sub { fact($_[0])**2 })});
                   1128: #sub sum1 {
                   1129: #    my ($start,$end,$sub)=@_;
                   1130: #    my $sum=0;
                   1131: #    for (my $i=$start;$i<=$end;$i++) {
                   1132: #        $sum+=&$sub($i);
                   1133: #    }
                   1134: #    return $sum
                   1135: #}
                   1136: 
                   1137: #&sum2('a',1,$x,'&sum2(\'b\',$a,2*$a, \'&factorial($b)**2\')');
                   1138: #sub sum2 {
                   1139: #    my ($varname,$start,$end,$line)=@_;
                   1140: #    my $sum=0;
                   1141: #    for (my $i=$start;$i<=$end;$i++) {
                   1142: #	my $func=sub {
                   1143: #	    eval("\$".$varname."=$i");
                   1144: #	    eval($line);
                   1145: #	};
                   1146: #        $sum+=&$func($i);
                   1147: #    }
                   1148: #    return $sum
                   1149: #}
                   1150: 
1.49      albertel 1151: # expiremental idea
                   1152: sub proper_path {
1.73      albertel 1153:     my ($path)=@_;
                   1154:     if ( $external::target eq "tex" ) {
                   1155: 	return '/home/httpd/html'.$path;
                   1156:     } else {
                   1157: 	return $path;
                   1158:     }
1.49      albertel 1159: }
1.23      ng       1160: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.