#!/usr/bin/perl use strict; for (split /[&;]/, $main::ENV{QUERY_STRING}) { } my %ex_point1 = (); ( kokugo => 54, suugaku => 55, eigo => 57, sekaishi => 53, nihonshi => 0, chiri => 0, butsuri => 54, kagaku => 52, seibutsu => 0, _OBJECT => 57, ); my %ex_point2 = (); ( kokugo => 53, suugaku => 55, eigo => 55, sekaishi => 52, nihonshi => 0, chiri => 0, butsuri => 54, kagaku => 51, seibutsu => 0, _OBJECT => 58, ); my %ex_haiten1 = (); ( kokugo => 80, suugaku => 80, eigo => 80, sekaishi => 40, nihonshi => 0, chiri => 0, butsuri => 40, kagaku => 0, seibutsu => 0, ); my %ex_haiten2 = (); ( kokugo => 0, suugaku => 300, eigo => 150, sekaishi => 0, nihonshi => 0, chiri => 0, butsuri => 150, kagaku => 150, seibutsu => 0, ); sub kanzan (%%%%) { my ($point1, $full1, $point2, $full2) = @_; my (%kanzaned1, %kanzaned2); $$full1{_ALL} = 0; for my $subject (keys %$full1) { next if $subject =~ /^_/; $kanzaned1{$subject} = $$point1{$subject}*$$full1{$subject}/100; $kanzaned1{_ALL} += $kanzaned1{$subject}; $$full1{_ALL} += $$full1{$subject}; } $kanzaned1{_PERCENT} = $$full1{_ALL}==0?0:100*$kanzaned1{_ALL}/$$full1{_ALL}; $$full2{_ALL} = 0; for my $subject (keys %$full2) { next if $subject =~ /^_/; $kanzaned2{$subject} = $$point2{$subject}*$$full2{$subject}/100; $kanzaned2{_ALL} += $kanzaned2{$subject}; $$full2{_ALL} += $$full2{$subject}; } $kanzaned2{_PERCENT} = $$full2{_ALL}==0?0:100*$kanzaned2{_ALL}/$$full2{_ALL}; my ($percent, $object_percent); $percent = ($$full1{_ALL}+$$full2{_ALL})==0?0: 100*($kanzaned1{_ALL}+$kanzaned2{_ALL}) /($$full1{_ALL}+$$full2{_ALL}); $object_percent = ($$full1{_ALL}+$$full2{_ALL})==0?0: ($$point1{_OBJECT}*$$full1{_ALL} +$$point2{_OBJECT}*$$full2{_ALL}) /($$full1{_ALL}+$$full2{_ALL}); ($percent, $object_percent, \%kanzaned1, \%kanzaned2); } %Suika::CGI::param = %{__get_parameter ()}; my (%mypoint1, %mypoint2, %haiten1, %haiten2); if ($Suika::CGI::param{newform} ne 'no') { %mypoint1 = %ex_point1; %mypoint2 = %ex_point2; %haiten1 = %ex_haiten1; %haiten2 = %ex_haiten2; } else { for my $s (keys %Suika::CGI::param) { $mypoint1{$1} = $Suika::CGI::param{$s} if $s =~ /^(.+[^H_])1$/; $mypoint2{$1} = $Suika::CGI::param{$s} if $s =~ /^(.+[^H_])2$/; $mypoint1{'_'.$1} = $Suika::CGI::param{$s} if $s =~ /^(.+)_1$/; $mypoint2{'_'.$1} = $Suika::CGI::param{$s} if $s =~ /^(.+)_2$/; $haiten1{$1} = $Suika::CGI::param{$s} if $s =~ /^(.+)H1$/; $haiten2{$1} = $Suika::CGI::param{$s} if $s =~ /^(.+)H2$/; } } my ($percent, $object, $kanzan1, $kanzan2) = kanzan ({%mypoint1} => {%haiten1}, {%mypoint2} => {%haiten2}); print STDOUT "Content-Type: text/html; charset=euc-jp Content-Style-Type: text/css Content-Language: ja "; output_html (\%mypoint1 => \%haiten1 => $kanzan1, \%mypoint2 => \%haiten2 => $kanzan2, percent => $percent, object => $object); sub diffmark ($) { my $diff = shift; return '□' if $diff < -4; return '△' if $diff < -2; return '○' if $diff < 0; return '◎'; } sub output_html (%%%%%) { my ($p1 => $h1 => $k1, $p2 => $h2 => $k2, %misc) = @_; for my $n ($$k1{_PERCENT}, $$k2{_PERCENT}, $misc{percent}, $misc{object}) { $n = int ($n); } $$k1{_DIFF} = $$k1{_PERCENT}-$$p1{_OBJECT}; $$k2{_DIFF} = $$k2{_PERCENT}-$$p2{_OBJECT}; $misc{_DIFF} = $misc{percent}-$misc{object}; $$k1{_DIFFMARK} = diffmark ($$k1{_DIFF}); $$k2{_DIFFMARK} = diffmark ($$k2{_DIFF}); $misc{_DIFFMARK} = diffmark ($misc{_DIFF}); print < 配点換算

配点換算

教科		国語	数学	英語	世界史	日本史	地理	物理	化学	生物
一次	持ち点
	配点
	換算点	$$k1{kokugo}	$$k1{suugaku}	$$k1{eigo}	$$k1{sekaishi}	$$k1{nihonshi}	$$k1{chiri}	$$k1{butsuri}	$$k1{kagaku}	$$k1{seibutsu}
二次	持ち点
	配点
	換算点	$$k2{kokugo}	$$k2{suugaku}	$$k2{eigo}	$$k2{sekaishi}	$$k2{nihonshi}	$$k2{chiri}	$$k2{butsuri}	$$k2{kagaku}	$$k2{seibutsu}

	得点率	目標点	差
一次	$$k1{_PERCENT}		$$k1{_DIFF}	$$k1{_DIFFMARK}
二次	$$k2{_PERCENT}		$$k2{_DIFF}	$$k2{_DIFFMARK}
合計	$misc{percent}	$misc{object}	$misc{_DIFF}	$misc{_DIFFMARK}

EOH } sub __get_parameter () { my @src; ## Query-string of Request-URI my $qs = $main::ENV{QUERY_STRING}; push @src, $qs if (index ($qs, '=') > -1); ## Entity-body if ($main::ENV{REQUEST_METHOD} eq 'POST') { my $mt = $main::ENV{CONTENT_TYPE}; if ($mt =~ m<^application/(?:x-www|sgml)-form-urlencoded\b>) { my $body; read STDIN, $body, $main::ENV{CONTENT_LENGTH}; push @src, $body; } } my %temp_params; for my $src (@src) { for (split /[;&]/, $src) { my ($name, $val) = split '=', $_, 2; for ($name, $val) { tr/+/ /; s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge; } $temp_params{$name} = $val; } } \%temp_params; } =head1 LICENSE Copyright 2001-2004 Wakaba Ew@suika.fam.cxE. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; see the file COPYING. If not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. =cut 1; # $Date: 2004/11/16 07:37:01 $