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

1.25      albertel    1: # file name (temp): default_homework
1.1       harris41    2: # used by lonxml::xmlparse() as input variable $safeinit to Apache::run::run()
1.20      harris41    3: #
                      4: # Guy Albertelli
                      5: #
                      6: # 05/25/2001 H. K. Ng
1.24      ng          7: # 05/31/2001 H. K. Ng
1.20      harris41    8: #
1.25      albertel    9: #init some globals
1.3       albertel   10: $RANDOMINIT=0;
1.22      ng         11: $pi=atan2(1,1)*4;
                     12: $rad2deg=180.0/$pi;
                     13: $deg2rad=$pi/180.0;
1.3       albertel   14: 
1.7       albertel   15: sub caparesponse_check {
1.36    ! albertel   16:   #not properly used yet: calc
        !            17:   #not to be used: $ans_fmt
        !            18:   my ($answer,$type,$tol,$sig,$ans_fmt,$unit,$calc) = 
        !            19: 	eval $_[1].';return ($answer,$type,$tol,$sig,$ans_fmt,$unit,$calc);';
        !            20: 
1.10      albertel   21:   my $tol_type=''; # gets it's value from whether tol has a % or not done
1.19      albertel   22:   my $sig_lbound=''; #done
                     23:   my $sig_ubound=''; #done
1.7       albertel   24:   my ($response,$expr)=@_;
1.31      albertel   25: 
1.32      albertel   26: 
1.8       albertel   27:   #type's definitons come from capaParser.h
1.31      albertel   28:   my $message='';
1.32      albertel   29:   #remove leading and trailing whitespace
                     30:   if ($response=~ /^\s|\s$/) {
                     31:     $response=~ s:^\s+|\s+$::g;
                     32:     $message .="Removed ws now :$response:<br />";
                     33:   } else {
                     34:     $message .="no ws in :$response:<br />";
                     35:   }
                     36: 
1.8       albertel   37:   if ($type eq '' ) {
1.31      albertel   38:     $message .= "Didn't find a type :$type:$expr: defaulting<br />";
1.8       albertel   39:     if ( $answer eq ($answer *1.0)) { $type = 2;
                     40:     } else { $type = 3; }
                     41:   } else {
                     42:          if ($type eq 'cs')    { $type = 4;
                     43:     } elsif ($type eq 'ci')    { $type = 3;
                     44:     } elsif ($type eq 'mc')    { $type = 5;
                     45:     } elsif ($type eq 'fml')   { $type = 8;
1.9       albertel   46:     } elsif ($type eq 'subj')  { $type = 7;
                     47:     } else { return "ERROR: Unknown type of answer: $type" }
1.8       albertel   48:   }
                     49: 
1.10      albertel   50:   if ($tol eq '') {
                     51:     $tol=0.0;
                     52:     $tol_type=1; #TOL_ABSOLUTE
                     53:   } else {
                     54:     if ($tol =~ /%$/) {
1.12      albertel   55:       chop $tol;
1.10      albertel   56:       $tol_type=2; #TOL_PERCENTAGE
                     57:     } else {
                     58:       $tol_type=1; #TOL_ABSOLUTE
                     59:     }
                     60:   }
1.12      albertel   61: 
                     62:   if ($sig eq '') {
                     63:     $sig_lbound = 0; #SIG_LB_DEFAULT
                     64:     $sig_ubound =15; #SIG_UB_DEFAULT
                     65:   } else {
                     66:     ($sig_lbound,$sig_ubound) = split /,/,$sig;
                     67:   }
1.7       albertel   68:   my $result = &caparesponse_capa_check_answer($response,$answer,$type,
1.10      albertel   69: 					       $tol_type,$tol,
1.7       albertel   70: 					       $sig_lbound,$sig_ubound,
1.29      albertel   71: 					       $ans_fmt,$unit,$calc);
1.9       albertel   72: 
                     73:   if    ($result == '1') { $result='EXACT_ANS'; } 
                     74:   elsif ($result == '2') { $result='APPROX_ANS'; }
                     75:   elsif ($result == '3') { $result='SIG_FAIL'; }
                     76:   elsif ($result == '4') { $result='UNIT_FAIL'; }
                     77:   elsif ($result == '5') { $result='NO_UNIT'; }
                     78:   elsif ($result == '6') { $result='UNIT_OK'; }
                     79:   elsif ($result == '7') { $result='INCORRECT'; }
                     80:   elsif ($result == '8') { $result='UNIT_NOTNEEDED'; }
                     81:   elsif ($result == '9') { $result='ANS_CNT_NOT_MATCH'; }
                     82:   elsif ($result =='10') { $result='SUB_RECORDED'; }
                     83:   elsif ($result =='11') { $result='BAD_FORMULA'; }
                     84:   elsif ($result =='12') { $result='WANTED_NUMERIC'; }
1.13      albertel   85:   else  {$result = "ERROR: Unknown Result:$result:$@:";}
1.9       albertel   86: 
1.36    ! albertel   87:   return "$result:<br />Error $error:<br />Answer $answer:<br />Response $response:<br /> type-$type|$tol|$tol_type|$sig:$sig_lbound:$sig_ubound|$unit|<br />$message$expr";
1.14      albertel   88: }
                     89: 
                     90: sub caparesponse_check_list {
                     91:   my ($response,$expr)=@_;
1.30      albertel   92:   # do these first, because who knows what varname the instructor might have used
                     93:   # but it probably isn't $CAPARESPONSE_CHECK_LIST_answer
                     94:   my $CAPARESPONSE_CHECK_LIST_answer = eval $expr.';return $answer';
                     95:   my (@list) = eval $CAPARESPONSE_CHECK_LIST_answer;
1.14      albertel   96:   my $result='';
1.31      albertel   97:   $result.="error:$@:<br />";
                     98:   # if the eval fails just use what is in the answer exactly
                     99:   if (!defined(@list) || !defined($list[0])) {
                    100:     $result.="list zero is undefined<br />";
                    101:     $list[0]=$CAPARESPONSE_CHECK_LIST_answer;
                    102:   }
1.15      albertel  103:   my $aresult='';
1.14      albertel  104:   my $current_answer;
1.31      albertel  105:   $result.="Got response :$CAPARESPONSE_CHECK_LIST_answer:$list[0]:<br />";
                    106:   my @responselist;
1.32      albertel  107:   my $type =eval $expr.';return $answer;';
1.31      albertel  108:   if ($type ne '' && $#list > 0) {
                    109:     (@responselist)=split /,/,$response;
                    110:   } else {
                    111:     (@responselist)=($response);
                    112:   }
1.15      albertel  113:   my $unit='';
1.31      albertel  114:   $result.="Initial final response :$responselist['-1']:<br />";
                    115:   if ($type eq '') {
                    116:     #for numerical problems split off the unit
                    117:     if ( $responselist['-1']=~ /(.*[^\s])\s+([^\s]+)/ ) {
                    118:       $responselist['-1']=$1;
                    119:       $unit=$2;
                    120:     }
1.15      albertel  121:   }
1.31      albertel  122:   $result.="Final final response :$responselist['-1']:<br />";
                    123:   $result.=":$#list: answers<br />";
1.14      albertel  124:   $unit=~s/\s//;
                    125:   my $i=0;
                    126:   my $awards='';
                    127:   for ($i=0; $i<@list;$i++) {
1.31      albertel  128:     $result.="trying answer :$list[$i]:<br />";
1.19      albertel  129:     if ($unit eq '') {
                    130:       $aresult=&caparesponse_check($responselist[$i],
1.31      albertel  131: 			     $expr.';my $answer=\''.$list[$i].'\';');
1.19      albertel  132:     } else {
                    133:       $aresult=&caparesponse_check($responselist[$i]." $unit",
1.31      albertel  134: 				   $expr.';my $answer=\''.$list[$i].'\';');
1.19      albertel  135:     }
1.15      albertel  136:     my ($temp)=split /:/, $aresult;
1.14      albertel  137:     $awards.="$temp,";
1.15      albertel  138:     $result.=$aresult;
1.14      albertel  139:   }
                    140:   chop $awards;
1.17      albertel  141:   return "$awards:<br />$result";
1.7       albertel  142: }
                    143: 
