Упорядочить массив по среднему баллу, задача на Записи Опции

[natik3]

Создать массив из 20 элементов,хранящих информацию о студенках факультета.Каждый элемент содержит фамилию,курс,форму обучения,(специалист,бакалавр,магис тр)и оценки по 5 предметам за последнюю сессию.
Упорядочить массив по среднему баллу.Осуществить перевод студентов на следующий курс.Переводятся студенты ,не имеющие задолжностей за последнюю сессию,студенты 5-ого курса(специалисты) и 6-ого курса(магистры)должны быть удалены ,как окончившие курс обучения.
Я сделала,но явно неправильно,и кое где несообразила,как дальше.помогите исправить ошибки и дописать то,что совсем неверно.буду очень благодарна!

Код

program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows;

const n=5;
type
formob=(spez,bakal,magis);
zmas=array [1..5]of integer;
telem=record
name:record
FIO:string[30]
curs: 1..6;
end;
pred:zmas;
form:formob;
end;
tmas=array [1..n] of telem;
var
a:tmas;
b:array[1..n]of string[30];// массив студентов,которых переводят
mn,choice,i:Integer;
  exit_:char;
  error_in: boolean;
Function menu :integer; //Вывод меню на экран
begin
    writeln;
    writeln (' ','1.Упорядочить массив по среднему баллу');
    writeln (' ','2.Перевести студентов на следующих курс');
    Writeln (' ','3.Завершение работы.');
    repeat
      write ('Ваш выбор: ');
      readln (choice);
      error_in:=(choice<1) or (choice >3);
      if error_in then writeln ('Ошибка ввода!')
    until not error_in;
    menu:=choice;
end;


procedure form (var a:tmas);
var
k,i,j:integer;
b:telem;
n:integer;
tmp:telem;
begin
  writeln('Ввести ФИО');
  readln(b.name.FIO);
  writeln('Ввести номер формы обучения');
  readln(k);
  case k of
    1: b.form:=spez;
    2: b.form:=bakal;
    3: b.form:=magis
  end;
  writeln('Ввести курс');
  readln(b.name.curs);
  writeln('Ввести оценки');
   for i:=1 to n do
  readln(b.pred[j]);
  a[i]:=b
   end;

Function Sr(b:zmas):integer;
  var
   s1,s,i:integer;
    begin
      S:=0;
      for i:=1 to n do
      begin
        S:=S+S1(b[i].pred);
        Sr:=s1 div 5
      end;
      end;

   procedure sort(var b:tmas);
var
i,j:integer;
tmp:telem;
begin
   for i:=1 to n do
  if(b[i]>b[i+1]) then
    begin
      tmp:=b[i];
      b[i]:=b[i+1];
      b[i+1]:=tmp;
    end;
end;
Procedure perevod (var b:tmas);
var i,k:integer;
i:=1; k:=0;
while  i<= n-k do
//---------------------
Function Dvoechnik (a:tmas);
var i,k:integer;
  for i:=1 to n do
    Begin
      If a[i]<3 then
         k:=k+1
    end;
//---------------------





   SetConsoleOutputCP(1251);
  form(а);
  writeln;
  REPEAT
    mn:=Menu;
    case mn of
     1:begin
          sort(а);

       end;
     2: begin
          Writeln('Перевод на следующий курс');

        end
     end;
    if mn<>3 then
        begin
          Writeln;
          write (' ','Завершить работу? (Y/N)');
          readln(exit_);
        end;
  UNTIL (exit_='y') or (exit_='Y') or (choice=3);
  readln

End.

[Krjuger]

Эх окей))

