Помощь - Поиск - Пользователи - Календарь
Полная версия: Упорядочить массив по среднему баллу
Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи
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
Окей,поможем, давайте только вы скажете,что именно не работает, что не можете придумать.
Еще я не улавливаю смысла делать в record еще один record.И еще 1 вопрос:"Вы используете Builder?"
Насчет процедуры form;

for i:=1 to n do
readln(b.pred[j]);
a[i]:=b


Нигде в вашей функции j больше не фигурирует, так что оно работать не будет,а точнее если j инициализируется нулем,то запись будет всегда производиться в 1 и ту же ячейку,а если каким нибудь значением за пределами нашего массива,так вообще вылетит с ошибкой.
natik3
Цитата(Krjuger @ 22.05.2012 11:58) *

Окей,поможем, давайте только вы скажете,что именно не работает, что не можете придумать.
Еще я не улавливаю смысла делать в record еще один record.И еще 1 вопрос:"Вы используете Builder?"
Насчет процедуры form;

for i:=1 to n do
readln(b.pred[j]);
a[i]:=b


Нигде в вашей функции j больше не фигурирует, так что оно работать не будет,а точнее если j инициализируется нулем,то запись будет всегда производиться в 1 и ту же ячейку,а если каким нибудь значением за пределами нашего массива,так вообще вылетит с ошибкой.

я чуть чуть сама исправила свои недочеты.вот что получилось
Код
program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows;

const n=5;
type
    formob=(spez,bakal,magis);
    Tballs=array[1..5]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;
var
a:tmas;
b:array[1..n]of string[30];
  s,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.FIO);
  writeln('Ввести номер формы обучения');
  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 n do
   begin
    readln(b.balls[j]);
    s:=s+b.balls[j]
   end;
  b.med_ball:=s/5;
  a[i]:=b
   end;


   procedure sort(var b:tmas);
var
i,j:integer;
tmp:telem;
begin
   for i:=1 to n do
    if b[i].med_ball>b[i+1].med_ball 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;  m:=n;
//---------------------
Function Dvoechnik (b:tmas);
var i,k:integer;
  for i:=1 to n do
    Begin
      If a[i]<3 then
         k:=k+1
    end;
//---------------------
  Procedure Delete(k1:Integer;Var b:tmas);
Var i : Integer;
Begin {сдвиг элементов на один влево}
For i:=k1 To n-1 Do
b[n]:= b[i+1]; {i-му элементу присваиваем значение (i+1)-го}
b[n]:=0;{последний элемент равен 0}
End;
   //---------------------
while i<=n do
if Dvoechnik(a[i].balls) then
     if (course=5) and ( f_study=spez) or (course=6) and  ( f_study=magis ) then
         begin
           Delete(k1);
           m:=m-1;
         else
      a[i].course:= course+1
          end;
          end;
   SetConsoleOutputCP(1251);
  form(а);
  writeln;
  REPEAT
    mn:=Menu;
    case mn of
     1:begin

          sort(а);

       end;
     2: begin
     Dvoechnik(d);
          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
Давайте не лезть вперед паровоза,у вас и без удаления много ошибок,щас будем потихоньку разгребать.Кстати скажите,что за компилятор вы используете?
natik3
Цитата(Krjuger @ 22.05.2012 14:26) *

Давайте не лезть вперед паровоза,у вас и без удаления много ошибок,щас будем потихоньку разгребать.Кстати скажите,что за компилятор вы используете?

Delphi 7
Krjuger
Значит так,начнем разбор полетов.

Tballs=array[1..5]of 1..5;
for i:=1 to n do
begin
readln(b.balls[j]);
s:=s+b.balls[j]
end;
b.med_ball:=s/5;
a[i]:=b
end;