1.4       albertel  144: sub tex {
                    145:   if ( $external::target eq "tex" ) {
                    146:     return @_[0];
                    147:   } else {
                    148:     return @_[1];
                    149:   }
                    150: }
                    151: 
1.24      ng        152: sub var_in_tex {
                    153:   if ( $external::target eq "tex" ) {
                    154:     return @_[0];
                    155:   } else {
                    156:     return "";
                    157:   }
                    158: }
                    159: 
1.4       albertel  160: sub web {
                    161:   if ( $external::target eq "tex" ) {
                    162:     return @_[1];
                    163:   } else {
                    164:     if ( $external::target eq "web") {
1.26      ng        165:       return @_[2];
                    166:     } else {
1.4       albertel  167:       return @_[0];
                    168:     }
                    169:   }
                    170: }
                    171: 
1.24      ng        172: sub html {
                    173:   if ( $external::target eq "web" ) {
1.26      ng        174:     return shift;
1.24      ng        175:   }
                    176: }
                    177: 
1.4       albertel  178: sub problem {
1.11      albertel  179:   return '1';
1.4       albertel  180: }
                    181: 
1.1       harris41  182: sub hinton {
                    183:   return 0;
                    184: }
                    185: 
                    186: sub random {
                    187:   my ($start,$end,$step)=@_;
1.3       albertel  188:   if ( ! $RANDOMINIT ) { srand($external::randomseed); $RANDOMINIT=1; }
1.1       harris41  189:   my $num=1+int(($end-$start)/$step);
                    190:   my $result=$start + int(rand() * $num)*$step;
                    191:   return $result;
                    192: }
                    193: 
