Тексты программ на Паскале для решения задач оценивания тестирования

Задача 1.

program P1;
uses crt;
var
  w,a:array[1..500] of real;
  n:integer;
procedure Input_3;
var i:integer;
begin
  clrscr;
  write('Количество тестированных n=');
  readln(n);
  writeln('Ввод результатов тестирования: ');
for i:=1 to n do
  begin
    writeln;
    write('результат ',i,'-го студента a[',i,']=');
    readln(a[i]);
 end;
 writeln;
 writeln('Ввод весов тестирования: ');
 for i:=1 to n do
 begin
    writeln;
    write('веса w[',i,']=');
    readln(w[i]) ;
 end;
end;
procedure Output_3;
var i:integer;
begin
     for i:=1 to n do
          write(a[i]:6:2,' ');
     writeln;
end;
procedure Sort_3;
var i,j:integer;
      tmp:real;
begin
   for i:=1 to n-1 do
     for j:=i+1 to n do
       if (a[i]>a[j])
          then begin
                      tmp:=a[i];
                      a[i]:=a[j];
                      a[j]:=tmp;
                  end;
end;
function SA_3:real;
var s:real;
       i:integer;
begin
   s:=0;
   SA_3:=0;
   for i:=1 to n do
   s:=s+a[i];
   if (n<>0)
      then SA_3:=s/n;
end;
function SW_3:real;
var s:real;
       i:integer;
begin
   s:=0;
   SW_3:=0;
   for i:=1 to n do
   s:=s+a[i]*w[i];
   if (n<>0)
      then SW_3:=s/n;
end;
function SGarm_3:real;
var s:real;
      i:integer;
begin
   s:=0;
   SGarm_3:=0;
   for i:=1 to n do
   if (a[i]<>0)
      then s:=s+1/a[i];
   if (s<>0)
      then SGarm_3:=n/s;
end;
function SWGeom_3:real;
var s:real;
      i:integer;
      w3:real;
begin
  w3:=0;
  for i:=1 to n do
       w3:=w3+w[i];
  s:=1;
  for i:=1 to n do
       s:=s*exp(w[i]*ln(a[i]));
  SWGeom_3:=exp(ln(s)/w3);
end;
function SWQuadr_3:real;
var s:real;
      i:integer;
      w3:real;
begin
  w3:=0;
  for i:=1 to n do
       w3:=w3+w[i];
  s:=1;
  for i:=1 to n do
      s:=s*sqr(a[i])*w[i];
  SWQuadr_3:=sqrt(s/w3);
end;
function Moda_3:real;
var i,j,k,mi:integer;
      max:real;
begin
  mi:=0;
  for i:=1 to n-1 do
      begin
         k:=1;
         for j:=i+1 to n do
             if (a[i]=a[j])
                then inc(k);
         if (k>mi)
            then begin
                          max:=a[i];
                          mi:=k; 
                    end;
      end;
  Moda_3:=max;
end;
function Mediana_3(sorted:boolean):real;
var i,j:integer;
      max,min:real;
begin
  if (sorted)
    then begin
              max:=a[n];
              min:=a[1];
           end
    else  begin
              max:=a[1];
              min:=a[1];
              for i:=2 to n do
                   begin
                       if (a[i]>max)
                          then max:=a[i];
                       if (a[i]<min)
                          then min:=a[i];
                   end;
            end;
  Mediana_3:=(max+min)/2;
end;
function Razmah_3:real;
begin
  razmah_3:=a[n]-a[1];
end;
function SAbsOtkl_3:real;
var s:real;
      i:integer;
      sa:real;
begin
   sa:=sa_3;
   s:=0;
   for i:=1 to n do
       s:=s+abs(a[i]-sa);
   SAbsOtkl_3:=s/n;
end;
function SQuadroOtkl_3:real;
var s:real;
      i:integer;
      sa:real;
begin
   sa:=sa_3;
   s:=0;
   for i:=1 to n do
        s:=s+sqrt(a[i]);
   SQuadroOtkl_3:=abs(s-n*sqrt(sa))/n;
end;
function Dispersia_3:real;
var s:real;
      i:integer;
      sa:real;