Я уже писал j у нас нигде не меняется и не участвует!!!!!!!!!Если мы считываем и суммируем оценки за предмет,то нам нужна изменяющаяся переменная.
Меняем.
readln(b.balls[i]);
s:=s+b.balls[i];
Но теперь возникла проблема, если мы изменим n например на 6, то мы будем считать 6 предметов,а тип Tballs у нас описан как массив строго из 5 элементов, исправляем.
Tballs=array[1..n]of 1..5;
Продолжаем, у нас получатся,что количество студентов навно n и количество предметов у каждого студента равно n, это непорядок, вводим вторую константу m.Пускай n- кол во студентов,а m- кол-во предметов.
В общем немного поработав с твоим кодом родилось нечто подобное.

const n=3;
const m=3;
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;

var
a:tmas;
mn,i:integer;
exit_:char;
begin
for i:=1 to n do
Add(a[i]);

writeln;
REPEAT
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
{Dvoechnik(d); }
Writeln('Перевод на следующий курс');
end;
else
begin
writeln;
write (' ','Завершить работу? (Y/N)');
readln(exit_);
end;
end;
UNTIL (exit_='y') or (exit_='Y') or (mn=3);
readln;
end.


Тут оно еще и сортирует правильно,я надеюсь тебе надо было отсортировать по возрастанию.

А теперь общие коментарии по твоему коду.

Не перескакивай в написании переменных,типов,профедур, и всего остального с заглавные букв на мелкие и обратно, паскаль это кушает, но в большинстве языков это неприемлемо и будут из-за этого ошибки.
Не создавай кучу переменных, которые ты не используешь.
Не нужно создавать глобальные переменные, когда все спокойно делается с локальными.
b:array[1..n]of string[30]; я так и не понял,где это вообще используется и просто удалил,работоспособность не изменилась, тоже самое относится к половине переменных в твоей процедуре form.
choice:integer;
error_in: boolean;
я сделал локальными, они нам просто не нужны как глобальные.
Если программа подразумевает маштабируемость,т.е. изменение размеров массивов,то ненадо использовать числа,иначе потом придется ползать по всех программе и искать их,а так забудешь одно число поменять и будешь получать вылеты за границы массива,оно тебе надо?
natik3
Цитата(Krjuger @ 22.05.2012 15:23) *

Значит так,начнем разбор полетов.

Tballs=array[1..5]of 1..5;
for i:=1 to n do
begin
readln(b.balls[j]);
s:=s+b.balls[j]
end;
b.med_ball:=s/5;
a[i]:=b
end;


Я уже писал j у нас нигде не меняется и не участвует!!!!!!!!!Если мы считываем и суммируем оценки за предмет,то нам нужна изменяющаяся переменная.
Меняем.
readln(b.balls[i]);
s:=s+b.balls[i];
Но теперь возникла проблема, если мы изменим n например на 6, то мы будем считать 6 предметов,а тип Tballs у нас описан как массив строго из 5 элементов, исправляем.
Tballs=array[1..n]of 1..5;
Продолжаем, у нас получатся,что количество студентов навно n и количество предметов у каждого студента равно n, это непорядок, вводим вторую константу m.Пускай n- кол во студентов,а m- кол-во предметов.
В общем немного поработав с твоим кодом родилось нечто подобное.

const n=3;
const m=3;
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;

var
a:tmas;
mn,i:integer;
exit_:char;
begin
for i:=1 to n do
Add(a[i]);

writeln;
REPEAT
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
{Dvoechnik(d); }
Writeln('Перевод на следующий курс');
end;
else
begin
writeln;
write (' ','Завершить работу? (Y/N)');
readln(exit_);
end;
end;
UNTIL (exit_='y') or (exit_='Y') or (mn=3);
readln;
end.


Тут оно еще и сортирует правильно,я надеюсь тебе надо было отсортировать по возрастанию.

А теперь общие коментарии по твоему коду.

Не перескакивай в написании переменных,типов,профедур, и всего остального с заглавные букв на мелкие и обратно, паскаль это кушает, но в большинстве языков это неприемлемо и будут из-за этого ошибки.
Не создавай кучу переменных, которые ты не используешь.
Не нужно создавать глобальные переменные, когда все спокойно делается с локальными.
b:array[1..n]of string[30]; я так и не понял,где это вообще используется и просто удалил,работоспособность не изменилась, тоже самое относится к половине переменных в твоей процедуре form.
choice:integer;
error_in: boolean;
я сделал локальными, они нам просто не нужны как глобальные.
Если программа подразумевает маштабируемость,т.е. изменение размеров массивов,то ненадо использовать числа,иначе потом придется ползать по всех программе и искать их,а так забудешь одно число поменять и будешь получать вылеты за границы массива,оно тебе надо?