const n=3;
const m=2;
type
    formob=(spez,bakal,magis);
    Tballs=array[1..m] of 1..5;
    telem=record
        FIO:string[35];
        curs: integer;
        f_study:formob;
        balls:Tballs;
        Med_ball:real;
   end;
   tmas=array [1..n] of telem;


  function menu :integer;
  var
    choice:integer;
    error_in: boolean;
  begin
      writeln;
      writeln (' ','1.Sorting');
      writeln (' ','2.Up');
      writeln (' ','3.Exit');
      error_in:=false;
      repeat
            write ('Choice: ');
            readln (choice);
            error_in:=(choice<1) or (choice >3);
            if error_in then
                 writeln ('Error!')
      until not error_in;
      menu:=choice;
  end;

  procedure Add (var a:telem);
  var
   k,i:integer;
   b:telem;
   s:integer;
   begin
     writeln('FIO');
     readln(b.FIO);
     writeln('Number of Form Educationя');
     readln(k);
     case k of
        1: b.f_study:=spez;
        2: b.f_study:=bakal;
        3: b.f_study:=magis
     end;
     writeln('Kurs');
     readln(b.curs);
     writeln('Marks');
     s:=0;
     for i:=1 to m do
     begin
        readln(b.balls[i]);
        s:=s+b.balls[i];
     end;
     b.med_ball:=s/m;
     a:=b;
   end;

   procedure swap(var x,y: telem);
   var
    t: telem;
   begin
    t := x;
    x := y;
    y := t
   end;

   procedure sort(var b:tmas);
   var
   i,j:integer;
   tmp:telem;
   begin
    for j:=1 to N-1 do
    for i:=1 to N-j do
     if (b[i].med_ball > b[i+1].med_ball) then
      swap(b[i],b[i+1]);
   end;

procedure Delete(var a:tmas; var p:integer ; i:integer);
 var
 j:integer;
begin
 if i<n then
  begin
    for j:=i+1 to n-p do
      a[j-1]:=a[j];
  end;
  p:=p+1;
end;

function LevelUp(var a: tmas; p:integer):integer;
 var
 i:integer;
begin
 for i:=n downto 1 do
  begin
  if ((a[i].f_study=magis) and (a[i].curs<6)) then
   a[i].curs:=a[i].curs+1
  else
   begin
   if ((a[i].f_study=spez) and (a[i].curs<5)) then
    a[i].curs:=a[i].curs+1
   else
    begin
     if ((a[i].f_study=bakal) and (a[i].curs<4)) then
      a[i].curs:=a[i].curs+1
     else
      Delete(a,p,i);
     end;
    end;
  end;
  LevelUp:=p;
end;

 function Otchislenie(var a: tmas;p:integer):integer;
 var
 flag:boolean;
 i,j:integer;
begin
flag:=false;
 for i:=n downto 1 do
  begin
   for j:=1 to m do
    begin
     if (a[i].balls[j]<3) then
      begin
       flag:=true;
       break;
      end;
    end;
    if (flag=true) then
      Delete(a,p,i);
  end;
  Otchislenie:=p;
end;

var
   a:tmas;
   mn,i:integer;
   exit_:char;
   p:integer;
begin
 for i:=1 to n do
  Add(a[i]);
  writeln;
  REPEAT
    p:=0;
    mn:=Menu;
    case mn of
      1:begin
        sort(a);
        for i:=1 to n do
        begin
         write(a[i].FIO+' ');
         writeln(a[i].med_ball:4:4);
        end;
        end;
      2: begin
          p:=LevelUp(a,p);
          p:=Otchislenie(a,p);
          for i:=1 to n-p do
          begin
           write(a[i].FIO+' ');
           writeln(a[i].med_ball:4:4);
          end;
         end;
     else
      begin
       writeln;
       write (' ','Завершить работу? (Y/N)');
       readln(exit_);
      end;
     end;
  UNTIL (exit_='y') or (exit_='Y') or (mn=3);
  readln;
 end.

Этот вариант компилируется и даже запускается и что то делает.Я попробовал,чтобы удалило тех,кто закончил (1 человек), и одного отчислил за неуспеваемость, вроде работает дальше программу тестируй сама)))))Если найдешь ошибку, скажешь)))

На Delete(a,p,i) он ругался потому,что сама функция описана ниже,чем место где она используется, поэтому кампилятор не мог понять,откуда ее брать,он наперед заглядывать не умеет.

Сообщение отредактировано: Krjuger - 22.05.2012 20:00

[natik3]

Эх окей))

