Хочу получить размещения из n элементов по m элементов. Для этого для каждого возможного сочетания из n по m нахожу перестановки по m. Проблема в том, что размещений получается больше чем нужно!! Объясните пожалуста, чего я не предусмотрела!

uses crt;

type
    mas=array[0..100] of integer;
    mas1=array[1..100] of integer;

Var
   razm,razm1 : mas;
   s : mas1;
   m,n,k,f,kol  : integer;
   i,j : byte;

procedure output;
var i: integer;
begin
  for i:=1 to m do write(s[razm[i]]);
end;

procedure output1;
var i: integer;
begin
  for i:=1 to m do write(s[razm1[i]]);
end;

Begin
clrscr;
writeln ('Naidem razmeshenia iz n elementov no m');
writeln ('Enter n and m');
readln (n,m);
writeln ('Vvedite mn-vo razmerom n');
for i := 1 to n do
    readln (s[i]);
writeln ('Mn-vo razmerom n:'); writeln;
for i := 1 to n do
    write ( s[i]:5);
readln;
clrscr;
for i:=1 to m do razm[i]:=i;
for i:=1 to m do razm1[i]:=i;
kol := 0;
while i <> 0 do
      begin
           output; write(' '); kol := kol + 1;
           for i := 1 to m do razm1[i] := razm[i];
           repeat
                 i:=m;
                 while razm1[i-1]>razm1[i] do
                       i := i - 1;
                 j:=i-1;
                 f:=razm1[j];
                 while razm1[i+1]>f do
                       i := i + 1;
                 razm1[j]:=razm1[i];
                 razm1[i]:=f;
                 i:=j+1;
                 k:=m;
                 while i<k do
                       begin
                            f:=razm1[i];
                            razm1[i]:=razm1[k];
                            razm1[k]:=f;
                            i := i + 1;
                            k := k - 1
                       end;
                 output1; write(' ');  kol := kol + 1;
           until j=0;
           i :=m;
           while razm[i]=n-m+i do
                 i := i-1;
           razm[i] := razm[i] + 1;
           for j := i+1 to m do
               razm[j] := razm[j-1] + 1;
      end;
writeln;
writeln('Kol-vo razmeshenii:', kol);
readkey;
End.

Сообщение отредактировано: 18192123 - 2.11.2007 20:46

У тебя в программе происходит выход за границы массива... Перекомпилируй программу с ключом {$R+} и ты увидишь, где именно происходит ошибка... А это значит, что результатам работы программы (после такого сбоя) доверять просто нельзя...

программа вылетает на процедуре output1.....получается, что-то лишнее добавляется в цикле для получения перестановок... но в чём причина конкретно, я не пойму.....

Смотри:

procedure output1;
var i: integer;
begin
  for i:=1 to m do write(s[razm1[i]]); { <--- проблема - здесь !!! }
end;

Что тут происходит? Массив S индексируется от единицы (поскольку это тип mas1), а очередной элемент razm1[i] содержит 0... Обращение по нулевому индексу к S - это ошибка...

По-моему, тебе надо просто перевести всю программу на нормальную индексацию, с 0 а не с единицы, чтобы не путаться.

да, действительно....и тогда получается размещение с 0 (если компилировать без режима {$R+}). но дело в том, что это и является лишним при исходном множестве, например, 1 2 3, если выводить размещения по 2. индексация с 0 поможет как раз это исправить?

Смотри, я не сторонник выдумывания новых алгоритмов... Есть алгоритм нахождения всех сочетаний из N по M (то, что у нас в FAQ-е называется Combination), и есть алгоритм нахождения всех перестановок (Permutations). Если их объединить, то получится алгоритм нахождения размещений:

const
  max_n = 100;
type
  arrType = array[1 .. max_n] of integer;

var
  s: arrType;   { <-- Это те значения, размещения которых будем выводить }
  mas: arrType; { <-- Это - массив для хранения сочетаний }

  N, M: Longint;
  I, J: Longint;


{
  для каждого из сочетаний вызываем эту процедуру обработки - и
  внутри нее для конкретного сочетания находим все перестановки
}
procedure ProcessCombination(const values: arrType);

  var
    mas: arrType; { <-- Это - массив для перестановок }
    i, j, k: integer;

  procedure WritePermutation;
  var i: Longint;
  begin
    for i := 1 to M do write(s[values[mas[i]]], ' '); { <--- Вот она - основная мысль !!! }
    writeln;
  end;

  procedure swap(i, k: longint);
  var X: byte;
  begin
    X := mas[i]; mas[i] := mas[k]; mas[k] := X;
  end;

begin

  fillchar(mas, sizeof(mas), 0);
  for i := 1 to m do mas[i] := i;

  while true do begin
    WritePermutation;
    i := M;
    while (i > 0) and (mas[i] >= mas[i + 1]) do dec(I);

    if I = 0 then break;

    for J := I + 1 to M do
      if mas[J] > mas[I] then k := J;
    swap(I, k);
    inc(I);
    J := M;

    while I < J do begin
      swap(I, J); inc(I); dec(J);
    end;
  end;

end;



begin

  write('n = '); readln(n);
  write('m = '); readln(m);
  writeln('enter the set of N items:');
  for i := 1 to n do readln(s[i]);

  for i := 1 to m do mas[i] := i;
  while true do begin
    ProcessCombination(mas);
    i := M;
    while (i > 0) and (mas[i] = N - M + i) do dec(i);

    if i = 0 then break;
    inc(mas[i]);
    for j := i + 1 to M do mas[j] := mas[j - 1] + 1;
  end;

end.

(в чем была основная мысль? В двойной индексации... Не просто s[mas[ i ]], а еще один уровень - через сочетания: s[values[mas[ i ]]])