1.26      ng        194: sub random_normal {
                    195:   my ($item_cnt,$seed,$av,$std_dev) = @_;
                    196:   my @retArray;
                    197:   &random_set_seed_from_phrase($seed);
                    198:   @retArray=&math_random_normal($item_cnt,$av,$std_dev);
                    199:   return @retArray;
                    200: }
                    201: 
                    202: sub random_beta {
                    203:   my ($item_cnt,$seed,$aa,$bb) = @_;
                    204:   my @retArray;
                    205:   &random_set_seed_from_phrase($seed);
                    206:   @retArray=&math_random_beta($item_cnt,$aa,$bb);
                    207:   return @retArray;
                    208: }
                    209: 
                    210: sub random_gamma {
                    211:   my ($item_cnt,$seed,$a,$r) = @_;
                    212:   my @retArray;
                    213:   &random_set_seed_from_phrase($seed);
                    214:   @retArray=&math_random_gamma($item_cnt,$a,$r);
                    215:   return @retArray;
                    216: }
                    217: 
                    218: sub random_exponential {
                    219:   my ($item_cnt,$seed,$av) = @_;
                    220:   my @retArray;
                    221:   &random_set_seed_from_phrase($seed);
                    222:   @retArray=&math_random_exponential($item_cnt,$av);
                    223:   return @retArray;
                    224: }
                    225: 
                    226: sub random_poisson {
                    227:   my ($item_cnt,$seed,$mu) = @_;
                    228:   my @retArray;
                    229:   &random_set_seed_from_phrase($seed);
                    230:   @retArray=&math_random_poisson($item_cnt,$mu);
                    231:   return @retArray;
                    232: }
                    233: 
                    234: sub random_chi {
                    235:   my ($item_cnt,$seed,$df) = @_;
                    236:   my @retArray;
                    237:   &random_set_seed_from_phrase($seed);
                    238:   @retArray=&math_random_chi_square($item_cnt,$df);
                    239:   return @retArray;
                    240: }
                    241: 
                    242: sub random_noncentral_chi {
                    243:   my ($item_cnt,$seed,$df,$nonc) = @_;
                    244:   my @retArray;
                    245:   &random_set_seed_from_phrase($seed);
                    246:   @retArray=&math_random_noncentral_chi_square($item_cnt,$df,$nonc);
                    247:   return @retArray;
                    248: }
                    249: 
                    250: sub random_f {
                    251:   my ($item_cnt,$seed,$dfn,$dfd) = @_;
                    252:   my @retArray;
                    253:   &random_set_seed_from_phrase($seed);
                    254:   @retArray=&math_random_f($item_cnt,$dfn,$dfd);
                    255:   return @retArray;
                    256: }
                    257: 
                    258: sub random_noncentral_f {
                    259:   my ($item_cnt,$seed,$dfn,$dfd,$nonc) = @_;
                    260:   my @retArray;
                    261:   &random_set_seed_from_phrase($seed);
                    262:   @retArray=&math_random_noncentral_f($item_cnt,$dfn,$dfd,$nonc);
                    263:   return @retArray;
                    264: }
                    265: 
                    266: sub random_multivariate_normal {
1.33      ng        267:   my ($item_cnt,$seed,$mean,$covar) = @_;
1.26      ng        268:   &random_set_seed_from_phrase($seed);
1.33      ng        269:   @retArray=&math_random_multivariate_normal($item_cnt,@$mean,@$covar);
1.26      ng        270:   return @retArray;
                    271: }
                    272: 
                    273: sub random_multinomial {
                    274:   my ($item_cnt,$seed,@p) = @_;
                    275:   my @retArray;
                    276:   &random_set_seed_from_phrase($seed);
                    277:   @retArray=&math_random_multinomial($item_cnt,@p);
                    278:   return @retArray;
                    279: }
                    280: 
                    281: sub random_permutation {
                    282:   my ($seed,@inArray) = @_;
                    283:   my @retArray;
                    284:   &random_set_seed_from_phrase($seed);
                    285:   @retArray=&math_random_permutation(@inArray);
                    286:   return @retArray;
                    287: }
                    288: 
                    289: sub random_uniform {
                    290:   my ($item_cnt,$seed,$low,$high) = @_;
                    291:   my @retArray;
                    292:   &random_set_seed_from_phrase($seed);
                    293:   @retArray=&math_random_uniform($item_cnt,$low,$high);
                    294:   return @retArray;
                    295: }
                    296: 
                    297: sub random_uniform_integer {
                    298:   my ($item_cnt,$seed,$low,$high) = @_;
                    299:   my @retArray;
                    300:   &random_set_seed_from_phrase($seed);
                    301:   @retArray=&math_random_uniform_integer($item_cnt,$low,$high);
                    302:   return @retArray;
                    303: }
                    304: 
                    305: sub random_binomial {
                    306:   my ($item_cnt,$seed,$nt,$p) = @_;
                    307:   my @retArray;
                    308:   &random_set_seed_from_phrase($seed);
                    309:   @retArray=&math_random_binomial($item_cnt,$nt,$p);
                    310:   return @retArray;
                    311: }
                    312: 
                    313: sub random_negative_binomial {
                    314:   my ($item_cnt,$seed,$ne,$p) = @_;
                    315:   my @retArray;
                    316:   &random_set_seed_from_phrase($seed);
                    317:   @retArray=&math_random_negative_binomial($item_cnt,$ne,$p);
                    318:   return @retArray;
                    319: }
                    320: 
