Хостинг портала RFpro.ru:
Московский хостер
Профессиональный платный хостинг на базе Windows 2008

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Чемпионы рейтинга экспертов в этой рассылке

lamed Статус: Практикант Рейтинг: 2151 ∙ повысить рейтинг »

Boriss Статус: Академик Рейтинг: 1756 ∙ повысить рейтинг »

_Ayl_ Статус: Студент Рейтинг: 1566 ∙ повысить рейтинг »

Вопрос № 176552: Уважаемые эксперты,помогите написать программу: При помощи генератора случайных чисел задать последоватеьность из 100 элементов,каждый из которых целое число в диапазоне лт 1 до 100. Отсортировать такую последовательность в порядке возрастания ис...

Уважаемые эксперты,помогите написать программу:
При помощи генератора случайных чисел задать последоватеьность из 100 элементов,каждый из которых целое число в диапазоне лт 1 до 100. Отсортировать такую последовательность в порядке возрастания используя:а)метод прямого включения б) пузырьковую сортировку.
сравнить эффективность методов а и б подсчитывая в ходе выполнения программы кол-во сравнений С, и кол-во перестановок М, для каждого метода

Сортировки оформить в виде отдельных подпрограмм.
Спасибо

Отправлен: 07.02.2010, 18:37
Вопрос задал: Кусмарцев Андрей Валерьевич, 3-й класс
Всего ответов: 3
Страница вопроса »