ты не представляешь,как я тебе благодарна...только буду оч признательна,если поможешь разобраться еще с переводом на следующий курс...
Krjuger
Тут есть 2 варианта,либо сначала повысить всем,а потом удалить тех кто привысил лимит, либо повыщать только тем,кто не заканчикает универ, а остальных сразу удалять.
Вот пример второго варианта, осталось только функцию удаления написать)

for i:=n downto 1 do
begin
if ((a[i].f_study=magis) and (a[i].curs<6)) or ((a[i].f_study=spez) and (a[i].curs<5)) or ((a[i].f_study=bacal) and (a[i].curs<4)) then
a[i].curs:=a[i].curs+1
else
Delete(a,i);
end;


Ее попробуйте сами сделать)
natik3
Цитата(Krjuger @ 22.05.2012 18:17) *

Тут есть 2 варианта,либо сначала повысить всем,а потом удалить тех кто привысил лимит, либо повыщать только тем,кто не заканчикает универ, а остальных сразу удалять.
Вот привер второго варианта, осталось только функцию удаления написать)

for i:=n downto 1 do
begin
if ((a[i].f_study=magis) and (a[i].curs<6)) or ((a[i].f_study=spez) and (a[i].curs<5)) or ((a[i].f_study=bacal) and (a[i].curs<4)) then
a[i].curs:=a[i].curs+1
else
Delete(a,i);
end;




ну вот смотри,что получилось..только вот функция по поиску двоичников и удаления K элемента...явно что то не то...
Код

Procedure perevod (var b:tmas);
var i,k:integer;
i:=1; k:=0;  d:=n;
//---------------------
Function Dvoechnik (b:tmas);
var i,k:integer;
  for i:=1 to n do
    Begin
      If a[i]<3 then
         k:=k+1
    end;
//---------------------
  Procedure Delete(k1:Integer;Var b:tmas);
Var i : Integer;
Begin
For i:=k1 To n-1 Do
b[n]:= b[i+1];
b[n]:=0;
End;
   //---------------------
while i<=n do
if Dvoechnik(a[i].balls) then

for i:=1 to n do
        begin
        if Dvoechnik(a[i].balls) then

for i:=1 to n do
     if (course=5) and ( f_study=spez) or (course=6) and  ( f_study=magis ) then
         begin
           Delete(k1);
           d:=d-1;
         else
       a[i].curs:=a[i].curs+1;
          end;
          end;
          
Krjuger
Ненене, ты что то перемудрила.))

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

procedure Otchislenie(var a: tmas;p:integer);
var
i:integer;
begin
for i:=n downto 1 do
if a[i]<3 then
Delete(a,n,i);
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 do
a[j-1]:=a[j];
p:=p+1;
end
else
p:=p+1;
end;


А выводишь на экран так:

for i:=1 to n-p do
begin
write(a[i].FIO+' ');
writeln(a[i].med_ball:4:4);
end;


Забыл предупредить,писал сразу на форум, так что могут быть ошибки.Как только доберусь до компилятора сразу проверю,а пока, если найдешь ошибки,попробуй сама исправить))))
natik3
Цитата(Krjuger @ 22.05.2012 18:53) *

Ненене, ты что то перемудрила.))

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

procedure Otchislenie(var a: tmas;p:integer);
var
i:integer;
begin
for i:=n downto 1 do
if a[i]<3 then
Delete(a,n,i);
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 do
a[j-1]:=a[j];
p:=p+1;
end
else
p:=p+1;
end;


А выводишь на экран так:

for i:=1 to n-p do
begin
write(a[i].FIO+' ');
writeln(a[i].med_ball:4:4);
end;