begin
   sa:=sa_3;
   s:=0;
   for i:=1 to n do
        s:=s+sqrt(a[i]);
   if (n>1)
      then Dispersia_3:=abs((s-n*sqrt(sa))/(n-1))
      else Dispersia_3:=0;
end;
begin
  Input_3;
  clrscr;
  writeln('Входные данные ');
  Output_3;
  writeln('Генеральная совокупность');
  Sort_3;
  writeln('Среднеарифметическое = ',SA_3:8:2);
  writeln('Средневзвешанное = ',SW_3:8:2);
  writeln('Средняя гармоническая велечина = ',SGarm_3:8:2);
  writeln('Средне взвешанная геометрическая велечина = ',SWGeom_3:8:2);
  writeln('Средне квадратическая величина выборки = ',SWGeom_3:8:2);
  writeln('Мода = ',Moda_3:8:2);
  writeln('Медиана = ',Mediana_3(true):8:2);
  writeln('Размах = ',Razmah_3:8:2);
  writeln('Среднеабсолютное отклонение = ',SAbsOtkl_3:8:2);
  writeln('Среднеквадратическое отклонение = ',SQuadroOtkl_3:8:2);
  writeln('Дисперсия = ',Dispersia_3:8:2);
  writeln('Стандартное отклонение = ',sqrt(Dispersia_3):8:2);
  writeln('Коэфициент вариации = ',sqrt(Dispersia_3)/sa_3:8:2);
  readkey;
end.

Задача 2.

program P2;
uses crt;
var
  a:array[1..50,1..50] of integer;
  n,m:integer;
  b,y:array[1..50] of integer;
  c,d:array[1..50] of real;
procedure Input_5;
var i,j:integer;
begin
  write('Количество тестированных n=');
  readln(n);
  write('Длина теста m=');
  readln(m);
  writeln('Введите результаты тестирования');
  for i:=1 to n do
     for j:=1 to m do
          begin
              write('a[',i,',',j,']=');
              readln(a[i,j]);
          end;
 writeln;
 writeln('Введите эталонные результаты');
 for i:=1 to m do
    begin
        write('b[',i,']=');
        readln(b[i]);
    end;
end;
procedure Output_5;
var i,j:integer;
begin
     for i:=1 to n do
         begin
             for j:=1 to m do
                 write(a[i][j]:6,' ');
                 writeln;
         end;
end;
procedure CheckAnsw;
var i,k,j,krs,lh:integer;
begin
   krs:=0;
   lh:=0;
   for j:=1 to m do
      begin
          k:=0;
          for i:=1 to n do
              if (a[i,j]=b[j])
                 then inc(k);
          y[j]:=k;
          if (k=n)
             then inc(krs);
          if (k=0)
             then inc(lh)
      end;
   for j:=1 to m do
   begin
       if (y[j]<>0)
          then c[j]:=krs/y[j]
          else c[j]:=0;
       if (y[j]<>n)
          then d[j]:=lh/(n-y[j])
          else d[j]:=0;
    end;
end;
procedure PrintResult;
var i:integer;
begin
  writeln('Вектор весов выполнения :');
  for i:=1 to m do
       write(c[i]:8:2);
  writeln;
  writeln('Вектор весов невыполнения :');
  for i:=1 to m do
       write(d[i]:8:2);
  writeln;
end;
begin
  clrscr;
  Input_5;
  clrscr;
  Output_5;
  CheckAnsw;
  PrintResult;
  readkey;
end.

Задача 3.

program P3;
uses crt;
var
  a:array[1..100,1..100] of integer;
  n,m:integer;
  b,stud_bal,tru_ans_count:array[1..100] of integer;
  r,c,d,y,x,disp,std_otk:array[1..100] of real;
  Disp_all,Stand_otkl_all:real;
procedure Input_6;
var i,j:integer;
begin
  write('Количество тестированных n=');
  readln(n);
  write('Длина теста m=');
  readln(m);
  writeln('Введите результаты тестирования');
  for i:=1 to n do
     for j:=1 to m do
         begin
             write('a[',i,',',j,']=');
             readln(a[i,j]);
         end;
  writeln;
  writeln('Введите эталонные результаты');
  for i:=1 to m do
      begin
           write('b[',i,']=');
           readln(b[i]);
      end;
