Приложение:
{ генерация перестановок } uses crt; const n = 5; { количество элементов в перестановке} var a:array[1..n] of integer;{массив элементов перестановки} j:integer;{счетчик} kol : longint;{количество перестановок} procedure generate (l,r:integer;var k:longint); {рекурсивная процедура генерации перестановок, входные параметры-границы перестановок, выходной-количество их} var i,v:integer; {счетчик цикла и буфер при обмене} begin if (l=r) then {если дошли до конца} begin for i:=1 to n do write(a[i],' '); {выводим на экран очередную перестановку} writeln; k:=k+1;{считаем} if k mod 20 = 0 then readln;{для удобства просмотра делаем задержки после каждых 20 перестановок} end else {если еще не дошли} begin for i := l to r do {от данного положения начала (L) до конца} begin v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]} {обмениваем текущий первый элемент с очередным} generate(l+1,r,k); {вызов новой генерации}{увеличиваем на 1 начало перестановки} v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[l]} {снова меняем} end; end; end; begin clrscr; for j := 1 to n do {заполняем первоначальный массив} a[j]:=j;{или порядковыми номерами(обычно) или как Вам нравится} generate( 1,n,kol); {генерация} writeln('kol=',kol);{вывод количества} readln end. {нумерация страниц Чтобы не заморачиваться с Вашим навороченным кодом, сделал по своему. Использовал девиз скульпторов, сначала создаю неправильную строку, потом от нее отсекаю все лишнее.} uses crt; const nmax=100; var a:array[1..nmax] of word; s,c:string; n,i,j,k:word; begin clrscr; repeat write('Vvedite kolichestvo stranic n='); readln(n); until (n>1)and(n<=nmax); repeat writeln('Vvedite ',n,' nomerov stranic po vozrastaniyu:'); for i:=1 to n do read(a[i]); readln; k:=0; for i:=2 to n do {проверяем правильность ввода} if a[i]<=a[i-1] then begin k:=1; break; end; if k=1 then writeln('Dopushena oshibka! Povtorite vvod.'); until k=0; str(a[1],c); {преобразуем в строку первое число} s:=c;{начальная строка} i:=2;{начинаем со второго} while i<=n do begin str(a[i],c);{преобразуем} if a[i]-a[i-1]<>1 then s:=s+', '+c;{если не по порядку, запятая +число} if (a[i]-a[i-1]=1)and(a[i+1]-a[i]<>1) then s:=s+'-'+c;{если по порядку, а следующее не по порядку, то дефис+число} if (a[i]-a[i-1]=1)and(a[i+1]-a[i]=1) then {если 3 по порядку, то} begin s:=s+'-';{пишем дефис} inc(i);{переходим к следующему} end else inc(i);{если не 3 попорядку, к следующему} end; for i:=length(s)downto 1 do {удаляем сочетания (,-)} if (s[i]='-')and(s[i+1]=',') then delete(s,i+1,2); while pos('--',s)>0 do {удаляем лишние дефисы} delete(s,pos('--',s),1); write(s); readln end.