Забыл предупредить,писал сразу на форум, так что могут быть ошибки.Как только доберусь до компилятора сразу проверю,а пока, если найдешь ошибки,попробуй сама исправить))))

просто преподаватель сказал делать по такой структуре.вот я и пыталась сообразить)))
он тут почему то выдает много ошибок,связанных с несовместимостью типов и ругается на Delete(a,p,i);...и честно признаться я не совсем понимаю что этот оператор делает..прости за мою тормознутость(
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) он ругался потому,что сама функция описана ниже,чем место где она используется, поэтому кампилятор не мог понять,откуда ее брать,он наперед заглядывать не умеет.
natik3
Цитата(Krjuger @ 22.05.2012 20:58) *

Эх окей))

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) он ругался потому,что сама функция описана ниже,чем место где она используется, поэтому кампилятор не мог понять,откуда ее брать,он наперед заглядывать не умеет.

ты просто не представляешь,как я тебе благодарна..у меня просто нет слов.огромное тебе спасибо..большое большое..если вдруг,что найду.обязательно скажу.СПАСИБО,еще раз)))
natik3
Цитата(Krjuger @ 22.05.2012 20:58) *

Эх окей))

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.

но он выдает куча ошибок,не пойму как их исправить..помогите....
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 Dvoechnik(var a: telem):boolean;
var
flag:boolean;
i,j:integer;
begin
flag:=false;
for j:=1 to m do
begin
if (a.balls[j]<3) then
begin
flag:=true;
break;
end;
end;
Dvoechnik:=flag;
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
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
else
begin
if ((a[i].f_study=spez) and (a[i].curs<5)) then
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
else
begin
if ((a[i].f_study=bakal) and (a[i].curs<4)) then
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
else
Delete(a,p,i);
end;
end;
end;
LevelUp:=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);
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.


Проверять щас не могу, проверьте сами,но оно точно откомпилируется.
natik3
Цитата(Krjuger @ 3.06.2012 14:43) *

Вы уж извините,но копаться в том,что вы изменили я не стал, я взял,что сам сделал и изменил.

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 Dvoechnik(var a: telem):boolean;
var
flag:boolean;
i,j:integer;
begin
flag:=false;
for j:=1 to m do
begin
if (a.balls[j]<3) then
begin
flag:=true;
break;
end;
end;
Dvoechnik:=flag;
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
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
else
begin
if ((a[i].f_study=spez) and (a[i].curs<5)) then
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
else
begin
if ((a[i].f_study=bakal) and (a[i].curs<4)) then
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
else
Delete(a,p,i);
end;
end;
end;
LevelUp:=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);
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.


Проверять щас не могу, проверьте сами,но оно точно откомпилируется.

спасибо большое..а еще вопрос.."break" можно убрать или заменить чем нибудь,а то она ругаетя,когда мы используем его
IUnknown
function Dvoechnik(var a: telem):boolean;
var
j: integer;
begin
Dvoechnik := True;
for j:=1 to m do
begin
if (a.balls[j]<3) then Exit
end;
Dvoechnik := False;
end;
Krjuger
Странный у вас преподаватель.
break - это функция прерывания цикла до его завершения по условию. Если у нас нет необходимости проходить цикл,а мы идем до первого появления чего-нибудь,то это экономит время,уменьшая время работы программы.Без него можно обходиться,как продемонстрировал IUnknown, но для этого пришлось пораскинуть мозгами, по крайней мере мне точно. И не всегда от него так просто избавиться.
natik3
Цитата(Krjuger @ 3.06.2012 17:59) *

Странный у вас преподаватель.
break - это функция прерывания цикла до его завершения по условию. Если у нас нет необходимости проходить цикл,а мы идем до первого появления чего-нибудь,то это экономит время,уменьшая время работы программы.Без него можно обходиться,как продемонстрировал IUnknown, но для этого пришлось пораскинуть мозгами, по крайней мере мне точно. И не всегда от него так просто избавиться.