end;
procedure Output_6;
var i,j:integer;
begin
    for i:=1 to n do
       begin
           for j:=1 to m do
                write(a[i][j]:6,' ');
            writeln;
       end;
end;
function SA_6:real;
var s:real;
      i:integer;
begin
   s:=0;
   SA_6:=0;
   for i:=1 to m do
        s:=s+disp[i];
   if (m<>0)
      then SA_6:=s/m;
end;
function Dispersia_6:real;
var s:real;
      i:integer;
      sa:real;
begin
   sa:=SA_6;
   s:=0;
   for i:=1 to m do
       s:=s+sqrt(disp[i]);
   Dispersia_6:=abs((s-m*sqrt(sa))/(m-1));
end;
procedure CheckAnsw;
var i,k,j,s_tr,s_fl:integer;
begin
   for i:=1 to n do
       begin
           k:=0;
           for j:=1 to m do
                if (a[i,j]=b[j])
                   then inc(k);
           stud_bal[i]:=k;
       end;
   for j:=1 to m do
      begin
          k:=0;
          s_tr:=0;
          s_fl:=0;
          for i:=1 to n do
               if (a[i,j]=b[j])
                  then begin
                              inc(k);
                              s_tr:= s_tr+stud_bal[i];
                          end
                  else s_fl:=s_fl+stud_bal[i];
          tru_ans_count[j]:=k;
          if (k<>0)
              then x[j]:=s_tr/k
              else x[j]:=0;
          if (k<>n)
              then y[j]:=s_fl/(n-k)
              else y[j]:=0;
          if (k<>0)
              then c[j]:=n/k
              else c[j]:=0;
          if (k<>n)
              then d[j]:= n/(n-k)
              else d[j]:=0;
          disp[j]:=c[j]*d[j];
          std_otk[j]:=sqrt(disp[j]);
      end;
    Disp_all:=Dispersia_6;
    Stand_otkl_all:=sqrt(Dispersia_6) ;
    for j:=1 to m do
        if (Stand_otkl_all>0)
           then r[j]:=(x[j]-y[j])*Std_otk[j]/Stand_otkl_all
           else r[j]:=0;
end;
procedure PrintResult;
var i:integer;
begin
  writeln('Вектор весов выполнения :');
  for i:=1 to m do
      write(c[i]:8:2);
  writeln;
  writeln;
  writeln('Вектор весов невыполнения :');
  for i:=1 to m do
       write(d[i]:8:2);
  writeln;
  writeln;
  writeln('Дисперсии каждого задания :');
  for i:=1 to m do
       write(disp[i]:8:2);
  writeln;
  writeln;
  writeln('Стандартное отклонение каждого задания :');
  for i:=1 to m do
      write(std_otk[i]:8:2);
  writeln;
  writeln;
  writeln('Общая дисперсии по всему тесту:',Disp_all:8:2);
  writeln;
  writeln('Стандартное отклонение по всему тесту:',Stand_otkl_all:8:2);
  writeln;
  writeln('Коэффициенты корреляции: ');
  for i:=1 to m do
      begin
           write(r[i]:8:2);
           if (r[i]>0.3)
              then writeln('  Валидное.') else  writeln('  Невалидное.')
       end;
end;
begin
   clrscr;
   Input_6;
   clrscr;
   Output_6;
   CheckAnsw;
   PrintResult;
   readkey;
end.

Задача 4.

program P4;
uses crt;
type
   mas=array[1..10,1..10] of integer;
   int_vect=array[1..10] of integer;
var
   aa:mas ;
   nn,mm:integer;
   bb:int_vect;
procedure Input_7;
var i,j:integer;
begin
  write('Количество тестированных n=');
  readln(nn);
  write('Длина теста m=');
  readln(mm);
  writeln('Введите результаты тестирования');
  for i:=1 to nn do
      for j:=1 to mm do
          begin
              write('a[',i,',',j,']=');
              readln(aa[i,j]);
          end;
 writeln;
 writeln('Введите эталонные результаты');
 for i:=1 to mm do
     begin
          write('b[',i,']=');
          readln(bb[i]);
     end;