const n=3;
const m=2;
type
    formob=(spez,bakal,magis);
    Tballs=array[1..m] of 1..5;
    telem=record
        FIO:string[35];
        curs: integer;
        f_study:formob;
        balls:Tballs;
        Med_ball:real;
   end;
   tmas=array [1..n] of telem;
  function menu :integer;
  var
    choice:integer;
    error_in: boolean;
  begin
      writeln;
      writeln (' ','1.Sorting');
      writeln (' ','2.Up');
      writeln (' ','3.Exit');
      error_in:=false;
      repeat
            write ('Choice: ');
            readln (choice);
            error_in:=(choice<1) or (choice >3);
            if error_in then
                 writeln ('Error!')
      until not error_in;
      menu:=choice;
  end;

  procedure Add (var a:telem);
  var
   k,i:integer;
   b:telem;
   s:integer;
   begin
     writeln('FIO');
     readln(b.FIO);
     writeln('Number of Form Educationя');
     readln(k);
     case k of
        1: b.f_study:=spez;
        2: b.f_study:=bakal;
        3: b.f_study:=magis
     end;
     writeln('Kurs');
     readln(b.curs);
     writeln('Marks');
     s:=0;
     for i:=1 to m do
     begin
        readln(b.balls[i]);
        s:=s+b.balls[i];
     end;
     b.med_ball:=s/m;
     a:=b;
   end;

   procedure swap(var x,y: telem);
   var
    t: telem;
   begin
    t := x;
    x := y;
    y := t
   end;

   procedure sort(var b:tmas);
   var
   i,j:integer;
   tmp:telem;
   begin
    for j:=1 to N-1 do
    for i:=1 to N-j do
     if (b[i].med_ball > b[i+1].med_ball) then
      swap(b[i],b[i+1]);
   end;

procedure Delete(var a:tmas; var p:integer ; i:integer);
 var
 j:integer;
begin
 if i<n then
  begin
    for j:=i+1 to n-p do
      a[j-1]:=a[j];
  end;
  p:=p+1;
end;

function LevelUp(var a: tmas; p:integer):integer;
 var
 i:integer;
begin
 for i:=n downto 1 do
  begin
  if ((a[i].f_study=magis) and (a[i].curs<6)) then
   a[i].curs:=a[i].curs+1
  else
   begin
   if ((a[i].f_study=spez) and (a[i].curs<5)) then
    a[i].curs:=a[i].curs+1
   else
    begin
     if ((a[i].f_study=bakal) and (a[i].curs<4)) then
      a[i].curs:=a[i].curs+1
     else
      Delete(a,p,i);
     end;
    end;
  end;
  LevelUp:=p;
end;

 function Otchislenie(var a: tmas;p:integer):integer;
 var
 flag:boolean;
 i,j:integer;
begin
flag:=false;
 for i:=n downto 1 do
  begin
   for j:=1 to m do
    begin
     if (a[i].balls[j]<3) then
      begin
       flag:=true;
       break;
      end;
    end;
    if (flag=true) then
      Delete(a,p,i);
  end;
  Otchislenie:=p;
end;

var
   a:tmas;
   mn,i:integer;
   exit_:char;
   p:integer;
begin
 for i:=1 to n do
  Add(a[i]);
  writeln;
  REPEAT
    p:=0;
    mn:=Menu;
    case mn of
      1:begin
        sort(a);
        for i:=1 to n do
        begin
         write(a[i].FIO+' ');
         writeln(a[i].med_ball:4:4);
        end;
        end;
      2: begin
          p:=LevelUp(a,p);
          p:=Otchislenie(a,p);
          for i:=1 to n-p do
          begin
           write(a[i].FIO+' ');
           writeln(a[i].med_ball:4:4);
          end;
         end;
     else
      begin
       writeln;
       write (' ','Завершить работу? (Y/N)');
       readln(exit_);
      end;
     end;
  UNTIL (exit_='y') or (exit_='Y') or (mn=3);
  readln;
 end.

Этот вариант компилируется и даже запускается и что то делает.Я попробовал,чтобы удалило тех,кто закончил (1 человек), и одного отчислил за неуспеваемость, вроде работает дальше программу тестируй сама)))))Если найдешь ошибку, скажешь)))