что она странная,я согласна...я вас конечно достала,но все же я не могу понять..в последней,вами переделанной версии, она переводит абсолютно всех.т е почему то не удаляет закончивших курс обучения...и условие функции двоечник тоже не выполняется.вы бы не могли бы посмотреть?(
Krjuger
Да я допустил маленькую ошибочку,bеgin еnd не расставил, щас просто программирую больше на дугом языке.

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
begin
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1;
end
else
begin
if ((a[i].f_study=spez) and (a[i].curs<5)) then
begin
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1;
end
else
begin
if ((a[i].f_study=bakal) and (a[i].curs<4)) then
begin
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
end
else
Delete(a,p,i);
end;
end;
end;
LevelUp:=p;
end;


Вот так вроде работает.
Но я использовал свое условие,а не IUnknown.
У программы на данный момент есть 1 недостаток.Если например специалист на 5 курсе получает 2, то его не оставляют на 2 год а все равно удаляют. Поскольку, я не знаю,как в этой ситуации поступать, я менять ничего не стал,но если все равно нужно из-за двойки оставлять на том же курсе,то в строчке
if ((a[i].f_study=spez) and (a[i].curs<5)) then

Вместо < ставиться <=, то есть она будет выглядеть.
if ((a[i].f_study=spez) and (a[i].curs<=5)) then

И так для всех трех, бакалавров,спецов и магистров.
natik3
Цитата(Krjuger @ 4.06.2012 22:59) *

Да я допустил маленькую ошибочку,bеgin еnd не расставил, щас просто программирую больше на дугом языке.

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
begin
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1;
end
else
begin
if ((a[i].f_study=spez) and (a[i].curs<5)) then
begin
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1;
end
else
begin
if ((a[i].f_study=bakal) and (a[i].curs<4)) then
begin
if not Dvoechnik(a[i]) then
a[i].curs:=a[i].curs+1
end
else
Delete(a,p,i);
end;
end;
end;
LevelUp:=p;
end;


Вот так вроде работает.
Но я использовал свое условие,а не IUnknown


он все равно двоечников переводит...( их не надо удалять но и переводить не надо.это функция должна быть как условие...
Krjuger
Окей. Тогда вынесем проверку на двоечника вперед,чтобы в случае чего вообще не рассматривать проверку на специальность и курс.

function LevelUp(var a: tmas; p:integer):integer;
var
i:integer;
begin
for i:=n downto 1 do
begin
if not Dvoechnik(a[i]) then
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;
end;
LevelUp:=p;
end;

natik3
Цитата(Krjuger @ 4.06.2012 23:26) *

Окей. Тогда вынесем проверку на двоечника вперед,чтобы в случае чего вообще не рассматривать проверку на специальность и курс.

function LevelUp(var a: tmas; p:integer):integer;
var
i:integer;
begin
for i:=n downto 1 do
begin
if not Dvoechnik(a[i]) then
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;
end;
LevelUp:=p;
end;




я знаю,что я тебя достала,но все равно двоечников переводит..(
Krjuger
Показывай твой код потому что у мня не переводит......
natik3
Цитата(Krjuger @ 4.06.2012 23:42) *

Показывай твой код потому что у мня не переводит......

Код

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.Выход');
      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('ФИО');
     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 Dvoechnik(var a: telem):boolean;
var
flag:boolean;
i,j:integer;
begin
flag:=false;
   for j:=1 to m do
    begin
     if (a.balls[j]<3) then
      begin
       flag:=true;
      end;
    end;
Dvoechnik:=flag;
end;
function LevelUp(var a: tmas; p:integer):integer;
var
i:integer;
begin
for i:=n downto 1 do
  begin
    if not Dvoechnik(a[i]) then
     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;
    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,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.

я ничего не меняла.только чтоб на русском выводилось и все
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.Сортировка');
writeln (' ','2.Перевод на следующий курс');
writeln (' ','3.Выход');
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('ФИО');
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 Dvoechnik(var a: telem):boolean;
var
flag:boolean;
i,j:integer;
begin
flag:=false;
for j:=1 to m do
begin
if (a.balls[j]<3) then
begin
flag:=true;
end;
end;
Dvoechnik:=flag;
end;
function LevelUp(var a: tmas; p:integer):integer;
var
i:integer;
begin
for i:=n downto 1 do
begin
if not Dvoechnik(a[i]) then
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;
end;
LevelUp:=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);
for i:=1 to n-p do
begin
write(a[i].FIO+' ');
writeln(a[i].curs);
end;
end;
else
begin
writeln;
write (' ','Завершить работу? (Y/N)');
readln(exit_);
end;
end;
UNTIL (exit_='y') or (exit_='Y') or (mn=3);
readln;
end.


Я удалил всякие satcosole потому,что у меня турбопаскаль,но сути дела не меняет.
Вот что я запускаю
qwerty
2
5
3
3
asdfg
2
5
4
2
zxcvb
2
2
4
4
В итоге на выходе у меня написано.
asdfg 5, собственно он остался на 5 курсе из-за двойки и zxcvb переведен на 3 курс,а qwerty был удален.
Что я делаю не так????????????
Дайте мне тесты,когда это не работает????????
natik3
Цитата(Krjuger @ 5.06.2012 0:00) *

Девушка, либо я дурак,либо что-то тут не так,но вот смотрите, вот что я запускаю.

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.Выход');
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('ФИО');
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 Dvoechnik(var a: telem):boolean;
var
flag:boolean;
i,j:integer;
begin
flag:=false;
for j:=1 to m do
begin
if (a.balls[j]<3) then
begin
flag:=true;
end;
end;
Dvoechnik:=flag;
end;
function LevelUp(var a: tmas; p:integer):integer;
var
i:integer;
begin
for i:=n downto 1 do
begin
if not Dvoechnik(a[i]) then
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;
end;
LevelUp:=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);
for i:=1 to n-p do
begin
write(a[i].FIO+' ');
writeln(a[i].curs);
end;
end;
else
begin
writeln;
write (' ','Завершить работу? (Y/N)');
readln(exit_);
end;
end;
UNTIL (exit_='y') or (exit_='Y') or (mn=3);
readln;
end.


Я удалил всякие satcosole потому,что у меня турбопаскаль,но сути дела не меняет.
Вот что я запускаю
qwerty
2
5
3
3
asdfg
2
5
4
2
zxcvb
2
2
4
4
В итоге на выходе у меня написано.
asdfg 5, собственно он остался на 5 курсе из-за двойки и zxcvb переведен на 3 курс,а qwerty был удален.
Что я делаю не так????????????
Дайте мне тесты,когда это не работает????????


смотрите у вас у asdfg есть оценка 2 и,если я правильно понимаю,когда мы выбираем пункт перевод на следующий курс он у нас печатает его в списке переведенных?или как?

вот смотрите,что ввожу я
ФИО
иванов
Номер формы обучения(1.специалист 2. бакалавр 3. магистр)
1
Курс
5
Оценка
4
5
ФИО
сидоров
Номер формы обучения(1.специалист 2. бакалавр 3. магистр)
2
Курс
3
Оценка
2
5
ФИО
петров
Номер формы обучения(1.специалист 2. бакалавр 3. магистр)
3
Курс
2
Оценка
4
5


1.Сортировка
2.Перевод на следующий курс
3.Выход
Choice: 2
сидоров 3.5000
петров 4.5000

1.Сортировка
2.Перевод на следующий курс
3.Выход
Choice:

он переводит сидорова...хотя он не должен этого делать,т к у него есть оценка 2!
Krjuger
Блииииин, я столько работы зря проделал.
Девушка не глупите.
Он выводит не список тех кого переводит, а список ВСЕХ кто щас учится, я же дописал,чтобы выводило номер курса.Правильно, он выводит сидорова,потому что он не закончил обучение, он остался на том же курсе,что и был.
Выведите вместо средней оценки номер их курсов и все увидите.
Если не верите, то повысьте их еще на курс,если бы сидорова повышали на курс,то при втором повышении на курс он оканчивал бы обучение и был бы удален из списка.
natik3
Цитата(Krjuger @ 5.06.2012 0:15) *

Блииииин, я столько работы зря проделал.
Девушка не глупите.
Он выводит не список тех кого переводит, а список ВСЕХ кто щас учится, я же дописал,чтобы выводило номер курса.Правильно, он выводит сидорова,потому что он не закончил обучение, он остался на том же курсе,что и был.
Выведите вместо средней оценки номер их курсов и все увидите.
Если не верите, то повысьте их еще на курс,если бы сидорова повышали на курс,то при втором повышении на курс он оканчивал бы обучение и был бы удален из списка.

я тупица...(((((( я знаю ,что вы это знаете ,но все же..сейчас перечитала условие задачи и взглянула на него по новому...т е,нам нужно перевести студентов всех студентов,а только 5 курса (специалитета) и 6-ого курса (магистратуры) проверить на наличие двоек и если они присутствуют то тогда оставляем,а если отсутствуют тогда удаляем их?правильно я прнимаю?
Krjuger
Вы у меня спрашиваете?????Я условие в глаза не видел)))))))
Но если руководстоваться здравым смыслом.
Если студент сдает сессию без двоек, его переводят на слудующий курс, если курс последний для его формата обучения, то считается,что он закончил институт, то есть его удаляют из списка учащихся.
Если студент получает хотябы 1 двойку, то в реальной жизни есть несколько вариантов, первый, его отчисляют,что изначально я и сделал, вы сказали, что его не надо отчислять, это значит,что его оставляют на второй год,но студентом то он быть не перестает,следовательно из списка студентов не пропадает.
Цитата
а только 5 курса (специалитета) и 6-ого курса (магистратуры) проверить на наличие двоек и если они присутствуют то тогда оставляем,а если отсутствуют тогда удаляем их?правильно я прнимаю?