end;
procedure Output_7(a:mas;n,m:integer);
var i,j:integer;
begin
    for i:=1 to n do
         begin
             for j:=1 to m do
                  write(a[i][j]:6,' ');
             writeln;
         end
end;
procedure CheckAnsw(a:mas;b:int_vect;n,m:integer;var stud_bal:int_vect);
var i,k,j,s_tr,s_fl:integer;
  Disp_all,Stand_otkl_all:real;
  tru_ans_count:array[1..100] of integer;
  r,c,d,y,x,disp,std_otk:array[1..100] of real;
function SA_7:real;
var s:real;
      i:integer;
begin
   s:=0;
   SA_7:=0;
   for i:=1 to m do
        s:=s+disp[i];
   if (m<>0)
       then SA_7:=s/m;
end;
function Dispersia_7:real;
var s:real;
      i:integer;
      sa:real;
begin
   sa:=SA_7;
   s:=0;
   for i:=1 to m do
        s:=s+sqrt(disp[i]);
   Dispersia_7:=abs((s-m*sqrt(sa))/(m-1));
end;
procedure PrintResult;
var i:integer;
begin
   writeln('Вектор весов выполнения :');
   for i:=1 to m do
        write(c[i]:8:2);
   writeln;
   writeln;
   writeln('Вектор весов невыполнения :');
   for i:=1 to m do
        write(d[i]:8:2);
   writeln;
   writeln;
   writeln('Дисперсии каждого задания :');
   for i:=1 to m do
        write(disp[i]:8:2);
   writeln;
   writeln;
   writeln('Стандартное отклонение каждого задания :');
   for i:=1 to m do
        write(std_otk[i]:8:2);
   writeln;
   writeln;
   writeln('Общая дисперсии по всему тесту:',Disp_all:8:2);
   writeln;
   writeln('Стандартное отклонение по всему тесту:',Stand_otkl_all:8:2);
   writeln;
   writeln('Коэффициенты корреляции  :');
   for i:=1 to m do
       begin
            write(r[i]:8:2);
            if (r[i]>0.3)
               then writeln('  Валидное.')
               else writeln('  Невалидное.')
       end;
end;
begin
   for i:=1 to n do
       begin
           k:=0;
           for j:=1 to m do
                if (a[i,j]=b[j])
                   then inc(k);
                   stud_bal[i]:=k;
       end;
   for j:=1 to m do
        begin
            k:=0;
            s_tr:=0;
            s_fl:=0;
            for i:=1 to n do
                if (a[i,j]=b[j])
                   then begin
                               inc(k);
                               s_tr:=s_tr+stud_bal[i];
                           end
                   else s_fl:=s_fl+stud_bal[i];
            tru_ans_count[j]:=k;
            if (k<>0)
               then x[j]:=s_tr/k
               else x[j]:=0;
            if (k<>n)
               then y[j]:=s_fl/(n-k)
               else y[j]:=0;
            if (k<>0)
               then c[j]:=n/k
               else c[j]:=0;
            if (k<>n)
               then d[j]:=n/(n-k)
               else d[j]:=0;
            disp[j]:=c[j]*d[j];
            std_otk[j]:=sqrt(disp[j]);
       end;
    Disp_all:=Dispersia_7;
    Stand_otkl_all:=sqrt(Dispersia_7) ;
    for j:=1 to m do
        if (Stand_otkl_all>0)
           then r[j]:=(x[j]-y[j])*Std_otk[j]/Stand_otkl_all
           else r[j]:=0;
        PrintResult;
end;
procedure Main;
var bx,by,x,y:int_vect;
var ax,ay:mas;
var mx,my:integer;
var i,j:integer;
function Koeff_Korell:real;
var sxy,sx,sy,sx2,sy2,vall:real;
var i:integer;
begin
   sxy:=0;
   sx:=0;
   sy:=0;
   sx2:=0;
   sy2:=0;
   for i:=1 to nn do
       begin
           sxy:=sxy+x[i]*y[i];
           sx:=sx+x[i];
           sy:=sy+y[i];
           sx2:=sx2+sqr(x[i]);
           sy2:=sy2+sqr(y[i]);
       end;
   val1:=(sqrt(sx2-sqr(sx)/nn)*sqrt(sy2-sqr(sy)/nn));
   if (val1<>0)
      then Koeff_Korell:=(sxy-sx*sy/nn)/val1
      else Koeff_Korell:=0;