1.23      ng        321: sub abs { abs(shift) }
                    322: sub sin { sin(shift) }
                    323: sub cos { cos(shift) }
                    324: sub exp { exp(shift) }
                    325: sub int { int(shift) }
                    326: sub log { log(shift) }
                    327: sub atan2 { atan2($_[0],$_[1]) }
                    328: sub sqrt { sqrt(shift) }
                    329: 
1.1       harris41  330: sub tan  { sin($_[0]) / cos($_[0]) }
1.21      harris41  331: #sub atan { atan2($_[0], 1); }
                    332: #sub acos { atan2(sqrt(1 - $_[0] * $_[0]), $_[0] ); }
                    333: #sub asin { atan2($_[0], sqrt(1- $_[0] * $_[0]) );  }
1.22      ng        334: 
1.18      albertel  335: sub log10 { log($_[0])/log(10); }
1.22      ng        336: 
1.20      harris41  337: sub factorial {
                    338:     my $input = int(shift);
                    339:     return "Error - unable to take factorial of an negative number ($input)" if $input < 0;
                    340:     return "Error - factorial result is greater than system limit ($input)" if $input > 170;
                    341:     return 1 if $input == 0;
                    342:     my $result = 1; 
                    343:     for (my $i=2; $i<=$input; $i++) { $result *= $i }
                    344:     return $result;
                    345: }
                    346: 
                    347: sub sgn {
                    348:     return -1 if $_[0] < 0;
                    349:     return 0 if $_[0] == 0;
                    350:     return 1 if $_[0] > 0;
                    351: }
                    352: 
                    353: sub min {
                    354:     my @sorted = sort { $a <=> $b || $a cmp $b } @_;
                    355:     return shift @sorted;
                    356: }
                    357: 
                    358: sub max {
                    359:     my @sorted = sort { $a <=> $b || $a cmp $b } @_;
                    360:     return pop @sorted;
                    361: }