Не совсем, проверяем студентов всех курсов если у них есть двойка,то оставляем их на том же курсе,где они и были.Если нет двоек, переводим, а если они еще и на последнем курсе,так вообще удаляем,считая,что они закончили обучение.
natik3
Цитата(Krjuger @ 5.06.2012 0:34) *

Вы у меня спрашиваете?????Я условие в глаза не видел)))))))
Но если руководстоваться здравым смыслом.
Если студент сдает сессию без двоек, его переводят на слудующий курс, если курс последний для его формата обучения, то считается,что он закончил институт, то есть его удаляют из списка учащихся.
Если студент получает хотябы 1 двойку, то в реальной жизни есть несколько вариантов, первый, его отчисляют,что изначально я и сделал, вы сказали, что его не надо отчислять, это значит,что его оставляют на второй год,но студентом то он быть не перестает,следовательно из списка студентов не пропадает.

Не совсем, проверяем студентов всех курсов если у них есть двойка,то оставляем их на том же курсе,где они и были.Если нет двоек, переводим, а если они еще и на последнем курсе,так вообще удаляем,считая,что они закончили обучение.

я чувствую себя идиоткой..наверно я ей и являюсь..((( я узнаю подробно завтра у преподавателя...спасибо большое за помощь!

Добавлено через 5 мин.
Цитата(Krjuger @ 5.06.2012 0:34) *

Вы у меня спрашиваете?????Я условие в глаза не видел)))))))
Но если руководстоваться здравым смыслом.
Если студент сдает сессию без двоек, его переводят на слудующий курс, если курс последний для его формата обучения, то считается,что он закончил институт, то есть его удаляют из списка учащихся.
Если студент получает хотябы 1 двойку, то в реальной жизни есть несколько вариантов, первый, его отчисляют,что изначально я и сделал, вы сказали, что его не надо отчислять, это значит,что его оставляют на второй год,но студентом то он быть не перестает,следовательно из списка студентов не пропадает.