end;
var rXY,r:real;
begin
    mx:=0;
    my:=0;
    if (mm>1)
       then mm:=2*(mm div 2);
    for j:=1 to mm do
        if (j mod 2=0)
           then begin
                       inc(mx);
                       bx[mx]:=bb[j] ;
                       for i:=1 to nn do
                            ax[i,mx]:=aa[i,j]
                   end
           else begin
                       inc(my);
                       by[my]:=bb[j];
                       for i:=1 to nn do
                            ay[i,my]:=aa[i,j]
                  end;
    writeln('Масив X:');
    Output_7(ax,nn,mx);
    CheckAnsw(ax,bx,nn,mx,x);
    writeln;
    writeln('Масив Y:');
    Output_7(ay,nn,my);
    CheckAnsw(ay,by,nn,my,y);
    writeln;
    rXY:=Koeff_Korell;
    writeln('Коэффициент корреляции X и Y:',rXY:8:2);
    r:=2*rXY/(1+rXY);
    writeln('Надежность всего теста:',r:8:2);
end;
begin
  clrscr;
  Input_7;
  clrscr;
  Main;
  readln;
  readln;
end.

Задача 5.

program P5;
uses crt;
var
  a:array[1..50,1..50] of real;
  k,n,m:integer;
  z:array[1..50] of integer;
  c,y:array[1..50] of real;
  pk,min_8:real;
procedure minmax(jj:integer;var min,max:real);
var i:integer;
begin
  min:= a[1,jj];
  max:=a[1,jj];
  for i:=2 to n do
     if (a[i,jj]>max)
        then max:=a[i,jj]
        else if (a[i,jj]<min)
                  then min:=a[i,jj];
end;
function SA_8(jj:integer):real;
var s:real;
i:integer;
begin
   s:=0;
   SA_8:=0;
   for i:=1 to n do
       s:=s+a[i,jj];
   if (n<>0)
      then SA_8:=s/n;
end;
procedure Input_8;
var i,j:integer;
begin
   write('Количество тестированных n=');
   readln(n);
   write('Длина теста m=');
   readln(m);
   writeln('Введите результаты тестирования');
   for i:=1 to n do
       for j:=1 to m do
           begin
               write('a[',i,',',j,']=');
               readln(a[i,j]);
           end;
   writeln;
   writeln('Введите количество групп');
   write('k=');
   readln(k);
   for i:=1 to m do
       z[i]:=1;
end;
procedure Output_8;
var i,j:integer;
begin
    for i:=1 to n do
         begin
             for j:=1 to m do
                 write(a[i][j]:6:2,' ');
             writeln;
         end;
end;
procedure CheckAnsw;
var i,j:integer;
      min,max,sa,s:real;
begin
   for j:=1 to m do
       begin
            minmax(j,min,max);
            for i:=1 to n do
                 begin
                      a[i,j]:=(a[i,j]-min)/(max-min);
                      if (z[j]=-1)
                         then a[i,j]:=1-a[i,j]
                 end;
   end;
   for j:=1 to m do
        begin
             sa:=SA_8(j);
             s:=0;
             for i:=1 to n do
                  s:=s+sqr(a[i,j]-sa);
             if (n>1)
                then c[j]:=sqrt(s/(n-1))
                else c[j]:=0;
        end;
    for i:=1 to n do
        begin
             s:=0;
             for j:=1 to m do
                  s:=s+a[i,j]*c[j];
             y[i]:=s;
        end;
    min:= y[1];
    max:=y[1];
    for i:=2 to n do
         if (y[i]>max)
            then max:=y[i]
            else if (y[i]<min)
                      then min:=y[i];
    pk:=max-min;
    min_8:=min;
    if (k>1)
       then pk:=pk/k;
end;
procedure PrintResult;
var i:integer;
      kk:integer;
begin
    writeln('Значения интегрального показателя и соотв класс :');
    for i:=1 to m do
        begin
            write(y[i]:8:2);
            kk:=0;
            if (pk>0)
               then begin
                           kk:=trunc((y[i]-min_8)/pk) ;
                           if (Frac((y[i]-min_8)/pk)>0.0006)
                               then inc(kk);
                      end;
            writeln('  класс #',kk) ;
        end;