1.1       harris41  362: 
1.20      harris41  363: sub roundto {
                    364:     my ($input,$n) = @_;
                    365:     return sprintf('%.'.$n.'f',$input);
                    366: }
                    367: 
                    368: sub to_string {
                    369:     my ($input,$n) = @_;
1.26      ng        370:     return sprintf($input) if $n eq "";
                    371:     $n = '.'.$n if $n !~ /^\./;
1.20      harris41  372:     return sprintf('%'.$n,$input) if $n ne "";
                    373: }
                    374: 
                    375: sub sub_string {
                    376:     my ($str,$start,$len) = @_;
                    377:     return substr($str,$start-1,$len);
                    378: }
1.1       harris41  379: 
                    380: sub pow   {return $_[0] ** $_[1]; }
1.27      ng        381: sub ceil  {return (($_[0]-int($_[0]))== 0.0) ? $_[0] : (($_[0] > 0) ? (int($_[0])+ 1) : int($_[0])); }
                    382: sub floor  {return (($_[0]-int($_[0]))== 0.0) ? $_[0] : (($_[0] > 0) ? int($_[0]) : (int($_[0])-1)); }
                    383: #sub floor {return int($_[0]); }
1.1       harris41  384: 
1.2       albertel  385: sub format {
                    386:   my ($value,$fmt)=@_;
1.11      albertel  387:   return sprintf('%.'.$fmt,$value);
1.2       albertel  388: }
1.5       albertel  389: 
                    390: sub map {
1.27      ng        391:     my ($phrase,$dest,$source)=@_;
                    392:     my @seed = &random_seed_from_phrase($phrase);
                    393:     &random_set_seed(@seed);
                    394:     my $destct = scalar(@$dest);
1.28      ng        395:     if (!$source) {
                    396: 	my @output;
                    397: 	my @idx = &math_random_permuted_index($destct);
                    398: 	my $ctr = 0;
                    399: 	while ($ctr < $destct) {
                    400: 	    $output[$ctr] = $$dest[$idx[$ctr]];
1.27      ng        401: 	    $ctr++;
1.28      ng        402: 	}
                    403: 	return @output;
1.27      ng        404:     } else {
1.28      ng        405: 	my $num = scalar(@$source);
                    406: 	my @idx = &math_random_permuted_index($num);
                    407: 	my $ctr = 0;
                    408: 	my $tot = $num;
                    409: 	$tot = $destct if $destct < $num;
                    410: 	if (ref($$dest[0])) {
                    411: 	    while ($ctr < $tot) {
                    412: 		${$$dest[$ctr]} = $$source[$idx[$ctr]];
                    413: 	        $ctr++;
                    414:             }
                    415:         } else {
                    416: 	    while ($ctr < $tot) {
                    417: 		$$dest[$ctr] = $$source[$idx[$ctr]];
                    418: 		$ctr++;
                    419: 	    }
                    420: 	}
1.27      ng        421:     }
                    422: }
                    423: 
                    424: sub rmap {
                    425:     my ($phrase,$dest,$source)=@_;
                    426:     my @seed = &random_seed_from_phrase($phrase);
                    427:     &random_set_seed(@seed);
                    428:     my $destct = scalar(@$dest);
1.28      ng        429:     if (!$source) {
                    430: 	my @idx = &math_random_permuted_index($destct);
                    431: 	my $ctr = 0;
                    432: 	my @r_idx;
                    433: 	while ($ctr < $destct) {
                    434: 	    $r_idx[$idx[$ctr]] = $ctr;
                    435: 	    $ctr++;
                    436: 	}
                    437: 	my @output;
                    438: 	$ctr = 0;
                    439: 	while ($ctr < $destct) {
                    440: 	    $output[$ctr] = $$dest[$r_idx[$ctr]];
1.27      ng        441: 	    $ctr++;
1.28      ng        442: 	}
                    443: 	return @output;
1.27      ng        444:     } else {
1.28      ng        445: 	my $num = scalar(@$source);
                    446: 	my @idx = &math_random_permuted_index($num);
                    447: 	my $ctr = 0;
                    448: 	my $tot = $num;
                    449: 	$tot = $destct if $destct < $num;
                    450: 	my @r_idx;
1.27      ng        451: 	while ($ctr < $tot) {
1.28      ng        452: 	    $r_idx[$idx[$ctr]] = $ctr;
1.27      ng        453: 	    $ctr++;
1.28      ng        454: 	}
                    455: 	$ctr = 0;
                    456: 	if (ref($$dest[0])) {
                    457: 	    while ($ctr < $tot) {
                    458: 		${$$dest[$ctr]} = $$source[$r_idx[$ctr]];
                    459: 	        $ctr++;
                    460:             }
                    461:         } else {
                    462: 	    while ($ctr < $tot) {
                    463: 		$$dest[$ctr] = $$source[$r_idx[$ctr]];
                    464: 		$ctr++;
                    465: 	    }
                    466: 	}
1.6       albertel  467:     }
1.5       albertel  468: }
1.22      ng        469: 
1.23      ng        470: sub capa_id { return }
                    471: 
                    472: sub problem { return }
                    473: 