Не совсем, проверяем студентов всех курсов если у них есть двойка,то оставляем их на том же курсе,где они и были.Если нет двоек, переводим, а если они еще и на последнем курсе,так вообще удаляем,считая,что они закончили обучение.

у меня появилась еще одна глупая мысль..смотрите..нам по условию надо перевести студентов на следующий курс...но если они имеют хотя бы одну двойку,то они остаются на второй год => в списке тех студентов,которых перевели на следующий курс они не должны быть..вот поэтому меня и смущало то,что оно выводит...
Krjuger
Понимаете, у вас не настолько хорошо структурированные данные.Если бы у вас для каждой специальности для каждого курса был свой собственный список студентов, тогда да это имело бы смысл,а так вы не выводите ни по курсам, ни по специальностям, какой смысл выводить тех,кто переведен,если люди с двойкой тоже являются студентами, просто их товарищи перешли на курс выше, а они остались.
Проще вывести всех,указав, что эти остались на 2 курсе, эти переведены на 3, эти на 4 и тд.
Конешно же можно было бы сделать подменю, сделать функцию,которая выводила бы всех студентов заданной специальности на определенном курсе,но каждый раз вбивать этот список,чтобы хотябы по 2-3 человека на каждой специальности хотябы на половине курсов........это порядка 15-20 человек. я точно не стану такое проверять.
natik3
Цитата(Krjuger @ 5.06.2012 0:51) *