end;
begin
  clrscr;
  Input_8;
  clrscr;
  Output_8;
  CheckAnsw;
  PrintResult;
  readkey;
end.

Задача 6.

program P6;
uses crt;
var
   a:array[1..50,1..50] of real;
   n,m:integer;
   b:array[1..50] of real;
function SA_9(jj:integer):real;
var s:real;
      i:integer;
begin
   s:=0;
   SA_9:=0;
   for i:=1 to n do
        s:=s+a[i,jj];
   if (n<>0) then SA_9:=s/n;
end;
procedure Input_9;
var i,j:integer;
begin
   write('Количество тестированных n=');
   readln(n);
   write('Длина теста m=');
   readln(m);
   writeln('Введите результаты тестирования');
   for i:=1 to n do
       for j:=1 to m do
           begin
                write('a[',i,',',j,']=');
                readln(a[i,j]);
           end;
end;
procedure Output_9;
var i,j:integer;
begin
     for i:=1 to n do
         begin
              for j:=1 to m do
                   write(a[i][j]:6:2,' ');
              writeln;
         end;
end;
procedure CheckAnsw;
var i,j:integer;
s,tmp:real;
begin
    for i:=1 to n do
        begin
            s:=0;
            for j:=1 to m do
                 s:=s+a[i,j];
            b[i]:=s;
        end;
    for i:=1 to n-1 do
       for j:=i+1 to n do
           if (b[i]>b[j])
              then begin
                          tmp:=b[i];
                          b[j]:=b[i];
                          b[i]:=tmp
                      end;
end;
procedure PrintResult;
var i:integer;
      kk:integer;
      const b_koef=0.6;
begin
   writeln('Значения интегрального показателя и соотв группа :');
   for i:=1 to m do
        begin
             write(b[i]:8:2);
             if (b[i]>=b[1]+b_koef*(b[n]-b[i]))
                then kk:=1
                else if (b[i]<=b[1]+(1-b_koef)*(b[n]-b[i]))
                           then kk:=3
                           else kk:=2;
             writeln('  группа #',kk) ;
        end;
end;
begin
   clrscr;
   Input_9;
   clrscr;
   Output_9;
   CheckAnsw;
   PrintResult;
   readkey;
end.

Задача 7.

program P7;
uses crt;
var
   n:integer;
   x:array[1..50] of real;
   dmax_10,min_10,max_10,sx,w_10:real;
procedure minmax(var min,max:real);
var i:integer;
begin
  min:= x[1];
  max:=x[1];
  for i:=2 to n do
    if (x[i]>max)
       then max:=x[i]
       else if (x[i]<min)
                 then min:=x[i];
end;
function SA_10:real;
var s:real;
      i:integer;
begin
   s:=0;
   SA_10:=0;
   for i:=1 to n do
   s:=s+x[i];
   if (n<>0)
      then SA_10:=s/n;
end;
procedure Input_10;
var i:integer;
begin
   write('Количество тестированных n=');
   readln(n);
   writeln('Введите результаты тестирования');
   for i:=1 to n do
       begin
           write('х[',i,']=');
           readln(x[i]);
       end;
end;
procedure Output_10;
var i:integer;
begin
    for i:=1 to n do
         write(x[i]:6:2,' ');
    writeln;
end;
procedure CheckAnsw;
begin
  sx:=SA_10;
  minmax(min_10,max_10);
  dmax_10:=abs(min_10-sx);
  if (abs(max_10-sx)>dmax_10)
      then dmax_10:=abs(max_10-sx);
  if (sx<>0)
      then w_10:=dmax_10/sx;
end;
procedure PrintResult;
begin
  writeln('Средняя велечина :',sx:8:2);
  writeln('Наибольшее значение :',max_10:8:2);
  writeln('Наимньшее значение :',min_10:8:2);
  writeln('Наибольшее отклонение в группе :',dmax_10:8:2);
  writeln('Относительное отклонение в группе :',w_10:8:2);
end;
begin
  clrscr;
  Input_10;
  clrscr;
  Output_10;
  CheckAnsw;
  PrintResult;
  readkey;
end.