1.22      ng        474: sub name{
                    475:   my $fullname = &EXT('environment.lastname').', '.&EXT('environment.firstname').' '.&EXT('environment.middlename');
                    476:   $fullname = "" if $fullname eq ",  ";
1.26      ng        477:   $fullname =~ s/\%2d/-/g;
1.22      ng        478:   return $fullname;
                    479: }
                    480: 
                    481: sub student_number { 
                    482:   my $id = &EXT('environment.id');
                    483:   $id = '' if $id eq "";
                    484:   return $id;
                    485: }
                    486: 
                    487: sub class {
                    488:   my $course = &EXT('course.description');
                    489:   $course = '' if $course eq "";
                    490:   return $course;
                    491: }
                    492: 
                    493: sub sec { 
                    494:   my $sec = &EXT('request.course.sec');
1.23      ng        495:   $sec = '' if $sec eq "";
1.22      ng        496:   return $sec;
                    497: }
                    498: 
1.23      ng        499: sub open_date { 
                    500:   my @dc = split(/\s+/,localtime(&EXT('resource.0.opendate')));
1.24      ng        501:   return '' if ($dc[0] eq "Wed" and $dc[2] == 31 and $dc[4] == 1969);
                    502:   my @hm = split(/:/,$dc[3]);
                    503:   my $ampm = " am";
                    504:   if ($hm[0] > 12) {
                    505:     $hm[0]-=12;
                    506:     $ampm = " pm";
                    507:   }
                    508:   return $dc[0].', '.$dc[1].' '.$dc[2].', '.$dc[4].' at '.$hm[0].':'.$hm[1].$ampm;
1.23      ng        509: }
                    510: 
                    511: sub due_date { 
                    512:   my @dc = split(/\s+/,localtime(&EXT('resource.0.duedate')));
1.24      ng        513:   return '' if ($dc[0] eq "Wed" and $dc[2] == 31 and $dc[4] == 1969);
                    514:   my @hm = split(/:/,$dc[3]);
                    515:   my $ampm = " am";
                    516:   if ($hm[0] > 12) {
                    517:     $hm[0]-=12;
                    518:     $ampm = " pm";
                    519:   }
                    520:   return $dc[0].', '.$dc[1].' '.$dc[2].', '.$dc[4].' at '.$hm[0].':'.$hm[1].$ampm;
                    521: #  return $dc[0].', '.$dc[1].' '.$dc[2].', '.$dc[4].' at '.$dc[3];
1.23      ng        522: }
                    523: 
                    524: sub answer_date { 
                    525:   my @dc = split(/\s+/,localtime(&EXT('resource.0.answerdate')));
1.24      ng        526:   return '' if ($dc[0] eq "Wed" and $dc[2] == 31 and $dc[4] == 1969);
                    527:   my @hm = split(/:/,$dc[3]);
                    528:   my $ampm = " am";
                    529:   if ($hm[0] > 12) {
                    530:     $hm[0]-=12;
                    531:     $ampm = " pm";
                    532:   }
                    533:   return $dc[0].', '.$dc[1].' '.$dc[2].', '.$dc[4].' at '.$hm[0].':'.$hm[1].$ampm;
                    534: #  return $dc[0].', '.$dc[1].' '.$dc[2].', '.$dc[4].' at '.$dc[3];
                    535: }
                    536: 
                    537: sub array_moments {
                    538:   my @input=@_;
                    539:   my (@output,$N);
                    540:   $N=scalar (@input);
                    541:   $output[0]=$N;
                    542:   if ($N <= 1) {
                    543:     $output[1]=$input[0];
1.28      ng        544:     $output[1]="Input array not defined" if ($N == 0);
1.24      ng        545:     $output[2]="variance undefined for N<=1";
                    546:     $output[3]="skewness undefined for N<=1";
                    547:     $output[4]="kurtosis undefined for N<=1";
                    548:     return @output;
                    549:   }
                    550:   my $sum=0;
                    551:   foreach my $line (@input) {
                    552:     $sum+=$line;
                    553:   }
                    554:   $output[1] = $sum/$N;
                    555:   my ($x,$sdev,$var,$skew,$kurt) = 0;
                    556:   foreach my $line (@input) {
                    557:     $x=$line-$output[1];
                    558:     $var+=$x**2;
                    559:     $skew+=$x**3;
                    560:     $kurt+=$x**4;
                    561:   }
                    562:   $output[2]=$var/($N-1);
                    563:   $sdev=sqrt($output[2]);
                    564:   if ($sdev == 0) {
                    565:      $output[3]="inf-variance=0";
                    566:      $output[4]="inf-variance=0";
                    567:      return @output;
                    568:   }
                    569:   $output[3]=$skew/($sdev**3*$N);
                    570:   $output[4]=$kurt/($sdev**4*$N)-3;
                    571:   return @output;
                    572: }
1.5       albertel  573: 
                    574: sub choose {
                    575:   my $num = $_[0];
                    576:   return $_[$num];
                    577: }
1.23      ng        578: 
                    579: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>