Понимаете, у вас не настолько хорошо структурированные данные.Если бы у вас для каждой специальности для каждого курса был свой собственный список студентов, тогда да это имело бы смысл,а так вы не выводите ни по курсам, ни по специальностям, какой смысл выводить тех,кто переведен,если люди с двойкой тоже являются студентами, просто их товарищи перешли на курс выше, а они остались.
Проще вывести всех,указав, что эти остались на 2 курсе, эти переведены на 3, эти на 4 и тд.
Конешно же можно было бы сделать подменю, сделать функцию,которая выводила бы всех студентов заданной специальности на определенном курсе,но каждый раз вбивать этот список,чтобы хотябы по 2-3 человека на каждой специальности хотябы на половине курсов........это порядка 15-20 человек. я точно не стану такое проверять.

спасибо..я завтра все узнаю.как точно надо делать..
Krjuger
То, что четко не обговорено в задании или преподавателем, в университете остается на рассмотрении того,кто выполняет задание, я больше чем уверен,если вы сможете обосновать то, почему вы сделали именно так,у вас примут задачу.
natik3
Цитата(Krjuger @ 5.06.2012 0:51) *

Понимаете, у вас не настолько хорошо структурированные данные.Если бы у вас для каждой специальности для каждого курса был свой собственный список студентов, тогда да это имело бы смысл,а так вы не выводите ни по курсам, ни по специальностям, какой смысл выводить тех,кто переведен,если люди с двойкой тоже являются студентами, просто их товарищи перешли на курс выше, а они остались.
Проще вывести всех,указав, что эти остались на 2 курсе, эти переведены на 3, эти на 4 и тд.
Конешно же можно было бы сделать подменю, сделать функцию,которая выводила бы всех студентов заданной специальности на определенном курсе,но каждый раз вбивать этот список,чтобы хотябы по 2-3 человека на каждой специальности хотябы на половине курсов........это порядка 15-20 человек. я точно не стану такое проверять.

А нельзя сделать в этой же задачи так,чтобы студенты с двойками не выводились..т е выводились только те,которые ПЕРЕВЕЛИСЬ на следующих курс...без вбивания каждой специальности и каждого курса....?
Krjuger
Конешно можно, но на мой взгляд это глупость несустветная.
2: begin
p:=LevelUp(a,p);
for i:=1 to n-p do
begin
if not Dvoechnik(a[i]) then
begin
write(a[i].FIO+' ');
writeln(a[i].curs);
end;
end;
end;

Я забыл про функцию двоечника, лучше использовать ее.
natik3
Цитата(Krjuger @ 5.06.2012 1:09) *

Конешно можно, но на мой взгляд это глупость несустветная.
2: begin
p:=LevelUp(a,p);
for i:=1 to n-p do
begin
if not Dvoechnik(a[i]) then
begin
write(a[i].FIO+' ');
writeln(a[i].curs);
end;
end;
end;

Я забыл про функцию двоечника, лучше использовать ее.

спасибо огромное!!!даже не знаю как благодарить!я завтра все точно узнаю как надо и что..но все равно..огромное спасибо.даже слов нет
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.