Приложение:
Type mas = array [1..100] of 1..100; {Тип массив} Const N = 100; {Количество элементов} Var a, b: mas; {массивы} i, c, m: word; procedure SimpleSort (var a: mas; var c: word; var m: word); {сортировка методом выбора} Var i, j, min: word; Begin c:= 0; m:= 0; {сравнения и перестановки} for i:=2 to N do begin min:= a[i]; {ищем место для текущего элемента} j:= i-1; while (j>=1) and (a[j]>min) do begin a[j+1]:= a[j]; {Сразу сдвигаем остальные элементы, чтобы освободить место} dec (j); {не забываем уменьшить индекс} inc (c); {наращиваем количество сравнений и перестановок} inc (m); end; a[j+1]:= min; {вставляем элемент} end; end; procedure BubbleSort (var a: mas; var c: word; var m: word); Var i, j, buf: word; Begin c:=0; m:=0; {обнуляем счётчики} for i:=1 to N-1 do for j:=1 to N-i do begin inc (c); {сравниваем} if a[j] >= a[j+1] then begin {обмениваем} inc (m); buf:= a[j]; a[j]:= a[j+1]; a[j+1]:= buf; end; end; End; Begin Randomize; {инициализируем генератор случайных чисел} for i:=1 to N do Begin {наполняем массив элементами от 1 до 100 и копируем его в другой} a[i]:= random (100)+1; {random генерирует число от 0 до параметра-1, поэтому берём от 100 и +1} b[i]:= a[i]; end; SimpleSort (a, c, m); {вызываем сортировки и выводим результаты} writeln (\'Sravnenia: \', c); writeln (\'Perestanovki: \', m); writeln; for i:=1 to N do write (a[i]:3); writeln; BubbleSort (b, c, m); writeln (\'Sravnenia: \', c); writeln (\'Perestanovki: \', m); writeln; for i:=1 to N do write (b[i]:3); writeln; End.
-----
Эта история - не для истории, понимаешь?

Ответ отправил: Verena, Профессионал
Ответ отправлен: 07.02.2010, 19:27
Номер ответа: 259295

Оценка ответа: 5

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259295 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

program P_176552;

{ Константы }
const
    NUM_CNT=100;    { Количество чисел }
    NUM_LO=1;       { Минимальное значение }
    NUM_HI=100;     { Максимальное значение }

{
Типы }
type
    TArray=array[1..NUM_CNT] of Integer;    { Массив }
    { Процедура сортировки
      Sequence - последовательность
      Comparisions - сравнений
      Permutations - перестановок }
    TSortProc=procedure(var Sequence:TArray;var Comparisions,Permutations:Integer);

{ Заполняет массив случайными значениями в диапазоне [NUM_LO..NUM_HI] }
procedure CreateArray(var Sequence:TArray);
var
    i:Integer;
begin
    for i:=1
  to NUM_CNT do begin
        Sequence[i]:=Random(NUM_HI-NUM_LO+1)+NUM_LO;
    end;
end;

{ Выводит массив }
procedure PrintArray(Message:String;Sequence:TArray);
var
    i:Integer;
begin
    WriteLn(Message);
    for i:=1 to NUM_CNT do begin
        Write(Sequence[i]:4,' ');
    end;
    WriteLn;
end;

{ Пузырьковая сортировка }
procedure BubbleTest(var Sequence:TArray;var Comparisions,Permutations:Integer);
var
    i,j,Tmp:Integer;
begin

   { Обнулим счетчики }
    Comparisions:=0;
    Permutations:=0;
    for i:=1 to NUM_CNT-1 do begin
        for j:=1 to NUM_CNT-i do begin
            Inc(Comparisions);
            if Sequence[j]>Sequence[j+1] then begin
                Inc(Permutations);
                Tmp:=Sequence[j];
                Sequence[j]:=Sequence[j+1];
                Sequence[j+1]:=Tmp;
            end;
        end;
    end;
end;

{ С
 ортировка включением }
procedure InclusionTest(var Sequence:TArray;var Comparisions,Permutations:Integer);
var
    i,j,item:Integer;
begin
    { Обнулим счетчики }
    Comparisions:=0;
    Permutations:=0;
    for i := 2 to NUM_CNT do begin
        item:=Sequence[i];
        j:=i-1;
        Inc(Comparisions);
        { Ищем куда вставить }
        while (j>0) and (item<=Sequence[j]) do begin
            Inc(Comparisions);
            Inc(Permutations);

           Sequence[j+1]:=Sequence[j];
            Dec(j);
        end;
        Inc(Permutations);
        Sequence[j+1]:=item;
    end;
end;

{ Помогает нам оформить вывод }
procedure Test(Message:String;Sequence:TArray;Proc:TSortProc);
var
    Comparisions,Permutations:Integer;
begin
    WriteLn;
    Proc(Sequence,Comparisions,Permutations);
    WriteLn(Message);
    PrintArray('Массив после сортировки:',Sequence);<
 br>    WriteLn('Сравнений:',Comparisions);
    WriteLn('Перестановок:',Permutations);
end;

var
    Sequence:TArray;

begin
    Randomize;
    { Заполним массив }
    CreateArray(Sequence);
    { Выведем его }
    PrintArray('Исходный массив:',Sequence);
    { Проверяем }
    Test('Пузырьковая сортировка.',Sequence,@BubbleTest);
    Test('Сортировка включением.',Sequence,@InclusionTest);
end.

~/projects/Pascal> ./P_176552
Исходный массив:
  61   69   74   91   28   39   13   35   77   78   42   62   12   43   37   72 
  34   24   70  100   23   60   27    1   63   72   60   27   24   90   83   25 
  60   37   52  100   
 11   69   71   12   52   78   81   94   64   36   32   21 
  86   64   77   70   42   17   13   64    3   12   23   64   33    9   88  
 49 
   8   99   68   26   15   66   38   28   86   77   98   66    8   28   59   37 
  49   24   82   87    3   65   19   95   94   68   27   37   55   73   68   42 
   6   71   60    6 

Пузырьковая сортировка.
Массив после сортировки:
   1    3    3    6    6    8    8    9   11   12   12   12   13   13   15   17 
  19   21   23   23   24   24   24   25   26   27   27   27   28   28   28   32 
  33   34   35   36   37   37   37   37   38   39   42   42   42   43   49   49 
 
52   52   55   59   60   60   60   60   61   62   63   64   64   64   64   65 
  66   66   68   68   68   69   69   70   70   71   71   72   72   73   74   77 
  77   77   78   78   81   82   83   86   86   87   88   90   91   94   94   95 
  98   99  100  100 
Сравнений:4950
Перестановок:2512

Сортировка включением.
Массив после сортировки:
   1    3    3    6    6    8    8    9   11   12   12   12   13   13   15   17 
  19   21   23   23   
 24   24   24   25   26   27   27   27   28   28   28   32 
  33   34   35   36   37   37   37   37   38   39   42   42   42   43   49   49 
  52   52   55   59   60   60   60   60   61   62   63   64   64   64   64   65 
  66   66   68   68   68   69   69   70   70   71   71   72   72   73   74   77 
  77   77   78   78   81   82   83   86   86   87   88   90   91   94   94   95 
  98   99  100  100 
Сравнений:2666
Перестановок:2666

Ответ отправил: Micren, Профессионал
Ответ отправлен: 07.02.2010, 20:04
Номер ответа: 259297

Оценка ответа: 4

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259297 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

program Psort;

{$APPTYPE CONSOLE}

const
  n=100;

type
  XArray = array[1..n] of integer;

var
  x,y:XArray;
  i:integer;
  c,m:integer;

procedure InitData;
var

 i: integer;
begin
  Randomize;
  for i:=1 to n do begin
    x[i]:=Random(n)+1;
    y[i]:=x[i];
  end;
end;

procedure DirectIncludeSort;
var
  i,j,tmp:integer;
begin
  for i:=2 to n do begin
    tmp:=x[i];
    j:=i;
    while (j>1)and(tmp<x[j-1]) do begin
      x[j]:=x[j-1];
      j:=j-1;
      m:=m+1;
      c:=c+1;
    end;
    c:=c+1;
    x[j]:=tmp;
    m:=m+1
  end
end
 ;

procedure BubbleSort;
var
  i,j,tmp:integer;
begin
  for i:=1 to n-1 do
    for j:=n downto i+1 do
    begin
      if y[j-1]>y[j] then
      begin
        tmp:=y[j];
        y[j]:=y[j-1];
        y[j-1]:=tmp;
        m:=m+1;
      end;
      c:=c+1
    end
end;

begin
  InitData;
  for i:=1 to n do write('x[',i,']=',x[i],' ');
  writeln;
  c:=0;
  m:=0;
  DirectIncludeSort;
  writeln('c=',c,'
m=',m);
  for i:=1 to n do write('x[',i,']=',x[i],' ');
  writeln;
  c:=0;
  m:=0;
  BubbleSort;
  Writeln('c=',c,' m=',m);
  for i:=1 to n do write('x[',i,']=',y[i],' ');
  writeln;
  readln
end.

Ответ отправил: star9491, 5-й класс
Ответ отправлен: 07.02.2010, 23:42
Номер ответа: 259301

Оценка ответа: 5

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259301 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

Добрый вечер,уважаемые эксперты!!!
Помогите решить задачи:
Найти сумму элементов и произведение ниже главной диагонали
Проверить,содержит ли матрица нулевую строку
найти решение системы n линейных уравнений с n неизвестными треугольного вида

Отправлен: 08.02.2010, 01:46
Вопрос задал: angel.nero, Посетитель
Всего ответов: 2
Страница вопроса »

Приложение:
1.Найти сумму элементов и произведение ниже главной диагонали uses crt; const nmax=20; var a:array[1..nmax,1..nmax] of real; n,i,j:byte; sm,pr:real; begin clrscr; randomize; repeat write(\'Размер матрицы=\'); readln(n); until n in [1..nmax]; writeln(\'Исходная матрица:\'); for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=5*random; if j<i then{элементы ниже гл. диагонали } begin textcolor(12);{выделим красным цветом} write(a[i,j]:5:2); end else begin textcolor(15);{остальные по умолчанию, у меня белый} write(a[i,j]:5:2); end; end; writeln; end; writeln; sm:=0; pr:=1; for i:=2 to n do{от строки 2 до последней} for j:=1 to i-1 do{от столбца 1 не доходя до главной диагонали} begin sm:=sm+a[i,j];{сумма} pr:=pr*a[i,j];{произведение} end; writeln(\'Сумма=\',sm:0:2); write(\'Произведение=\',pr:0:2); readln end. 2.Проверить,содержит ли матрица нулевую строку uses crt; const nmax=20; var a:array[1..nmax,1..nmax] of integer; n,m,i,j,k,f:byte; begin clrscr; repeat write(\'Количество строк n=\'); readln(n); until n in [1..nmax]; repeat write(\'Количество столбцов m=\'); readln(m); until m in [1..nmax]; writeln(\'Введите \',n*m,\' элементов матрицы\'); for i:=1 to n do for j:=1 to m do begin write(\'a[\',i,\',\',j,\']=\'); readln(a[i,j]); end; clrscr; writeln(\'Исходная матрица:\'); for i:=1 to n do begin for j:=1 to m do write(a[i,j]:2,\' \'); writeln; end; writeln; f:=0;{пока строк с нолями нет} for i:=1 to n do{смотрим строки по порядку} begin k:=0;{пока нолей в строке нет} for j:=1 to m do{идем по строке} if a[i,j]=0 then k:=k+1;{считаем ноли} if k=m then{если все ноли} begin write(\'Матрица содержит нулевую строку ее номер=\',i); f:=1;{фиксируем} break;{дальше не ищем} end; end; if f=0 then write(\'Матрица не содержит нулевых строк\'); readln end. 3.Найти решение системы n линейных уравнений с n неизвестными треугольного вида uses crt; const nmax=20; var a:array[1..nmax,1..nmax] of real;{матрица коэффициентов} b,x:array[1..nmax] of real;{массивы свободных членов и корней системы} n,i,j,k:byte;{размер и счетчики циклов} r,g:real;{вспомогательные переменные} begin clrscr; randomize; repeat write(\'Количество уравнений=\'); readln(n); until n in [1..nmax]; writeln(\'Введите коэффициенты треугольной матрицы:\'); for i:=1 to n do{вводим по строкам} for j:=i to n do{от главной диагонали до кол-ва} begin write(\'a[\',i,\',\',j,\']=\'); readln(a[i,j]); end; writeln(\'Введите свободные члены:\'); for i:=1 to n do begin write(\'b[\',i,\']=\'); readln(b[i]); end; clrscr; writeln(\'Исходная матрица и свободные члены:\'); for i:=1 to n do begin for j:=1 to n do if j<i then write(\' \':5){до главной-пробелы} else write(a[i,j]:5:2);{дальше коэффициенты} write(b[i]:7:2);{свободные члены} writeln; end; writeln; for i:=n downto 1 do{обратный ход Гаусса, теорию в математике} begin if a[i,i]=0 then{если главный элемент=0, матрица выржденная} begin write(\'Решений нет!\'); readln; exit; end; r:=0; for j:=i+1 to n do begin g:=a[i,j]*x[j]; r:=r+g; end; x[i]:=(b[i]-r)/a[i,i]; end; writeln(\'Корни системы:\'); for i:=1 to n do write(\'x[\',i,\']=\',x[i]:0:2,\' \'); readln end.

Ответ отправил: Пупорев Юрий Борисович, Специалист
Ответ отправлен: 08.02.2010, 08:32
Номер ответа: 259307

Оценка ответа: 5
Комментарий к оценке:
Большое вам спасибо!!!!

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259307 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

Приложение:
{ Проверить,содержит ли матрица нулевую строку } Uses Crt; Const Rows = 5; Columns = 3; Var Ar: Array[1..Rows, 1..Columns] of Byte; col, row: Byte; flag: Boolean; begin ClrScr; Randomize; {Init array} for row:=1 to Rows do begin for col:=1 to Columns do begin Ar[row, col] := Random(2); Write(Ar[row, col]:4); end; WriteLn; end; {Search zero-row}; for row:=1 to Rows do begin flag := true; for col:=1 to Columns do begin if Ar[row, col] <> 0 then begin flag := false; break; end; end; if flag then break; end; if flag then Write(\'Found zero-row.\') else Write(\'Zero-row not found.\'); repeat until keypressed; end.
-----
Временная неудача лучше временной удачи

Ответ отправил: Andrew Kovalchuk, 4-й класс
Ответ отправлен: 08.02.2010, 15:29
Номер ответа: 259317

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259317 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

Помогите решить одну задачку:
Выполнить обмен в одномерном массиве,значениями максимального элемента и элемента,имеющего заданное значение(использовать ф-цию нахождения номера максимального элемента,ф-цию нахождения номера элемента, имеющего заданное значение,и процедуру обмена значениями двух элементов)

Отправлен: 08.02.2010, 02:01
Вопрос задал: angel.nero, Посетитель
Всего ответов: 2
Страница вопроса »

Приложение:
uses crt; const nmax=100;{максимальный размер массива} type mas=array[1..nmax] of integer;{тип массива} function Max(v:mas;x:byte):byte;{поиск номера максимального} var i,imx:byte; begin imx:=1; for i:=1 to x do if v[i]>v[imx] then imx:=i;{нашли} Max:=imx;{присвоили значение функции} end; function Zad(v:mas;x:byte;z:integer):byte;{поиск позиции заданного числа} var i,iz:byte; begin iz:=0; for i:=1 to x do if v[i]=z then{нашли число} begin iz:=i;{его номер} break;{дальше не ищем} end; Zad:=iz;{значение функции} end; procedure Obmen(var v:mas;x:byte;imx,iz:byte);{обмен максимального и заданного чисел} var b:integer; begin b:=v[imx];{простой обмен с использованием переменой-буфера} v[imx]:=v[iz]; v[iz]:=b; end; var a:mas; n,i,k,imax,izad:byte; begin clrscr; randomize; repeat write(\'Размер массива n=\'); readln(n); until n in [1..nmax]; writeln(\'Исходный массив:\'); for i:=1 to n do begin a[i]:=random(20)+1; write(a[i],\' \'); end; writeln; writeln; imax:=Max(a,n); writeln(\'Номер максимального=\',imax); write(\'Введите число для поиска k=\'); readln(k); izad:=Zad(a,n,k); if izad=0 then write(\'Числа \',k,\' в массиве нет!\'){если значение функции=0} else writeln(\'Номер числа \',k,\'=\',izad); if izad=imax then write(\'Число \',k,\' совпадает с максимальным значением!\'); if(izad>0)and(izad<>imax)then begin Obmen(a,n,imax,izad); writeln(\'Обмен элементов:\'); for i:=1 to n do write(a[i],\' \'); end; readln end.

Ответ отправил: Пупорев Юрий Борисович, Специалист
Ответ отправлен: 08.02.2010, 06:55
Номер ответа: 259305

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259305 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

Приложение:
{ Выполнить обмен в одномерном массиве,значениями максимального элемента и элемента, имеющего заданное значение(использовать ф-цию нахождения номера максимального элемента, ф-цию нахождения номера элемента, имеющего заданное значение и процедуру обмена значениями двух элементов) } Uses Crt; Const MaxCount = 10; Var Ar: Array[1..MaxCount] of Byte; indexMax, indexEl, i, index, max: Byte; function getIndexOfMaxElement: Byte; begin index := 1; max := Ar[1]; for i := 2 to MaxCount do if max < Ar[i] then begin max := Ar[i]; index := i; end; getIndexOfMaxElement := index; end; function getIndexOfElement(num: Byte): Byte; begin index := 0; for i:= 1 to MaxCount do if Ar[i] = num then begin index := i; break; end; getIndexOfElement := index; end; procedure Exchange(idx1, idx2 : Byte); var tmp : Byte; begin tmp := Ar[idx1]; Ar[idx1] := Ar[idx2]; Ar[idx2] := tmp; end; begin ClrScr; Randomize; for i := 1 to MaxCount do begin Ar[i] := Random(255); Write(Ar[i]:5); end; WriteLn; indexMax := getIndexOfMaxElement; indexEl := getIndexOfElement(Ar[Random(MaxCount) + 1]); Exchange(indexMax, indexEl); for i := 1 to MaxCount do begin if (i = indexMax) or (i = indexEl) then TextAttr := $0A else TextAttr := $07; Write(Ar[i]:5); end; repeat until keypressed; end.
-----
Временная неудача лучше временной удачи

Ответ отправил: Andrew Kovalchuk, 4-й класс
Ответ отправлен: 08.02.2010, 12:30
Номер ответа: 259310

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это! Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 259310 на номер 1151 (Россия) | Еще номера »

Отправить WebMoney: Неплохо (30 руб.) Хорошо (40 руб.) Отлично (55 руб.) БЛЕСТЯЩЕ! (80 руб.)

Оценить выпуск »
Нам очень важно Ваше мнение об этом выпуске рассылки!

Задать вопрос экспертам этой рассылки »