На Delete(a,p,i) он ругался потому,что сама функция описана ниже,чем место где она используется, поэтому кампилятор не мог понять,откуда ее брать,он наперед заглядывать не умеет.

у меня появилась вот какая проблема..преподавательница сказала,что двоечников не надо удалять..а функция на проверку двоечников должна быть как условие в функции перевода..что то вроде вот этого..

Код

program str155n10;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  windows;

const n=3;   //кол во студентов
const m=2;    //кол-во предметов
type
    formob=(spez,bakal,magis);
    Tballs=array[1..m] of 1..5;
    telem=record
        FIO:string[35];
        curs: integer;
        f_study:formob;
        balls:Tballs;
        Med_ball:real;
   end;
   tmas=array [1..n] of telem;
  function menu :integer;
  var
    choice:integer;
    error_in: boolean;
  begin
      writeln;
      writeln (' ','1.Сортировка по среднему баллу');
      writeln (' ','2.Перевод на следующий курс');
      writeln (' ','3.Exit');
      error_in:=false;
      repeat
            write ('Наш выбар: ');
            readln (choice);
            error_in:=(choice<1) or (choice >3);
            if error_in then
                 writeln ('Error!')
      until not error_in;
      menu:=choice;
  end;

  procedure Add (var a:telem);
  var
   k,i:integer;
   b:telem;
   s:integer;
   begin
     writeln('ФИО');
     readln(b.FIO);
     writeln('Введите номер формы обучения(1.специалист 2.бакалавр 3.магистр)');
     readln(k);
     case k of
        1: b.f_study:=spez;
        2: b.f_study:=bakal;
        3: b.f_study:=magis
     end;
     writeln('Курс');
     readln(b.curs);
     writeln('Оценки');
     s:=0;
     for i:=1 to m do
     begin
        readln(b.balls[i]);
        s:=s+b.balls[i];
     end;
     b.med_ball:=s/m;
     a:=b;
   end;

   procedure swap(var x,y: telem);
   var
    t: telem;
   begin
    t := x;
    x := y;
    y := t
   end;

   procedure sort(var b:tmas);
   var
   i,j:integer;
   tmp:telem;
   begin
    for j:=1 to N-1 do
    for i:=1 to N-j do
     if (b[i].med_ball > b[i+1].med_ball) then
      swap(b[i],b[i+1]);
   end;

procedure Delete(var a:tmas; var p:integer; i:integer);
var
j:integer;
begin
if i<n then
  begin
    for j:=i+1 to n-p do
      a[j-1]:=a[j];
  end;
  p:=p+1;
end;

function Good(b:Tballs):boolean;
var
g:boolean;
i,j:integer;
begin
g:=true;  i:=1;
while (i<=5)and g do
     if b[i]<3 then
      begin
       g:=false;
        end
       else
       i:=i+1;
  Good:=g
  end;

function LevelUp (var a: tmas;p:integer):integer;
var
g,i:integer;
begin
for i:=n downto 1 do
  begin
  If Good(a[i].balls)then
  if ((curs=5) and (f_study=spez)) or ((curs=6) and (f_study=magic)) do
  begin
   Delete(a,g,i)
   else
   a[i].curs:=a[i].curs+1
    end;
  end;
  LevelUp:=p
end;

var
   a:tmas;
   mn,i:integer;
   exit_:char;
   p:integer;
begin
setconsolecp(1251);
setconsoleoutputcp(1251);
for i:=1 to n do
  Add(a[i]);
  writeln;
  REPEAT
    p:=0;
    mn:=Menu;
    case mn of
      1:begin
        sort(a);
        for i:=1 to n do
        begin
         write(a[i].FIO+' ');
         writeln(a[i].med_ball:4:4);
        end;
        end;
      2: begin
          p:=LevelUp(a,g);
          for i:=1 to n-p do
          begin
           write(a[i].FIO+' ');
          // writeln(a[i].med_ball:4:4);
          end;
         end;
     else
      begin
       writeln;
       write (' ','Завершить работу? (Y/N)');
       readln(exit_);
      end;
     end;
  UNTIL (exit_='y') or (exit_='Y') or (mn=3);
  readln;
end.

но он выдает куча ошибок,не пойму как их исправить..помогите....