Автор-составитель: Смольников И.А.
Тема: Примеры программ, написанных на языке программирования Pascal.
1. Подсчет различных букв в слове
var s:string;
r:real;
i,j,n:integer;
begin
r:=0;
readln(s);
for i:=1 to length(s) do begin
n:=0;
for j:=1 to length(s) do begin
if s[i]=s[j] then inc(n);
end;
r:=r+1/n;
end;
writeln('количество различных букв = ', r:1:0);
end.
2. Перестановка букв в слове (циклический сдвиг вправо)
var s:string;
i,j,n:integer;
begin
readln(s);
s:=s[length(s)] + copy(s,1,length(s)-1);
writeln(s);
end.
3. Определить, является ли слово "перевертышем"
{ Например, "шалаш", "казак" - перевертыш }
program primer1;
var s1,s2:string;
i:integer;
begin
readln(s1); s2:='';
for i:=length(s1) downto 1 do begin
s2:=s2+s1[i];
end;
if s1=s2 then writeln(s1, ' - перевертыш')
else writeln(s1, ' - не перевертыш');
end.
4. Печать всех делителей натурального числа A
var a,n,c,d:word;
begin { основная программа }
readln( a );
n:=1;
while ( n
c:=a mod n;
d:=a div n;
if c = 0 then begin
writeln( n );
if n d then writeln( d );
end;
inc( n );
end;
end.
5. Печать всех совершенных чисел до 10000
const LIMIT = 10000;
var n,i,j,s,lim,c,d : word;
begin { основная программа }
for i:=1 to LIMIT do begin
s:=1; lim:=round(sqrt(i));
for j:=2 to lim do begin
c:=i mod j;
d:=i div j;
if c = 0 then begin
inc(s,j);
if (jd) then inc(s,d); {дважды не складывать корень числа}
end;
end;
if s=i then writeln(i);
end;
end.
6. Печать всех простых чисел до 500
const LIMIT = 500;
var i,j,lim : word;
begin { основная программа }
writeln; {перевод строки, начинаем с новой строки}
for i:=1 to LIMIT do begin
j:=2; lim:=round(sqrt(i));
while (i mod j 0) and (j
if (j lim) then write( i,' ' );
end;
end.
7. Подсчет суммы элементов одномерного массива
var a:array[1..10] of integer;
s:longint;
i:integer;
begin
writeln('введите 10 элементов массива');
s:=0;
for i:=1 to 10 do begin
readln( a[i] );
s:=s+a[i];
end;
writeln( 'Сумма элементов массива = ', s );
end.
8. Подсчет суммы элементов двухмерного массива
var a:array[1..10,1..2] of integer;
s:longint;
i,j:integer;
begin
writeln('введете 20 элементов массива');
s:=0;
for i:=1 to 10 do begin
for j:=1 to 2 do begin
readln( a[i,j] );
s:=s+a[i,j];
end;
end;
writeln( 'Сумма элементов массива = ', s );
end.
9. Поиск минимального элемента в массиве?
var a:array[1..10] of integer;
min:integer;
i:integer;
begin
writeln('введите 10 элементов массива');
min:=MAXINT;
for i:=1 to 10 do begin
readln( a[i] );
if mina[i] then min:=a[i];
end;
writeln( 'Максимальный элемент массива = ', min );
end.
10. Печать всех элементов массива из интервала C...D
var a:array[1..10] of integer;
c,d:integer;
i:integer;
begin
writeln('введите 10 элементов массива');
for i:=1 to 10 do readln( a[i] );
writeln('введите интервал C и D');
readln( c,d );
for i:=1 to 10 do begin
if (a[i]=C) and (a[i]
end;
end.
11. Циклический сдвиг элементов массива вправо
var a:array[1..10] of integer;
x:integer;
i:integer;
begin
writeln('введите 10 элементов массива');
for i:=1 to 10 do readln( a[i] );
x:=a[10];
for i:=10 to 2 do begin
a[i]:=a[i-1];
end;
a[1]:=x;
writeln('после сдвига:');
for i:=1 to 10 do writeln( a[i] );
end.
12. Печать самого часто встречающегося элемента из массива
var a:array[1..10] of integer;
i,j,m,p,n:integer;
begin
writeln('введите 10 элементов массива');
for i:=1 to 10 do readln( a[i] );
m:=1; p:=1;
for i:=1 to 10 do begin
n:=0;
for j:=1 to 10 do begin
if a[i]=a[j] then inc(n);
end;
if nm then begin
m:=n; p:=i;
end;
end;
writeln('самый часто встречающийся элемент:',a[p]);
end.
13. Все ли элементы массива различны?
Вариант с циклом WHILE
var a:array[1..10] of integer;
i,j:integer;
begin
writeln('введите 10 элементов массива');
for i:=1 to 10 do readln( a[i] );
i:=1;
while (i
j:=i+1;
while (ja[j]) do inc(j);
inc(i);
end;
if iв массиве есть одинаковые элементы')
else writeln('все элементы массива различны');
end.
Вариант с циклом FOR
var a:array[1..10] of integer;
i,j:integer;
begin
writeln('введите 10 элементов массива');
for i:=1 to 10 do readln( a[i] );
for i:=1 to 9 do begin
for j:=i+1 to 10 do begin
if a[i]=a[j] then break;
end;
if j
end;
if i
else writeln('все элементы массива различны');
end.
14. Сортировка массива "пузырьком" по возрастанию
const n = 10; { количество элементов в массиве }
var a:array[1..n] of integer;
i,j,x:integer;
begin
writeln('введите ',n,' элементов массива');
for i:=1 to n do readln( a[i] );
for i:=1 to n-1 do begin
for j:=i+1 to n do begin
if a[i]a[j] then begin
x:=a[i]; a[i]:=a[j]; a[j]:=x;
end;
end;
end;
writeln('после сортировки:');
for i:=1 to n do writeln( a[i] );
end.
15. Решение уравнения: A*x^2 + B*x + C = 0
var a,b,c,d,x:real;
begin
writeln('введите A,B,C');
readln( a,b,c );
d:=sqr(b)-4*a*c;
if d
writeln('действительных корней нет');
end else if d=0 then begin
x:=(-b)/2*a;
writeln('корень уравнения: ',x);
end else begin
x:=(-b+sqrt(d))/2*a;
writeln('1-й корень уравнения: ',x);
x:=(-b-sqrt(d))/2*a;
writeln('2-й корень уравнения: ',x);
end;
end.
16. Вычисление длины отрезка
var x1,y1,x2,y2,d:real;
begin
writeln('введите A(X1,Y1) и B(X2,Y2)');
readln( x1,y1,x2,y2 );
d:=sqrt(sqr(y2-y1)+sqr(x2-x1));
writeln('длина отрезка |AB|=',d);
end.
17. Какая точка (A или B) ближе к началу координат
var x1,y1,x2,y2,d1,d2:real;
begin
writeln('введите A(X1,Y1) и B(X2,Y2)');
readln( x1,y1,x2,y2 );
d1:=sqrt(sqr(y1)+sqr(x1));
d2:=sqrt(sqr(y2)+sqr(x2));
if d1Точка A ближе')
else if d1d2 then writeln('Точка B ближе')
else writeln('Одинаково');
end.
18. Вычисление площади треугольника по 3 вершинам
var x1,y1,x2,y2,x3,y3,a,b,c,p,s:real;
begin
writeln('введите A(X1,Y1), B(X2,Y2) и C(X3,Y3)');
readln( x1,y1,x2,y2,x3,y3 );
c:=sqrt(sqr(y1-y2)+sqr(x1-x2));
a:=sqrt(sqr(y2-y3)+sqr(x2-x3));
b:=sqrt(sqr(y1-y3)+sqr(x1-x3));
p:=(a+b+c)/2;
s:=p*sqrt((p-a)*(p-b)*(p-c));
writeln('площадь треугольника = ',s);
end.
19. Попадает ли точка M(x,y) в круг с центром O(Xc,Yc) и радиусом R
var xc,yc,mx,my,d,r:real;
begin
writeln('введите M(X,Y), O(Xc,Yc) и R');
readln( mx,my,xc,yc,r );
d:=sqrt(sqr(xc-mx)+sqr(yc-my));
if d
else writeln ('точка M лежит вне круга');
end.
20. Перевод десятичного числа в двоичное
var a : longint;
function DEC_BIN(x:longint):string;
const digits:array [0..1] of char = ('0','1');
var res:string; d:0..1;
begin
res:='';
while (x0) do begin
d:=x mod 2; res:=digits[d]+res;
x:=x div 2;
end;
DEC_BIN:=res;
end;
begin { основная программа }
readln( a );
writeln( DEC_BIN(a) );
end.
21. Перевод двоичного числа в десятичное
var a : string;
function BIN_DEC(x:string):longint;
const digits:array [0..1] of char = ('0','1');
var res,ves:longint; i,j:byte;
begin
res:=0; ves:=1;
for i:=length(x) downto 1 do begin
j:=0;
while (digits[j]x[i]) do inc(j);
res:=res+ves*j;
ves:=ves*2;
end;
BIN_DEC:=res;
end;
begin { основная программа }
readln( a );
writeln( BIN_DEC(a) );
end.
22. Перевод десятичного числа в шестнадцатеричное
var a : longint;
function DEC_HEX(x:longint):string;
const digits:array [0..15] of char = ('0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F');
var res:string; d:0..15;
begin
res:='';
while (x0) do begin
d:=x mod 16;
x:=x div 16;
res:=digits[d]+res;
end;
DEC_HEX:=res;
end;
begin { основная программа }
readln( a );
writeln( DEC_HEX(a) );
end.
23. Перевод шестнадцатеричного числа в десятичное
var a : string;
function HEX_DEC(x:string):longint;
const digits:array [0..15] of char =
('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
var res,ves:longint; i,j:byte;
begin
res:=0; ves:=1;
for i:=length(x) downto 1 do begin
j:=0; a[i]:=UpCase(a[i]);
while (digits[j]x[i]) do inc(j);
res:=res+ves*j;
ves:=ves*16;
end;
HEX_DEC:=res;
end;
begin { основная программа }
readln( a );
writeln( HEX_DEC(a) );
end.
24. Рекурсивные алгоритмы
Нахождение НОД и НОК двух чисел
var a,b:longint;
function NOD(x,y:longint):longint; { фукнция поиска наиб. общ. делителя }
begin
if x0 then NOD:=NOD(y mod x,x) else NOD:=y;
end;
function NOK(x,y:longint):longint; { фукнция поиска наим. общ. кратного }
begin
NOK:=( x div NOD(x,y) ) * y;
end;
begin { основная программа }
readln(a,b);
writeln( 'НОД этих чисел = ', NOD(a,b) );
writeln( 'НОК этих чисел = ', NOK(a,b) );
end.
Вычисление факториала
var n:integer;
function f(x:integer):longint;
begin
if x = 1 then f := 1 else f := x * f(x-1);
end;
begin
writeln('введите N (N=1..13)');
readln(n);
writeln('N!=',f(n));
end.
Генерация перестановок
const n = 3; { количество элементов в перестановке}
var a:array[1..n] of integer;
index : integer;
procedure generate (l,r:integer);
var i,v:integer;
begin
if (l=r) then begin
for i:=1 to n do write(a[i],' ');
writeln;
end else begin
for i := l to r do begin
v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[j]}
generate(l+1,r); {вызов новой генерации}
v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[j]}
end;
end;
end;
begin
for index := 1 to N do A[index]:=index;
generate( 1,n );
end.
Быстрая сортировка
{ ----------------------------------------------------------------------- }
{ БЫСТРАЯ СОРТИРОВКА. }
{ Устанавливаем I=1 и J=N. Сравниваем элементы A[I] и A[J]. Если }
{ A[I]
{ тов A[I] с A[J]. Последовательное уменьшение индекса J и сравнение ука- }
{ занных элементов A[I] с A[J] продолжаем до тех пор, пока выполняется }
{ условие A[I] Как только A[I] станет больше A[J], меняем места- }
{ ми элементы A[I] с A[J], увеличиваем индекс I на 1 и продолжаем сравне- }
{ ние элементов A[I] с A[J]. Последовательное увеличение индекса I и }
{ сравнение (элементов A[I] с A[J]) продолжаем до тех пор, пока выполня- }
{ ется условие A[I] Как только A[I] станет больше A[J], опять }
{ меняем местами элементы A[I] с A[J], снова начинаем уменьшать J. }
{ Чередуя уменьшение J и увеличение I, сравнение и необходимые обме- }
{ ны, приходим к некоторому элементу, называемому пороговым или главным, }
{ характеризующим условие I=J. В результате элементы массива оказываются }
{ разделенными на две части так, что все элементы слева - меньше главного }
{ элемента, а все элементы справа - больше главного элемента. }
{ К этим массивам применяем рассмотренный алгоритм, получаем четыре }
{ части и т.д. Процесс закончим, когда массив A станет полностью отсорти- }
{ рованным. }
{ При программировании алгоритма "Быстрой сортировки" удобно исполь- }
{ зовать рекурентные вызовы процедуры сортировки (рекурсию). }
{ ----------------------------------------------------------------------- }
var a:array[1..10] of integer; { массив элементов }
n:integer;
procedure QuickSort( L, R : Integer ); { Быстрая сортировка массива A[] }
var i,j,x,y : integer;
begin
i := l; j := r;
x := a[(l+r) div 2];
repeat
while (A[i]
while (x
if ( i
begin
y:=A[i]; a[i]:=a[j]; a[j]:=y;
inc(i); dec(j);
end;
until (ij);
if (l
if (i
end;
begin
writeln('введите 10 элементов массива:');
for n:=1 to 10 do readln(a[n]);
QuickSort( 1, 10 ); { на входе: левая и правая граница сортировки }
writeln('после сортировки:');
for n:=1 to 10 do writeln(a[n]);
end.
25. Решение системы 2-х уравнений с двумя неизвестными
{ ------------------------------------------------------------------------ }
{ решение уравнений вида }
{ |a1*x + b1*y = c1 }
{ |a2*x + b2*y = c2 }
{ }
{ метод решения: }
{ |c1 b1| |a1 c1| }
{ |c2 b2| |a2 c2| }
{ x = --------- y = --------- }
{ |a1 b1| |a1 b1| }
{ |a2 b2| |a2 b2| }
{ }
{ выражаем определители второго порядка: }
{ x = (c1*b2-c2*b1)/(a1*b2-a2*b1) }
{ y = (a1*c2-a2*c1)/(a1*b2-a2*b1) }
{ ------------------------------------------------------------------------ }
var a1,a2,b1,b2,c1,c2,x,y,d,dx,dy:real;
begin
writeln('введите коэффициенты уравнения: a1,b1,c1,a2,b2,c2');
readln(a1,b1,c1,a2,b2,c2);
d := (a1*b2-a2*b1);
dx := (c1*b2-c2*b1);
dy := (a1*c2-a2*c1);
if ( d=0 ) and ( (dx=0) or (dy=0) ) then
writeln('бесконечное множество решений')
else if ( d0 ) and ( (dx=0) or (dy=0) ) then
writeln('нет решений')
else begin
x:=dx/d; y:=dy/d;
writeln('x = ', x); writeln('y = ', y);
end;
end.
26. Решение системы 3-х уравнений с тремя неизвестными
{ ------------------------------------------------------------------------ }
{ решение уравнений вида: }
{ |a1*x + b1*y + c1*z = d1| }
{ |a2*x + b2*y + c2*z = d2| }
{ |a3*x + b3*y + c3*z = d3| }
{ }
{ метод решения: }
{ |d1 b1 c1| |a1 d1 c1| |a1 b1 d1| }
{ |d2 b2 c2| |a2 d2 c2| |a2 b2 d2| }
{ |d3 b3 c3| |a3 d3 c3| |a3 b3 d3| }
{ x = ---------- y = ---------- z = ---------- }
{ |a1 b1 c1| |a1 b1 c1| |a1 b1 c1| }
{ |a2 b2 c2| |a2 b2 c2| |a2 b2 c2| }
{ |a3 b3 c3| |a3 b3 c3| |a3 b3 c3| }
{ }
{ выражаем определители третьего порядка: }
{ e := (a1*b2*c3+b1*c2*a3+c1*a2*b3-a3*b2*c1-b3*c2*a1-c3*a2*b1); }
{ ex := (d1*b2*c3+b1*c2*d3+c1*d2*b3-d3*b2*c1-b3*c2*d1-c3*d2*b1); }
{ ey := (a1*d2*c3+d1*c2*a3+c1*a2*d3-a3*d2*c1-d3*c2*a1-c3*a2*d1); }
{ ez := (a1*b2*d3+b1*d2*a3+d1*a2*b3-a3*b2*d1-b3*d2*a1-d3*a2*b1); }
{ x = ex/e }
{ y = ey/e }
{ z = ez/e }
{ ------------------------------------------------------------------------ }
var a1,a2,a3,b1,b2,b3,c1,c2,c3,d1,d2,d3,x,y,z,e,ex,ey,ez:real;
begin
writeln('введите коэффициенты уравнения:a1,b1,c1,d1,a2,b2,c2,d2,a3,b3,c3,d3');
readln(a1,b1,c1,d1,a2,b2,c2,d2,a3,b3,c3,d3);
e := (a1*b2*c3+b1*c2*a3+c1*a2*b3-a3*b2*c1-b3*c2*a1-c3*a2*b1);
ex := (d1*b2*c3+b1*c2*d3+c1*d2*b3-d3*b2*c1-b3*c2*d1-c3*d2*b1);
ey := (a1*d2*c3+d1*c2*a3+c1*a2*d3-a3*d2*c1-d3*c2*a1-c3*a2*d1);
ez := (a1*b2*d3+b1*d2*a3+d1*a2*b3-a3*b2*d1-b3*d2*a1-d3*a2*b1);
if ( e=0 ) and ( (ex=0) or (ey=0) or (ez=0) ) then
writeln('бесконечное множество решений')
else if ( e0 ) and ( (ex=0) or (ey=0) or (ez=0) ) then
writeln('нет решений')
else begin
x:=ex/e; y:=ey/e; z:=ez/e;
writeln('x = ', x); writeln('y = ', y); writeln('z = ', z);
end;
end.
27. Геометрические алгоритмы
Пересекаются ли 2 отрезка?
{ ------------------------------------------------------------------------ }
{ Определяет пересечение отрезков A(ax1,ay1,ax2,ay2) и B (bx1,by1,bx2,by2),}
{ функция возвращает TRUE - если отрезки пересекаются, а если пересекаются }
{ в концах или вовсе не пересекаются, возвращается FALSE (ложь) }
{ ------------------------------------------------------------------------ }
function Intersection(ax1,ay1,ax2,ay2,bx1,by1,bx2,by2:real):boolean;
var v1,v2,v3,v4:real;
begin
v1:=(bx2-bx1)*(ay1-by1)-(by2-by1)*(ax1-bx1);
v2:=(bx2-bx1)*(ay2-by1)-(by2-by1)*(ax2-bx1);
v3:=(ax2-ax1)*(by1-ay1)-(ay2-ay1)*(bx1-ax1);
v4:=(ax2-ax1)*(by2-ay1)-(ay2-ay1)*(bx2-ax1);
Intersection:=(v1*v2
end;
begin { основная программа, вызов функции - тест }
writeln(Intersection(1,1,5,5,1,2,3,1)); {test1, yes Intersection}
writeln(Intersection(1,1,5,5,1,2,1,3)); {test2, no Intersection}
end.
Точка внутри сектора или нет?
{ ------------------------------------------------------------------------ }
{ Если точка внутри сектора (или на сторонах) - TRUE, если нет - FALSE }
{ tx,ty - вершина сектора }
{ x1,y1,x2,y2 - точки на сторонах сектора }
{ px,py - точка на плоскости }
{ }
{ ------------------------------------------------------------------------ }
{возвращает знак числа, 1 - положительное число, -1 - отрицательное, 0 - 0 }
function sign(r:real):integer;
begin
sign:=0; if r=0 then exit;
if r
end;
function InsideSector(tx,ty,x1,y1,x2,y2,px,py:real):boolean;
var x,y,a1,a2,b1,b2,c1,c2:real;
var i1,i2,i3,i4:integer;
begin
x:=(tx+x1+x2)/3; y:=(ty+y1+y2)/3;
a1:=ty-y1; b1:=x1-tx; c1:=tx*y1-ty*x1;
a2:=ty-y2; b2:=x2-tx; c2:=tx*y2-ty*x2;
i1:=sign(a1*x+b1*y+c1); i2:=sign(a2*x+b2*y+b2);
i3:=sign(a1*px+b1*py+c1); i4:=sign(a2*px+b2*py+c2);
InsideSector:=((i1=i3) and (i2=i4)) or
((i1=0) and (i2=i4)) or
((i1=i3) and (i2=0));
end;
begin { основная программа, вызов функции - тест }
writeln(InsideSector(1,1,5,1,1,5,3,3)); {test1, yes Inside}
writeln(InsideSector(1,1,5,1,7,2,3,3)); {test2, no Intersection}
end.
С какой стороны вектора лежит точка?
{ ------------------------------------------------------------------------ }
{ Если vector(a) и vector(b) - вектора a и b соответственно, то: }
{ }
{ vector(a)*vector(b) = ax*by - ay*bx = a*b*sin(beta-alfa) }
{ ax,ay,bx,by - координаты концов векторов }
{ a - длина вектора a }
{ b - длина вектора b }
{ alfa - угол альфа для вектора a }
{ beta - угол бета для вектора b }
{ }
{ Вывод: при общей начальной точке двух векторов их векторное произведение }
{ больше нуля, если второй вектор направлен влево от первого, }
{ и меньше нуля, если вправо. }
{ }
{ Если известны две точки, то вектор, основанный на них можно получить }
{ вычитанием двух векторов направленных из начала координат: }
{ Например, есть точка A и точка B }
{ вектор|AB| = Вектор|B| - Вектор|A|, иным словом AB_x = Bx-Ax, AB_y= By-Ay}
{ }
{ Таким образом, получается: }
{ Если есть вектор |AB|, заданный координатами ax,ay,bx,by и точка px,py, }
{ то для того чтобы узнать лежит ли она слева или справа, надо узнать знак }
{ произведения: }
{ (bx-ax)*(py-ay)-(by-ay)*(px-ax) }
{ ------------------------------------------------------------------------ }
var i:integer;
(* функция определеяет положение точки относительно вектора *)
Function WherePoint(ax,ay,bx,by,px,py:real):integer;
var s :real;
begin
s:=(bx-ax)*(py-ay)-(by-ay)*(px-ax);
if s0 then WherePoint:=1
else if s
else WherePoint:=0;
end;
Begin (* Тело основной программы *)
i:=WherePoint(1,1,8,8,2,5);
if i 0 then writeln('точка слева от вектора')
else if i
else writeln('на векторе, прямо по вектору или сзади вектора');
End.
С какой стороны вектора лежит точка? Вариант 1
{ ------------------------------------------------------------------------ }
{ Идея: обходим треугольник по часовой стрелке. }
{ Точка должна лежать справа от всех сторон, если она внутри }
{ ------------------------------------------------------------------------ }
(* функция определеяет положение точки относительно вектора *)
Function WherePoint(ax,ay,bx,by,px,py:real):integer;
var s :real;
begin
s:=(bx-ax)*(py-ay)-(by-ay)*(px-ax);
if s0 then WherePoint:=1
else if s
else WherePoint:=0;
end;
(* функция определеяет относительное положение точки: внутри или нет *)
Function PointInsideTreangle(ax,ay,bx,by,cx,cy,px,py:real):boolean;
var s1,s2,s3 :integer;
begin
PointInsideTreangle:=FALSE;
s1:=WherePoint(ax,ay,bx,by,px,py);
s2:=WherePoint(bx,by,cx,cy,px,py);
if s2*s1
s3:=WherePoint(cx,cy,ax,ay,px,py);
if s3*s2
PointInsideTreangle:=TRUE;
end;
Begin (* Тело основной программы *)
writeln(PointInsideTreangle(1,1,8,1,1,8,2,2)); {TEST1, Inside}
writeln(PointInsideTreangle(1,1,8,1,1,8,6,6)); {TEST2, Outside}
End.
Точка внутри треугольника? Вариант 2
{ ------------------------------------------------------------------------ }
{ Идея: Пусть есть треугольник ABC и точка P. Если Площадь ABC равна сумме }
{ площадей треугольников ABP,BCP,CAP, то точка внутри треугольника. }
{ ------------------------------------------------------------------------ }
(* функция вычисляет расстояние между точками *)
Function Distance(ax,ay,bx,by:real):real;
begin
Distance := sqrt(sqr(ax-bx)+sqr(ay-by));
end;
(* функция вычисляет площадь треугольника по формуле Герона *)
Function SqrGeron(ax,ay,bx,by,cx,cy:real):real;
var p,a,b,c :real;
Begin
a:=Distance(cx,cy,bx,by);
b:=Distance(ax,ay,cx,cy);
c:=Distance(ax,ay,bx,by);
p:=(a+b+c)/2;
SqrGeron:=sqrt(p*(p-a)*(p-b)*(p-c));
End;
(* функция определеяет относительное положение точки: внутри или нет *)
Function PointInsideTreangle(ax,ay,bx,by,cx,cy,px,py:real):boolean;
const error = 1.000001;
var s,s1,s2,s3 :real;
begin
PointInsideTreangle:=TRUE;
s :=SqrGeron(ax,ay,bx,by,cx,cy);
s1:=SqrGeron(ax,ay,bx,by,px,py);
s2:=SqrGeron(bx,by,cx,cy,px,py);
s3:=SqrGeron(cx,cy,ax,ay,px,py);
if s*errors1+s2+s3 then PointInsideTreangle:=TRUE
else PointInsideTreangle:=FALSE;
end;
Begin (* Тело основной программы *)
writeln(PointInsideTreangle(1,1,8,1,1,8,2,2)); {TEST1, Inside}
writeln(PointInsideTreangle(1,1,8,1,1,8,6,6)); {TEST2, Outside}
End.
28. Арифметические алгоритмы
Моделирование сложения двоичных чисел
{ ------------------------------------------------------------------------ }
var sr,sf,ss:string;
function BinAdd(s1,s2:string):string;
var s:string; l,i,d,carry:byte;
begin
{выравнивание строк по длине}
if length(s1)length(s2) then while length(s2)
else while length(s1)
l:=length(s1);
s:=''; carry:=0;
for i:=l downto 1 do begin
d := (ord(s1[i])-ord('0')) + (ord(s2[i])-ord('0')) + carry;
carry := d div 2;
d:=d mod 2;
s:=char(d+ord('0')) + s;
end;
if carry0 then s:='1'+s;
BinAdd:=s;
end;
begin
writeln('введите 1-е двоичное число:');
readln(sf);
writeln('введите 2-е двоичное число:');
readln(ss);
sr:=BinAdd(sf,ss);
writeln('результат сложения = ',sr);
end.
Моделирование вычитания двоичных чисел
{ ------------------------------------------------------------------------ }
var sr,sf,ss:string;
{ вычитание двоичных строк, первое число должно быть = второго }
function BinSub(s1,s2:string):string;
var s:string; l,i,j:byte;
begin
{выравнивание строк по длине}
if length(s1)length(s2) then while length(s2)
else while length(s1)
l:=length(s1); {начало алгоритма вычитания}
s:='';
for i:=l downto 1 do begin
case s1[i] of
'1': if s2[i]='0' then s:='1'+s else s:='0'+s;
'0': if s2[i]='0' then s:='0'+s else begin
s:='1'+s;
if (s1[i-1]='1') then s1[i-1]:='0' else begin
j:=1;
while (i-j0) and (s1[i-j]='0') do begin
s1[i-j]:='1';
inc(j);
end;
s1[i-j]:='0';
end;
end;
end;
end;
{Уничтожение передних нолей}
while (length(s)1) and (s[1]='0') do delete(s,1,1);
BinSub:=s;
end;
begin
writeln('введите 1-е двоичное число:');
readln(sf);
writeln('введите 2-е двоичное число:');
readln(ss);
sr:=BinSub(sf,ss);
writeln('результат вычитания = ',sr);
end.
Возведение целого числа в натуральную степень
Вариант 1 (обычный)
var x,y:integer;
function Degree(a,b:integer):longint;
var r:longint;
begin
r:=1;
while b0 do begin
r:=r*a;
b:=b-1;
end;
Degree:=r;
end;
begin
writeln('введите число и (через пробел) степень числа');
readln(x,y);
writeln(Degree(x,y)); { print x^y }
end.
Вариант 2 (более быстрый и эффективный)
var x,y:integer;
function Degree(a,b:integer):longint;
var r:longint; c:integer;
begin
r:=1; c:=a;
while b0 do begin
if odd(b) then begin
r:=r*c;
dec(b);
end else begin
c:=c*c;
b:=b div 2;
end;
end;
Degree:=r;
end;
begin
writeln('введите число и (через пробел) степень числа');
readln(x,y);
writeln(Degree(x,y)); { print x^y }
end.
Умножение длинных натуральных десятичных чисел
{ Введенное число помещается поразрядно в массив ROW. }
{ Могут умножаться числа до 10000 разрядов }
{ ------------------------------------------------------------------------ }
{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
uses crt;
var {-------- use calc factorial ---------}
row : array[1..20000] of byte;
col : array[1..10000] of byte;
nr,nc,dp : integer;
c : char;
procedure PrintResult;
begin
write('Р е з у л ь т а т = ');
while (dp
write(char(row[dp]+ord('0')));
inc(dp);
end;
writeln;
end;
29. Умножение по Аль-Хорезми, в ROW - 1 число,в COL - 2 число
{Результат пишется в конец массива ROW }
procedure Multiplying;
var i,j,cr,cc:integer;
carry,sum:longint;
begin
dp:=high(row); cr:=nr; cc:=nc;
carry := 0;
while (cc0) do begin
i:=cr; j:=cc; sum:=carry;
while (i=1) do begin
sum:=sum+row[i]*col[j];
inc(i); dec(j);
end;
row[dp]:=sum mod 10; dec(dp);
carry:=sum div 10;
if cr1 then dec(cr) else dec(cc);
end;
while (carry0) do begin
row[dp]:=carry mod 10;
carry:=carry div 10;
dec(dp);
end;
inc(dp);
end;
begin
{обнуление массивов-множителей}
fillchar(row,sizeof(row),0); fillchar(col,sizeof(col),0);
{поразрядный ввод 1-го числа}
writeln('введите 1-е число число:');
c:=#0;
while NOT(c in ['0'..'9']) do c:=readkey;
nr:=0;
while (c in ['0'..'9']) do begin
write(c);
inc(nr); row[nr]:=ord(c)-ord('0');
c:=readkey;
end;
writeln;
{поразрядный ввод 2-го числа}
writeln('введите 2-е число число:');
while NOT(c in ['0'..'9']) do c:=readkey;
nc:=0;
while (c in ['0'..'9']) do begin
write(c);
inc(nc); col[nc]:=ord(c)-ord('0');
c:=readkey;
end;
writeln;
{вызов процедуры умножения, затем - вызов процедуры вывода результата}
Multiplying; PrintResult;
end.
30. Кодировка. Пример простой кодировки (сдвиг по ключу)
{--------------------------------------------------------------------------}
{ Алгоритм: каждый код символа увеличивается на некоторое число - "ключ" }
{--------------------------------------------------------------------------}
var s:string;
i,key:integer;
begin
writeln('Введите текст'); readln(s);
writeln('Введите ключ (число от 1 до 255)'); readln(key);
for i:=1 to length(s) do s[i]:=char( ord(s[i]) + key );
writeln('Зашифрованный текст: ',s);
end.
31. Обработка текста
Подсчет количества слов в тексте
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - количество слов в тексте }
{--------------------------------------------------------------------------}
const Alpha : set of char=['A'..'Z','А'..'П','Р'..'Я','a'..'z','а'..'п','р'..'я'];
var s:string;
i:integer;
wc:integer;
begin
writeln('Введите текст'); readln(s);
i:=1; wc:=0;
Repeat
while NOT(s[i] in Alpha) and (i
if (i
while (s[i] in Alpha) and (i
Until (ilength(s));
writeln('Количество слов в этом тексте = ',wc);
end.
Выделение слов из текста
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - список слов }
{--------------------------------------------------------------------------}
const Alpha : set of char=['A'..'Z','А'..'П','Р'..'Я','a'..'z','а'..'п','р'..'я'];
var s,t:string;
i:integer;
begin
writeln('Введите текст'); readln(s);
writeln('Список слов в тексте:');
i:=1;
Repeat
while NOT(s[i] in Alpha) and (i
t:='';
while (s[i] in Alpha) and (i
t:=t+s[i];
inc(i);
end;
if length(t)0 then writeln(t);
Until (ilength(s));
end.
Выделение чисел из текста
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - список чисел }
{--------------------------------------------------------------------------}
const Digits : set of char=['0'..'9'];
var s,d:string;
i:integer;
begin
writeln('Введите текст, в котором есть и цифры:'); readln(s);
writeln('Список чисел в тексте:');
i:=1;
Repeat
while NOT(s[i] in Digits) and (i
d:='';
while (s[i] in Digits) and (i
d:=d+s[i];
inc(i);
end;
if length(d)0 then writeln(d);
Until (ilength(s));
end.
Разрешение ввода только цифр
{--------------------------------------------------------------------------}
{ На входе - текст с цифрами (но будут вводиться только цифры }
{--------------------------------------------------------------------------}
uses crt;
const ENTER=#13;
var c:char;
begin
writeln('Вводите буквы и цифры');
c:=readkey;
while (cENTER) do begin
if c in ['0'..'9'] then write(c);
c:=readkey;
end;
writeln;
end.
Перевод в маленькие буквы (нижний регистр)
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - текст из маленьких букв }
{--------------------------------------------------------------------------}
var s:string;
function SmallAlpha(ps:string):string;
var i:integer;
begin
for i:=1 to length(ps) do begin
case ps[i] of
'A'..'Z','А'..'П': inc(ps[i],32);
'Р'..'Я' : inc(ps[i],80);
end;
end;
SmallAlpha:=ps;
end;
begin
writeln('Введите любой текст'); readln(s);
writeln('Этот же текст маленькими буквами:');
writeln(SmallAlpha(s));
end.
Перевод в заглавные буквы (верхний регистр)
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - текст из больших букв }
{--------------------------------------------------------------------------}
var s:string;
function BigAlpha(ps:string):string;
var i:integer;
begin
for i:=1 to length(ps) do begin
case ps[i] of
'a'..'z','а'..'п': dec(ps[i],32);
'р'..'я' : dec(ps[i],80);
end;
end;
BigAlpha:=ps;
end;
begin
writeln('Введите любой текст'); readln(s);
writeln('Этот же текст большими буквами:');
writeln(BigAlpha(s));
end.
Удаление из текста комметариев типа {...}
{--------------------------------------------------------------------------}
{ На входе - текст с комметариями, на выходе - текст без комментарив }
{--------------------------------------------------------------------------}
var s,r:string;
state,i:integer;
begin
writeln('Введите любой текст с комментариями'); readln(s);
r:=''; state:=0; {нормальное состояние}
for i:=1 to length(s) do begin
case s[i] of
'{': if state=0 then state:=1; {теперь мы внутри комментария}
'}': if state=1 then state:=0 {теперь мы вышли из комментария}
else r:=r+s[i]; {мы не в комментарии}
else if state=0 then r:=r+s[i]; {мы не в комментарии}
end;
end;
writeln('новый текст:'); writeln(r);
end.
32. Бэк-трекинг: Города
{--------------------------------------------------------------------------}
{ Задача "Города". (А.Н.Никитин) }
{ Широко известна игра "Города". Называется какой-нибудь город, допус- }
{ тим, "Саратов". Кончается на "в", значит требуется назвать другой город, }
{ у которого в названии первая буква "в". Это может быть "Воронеж". Следу- }
{ ющий город должен начинаться на "ж" и т.д. Запрещено повторять название }
{ городов. Надо написать программу, которая из набора названий городов }
{ (все названия разные) строит цепочку максимальной длины. }
{ }
{ Входные данные: файл TOWN.IN в 1-й строке содержит количество слов в }
{ наборе. Начиная со второй строки (по одному в строке) следуют названия }
{ городов (все буквы в названиях - заглавные). }
{ }
{ Выходные данные: 1-я строка TOWN.OUT содержит длину максимальной це- }
{ почки. Начиная со второй строки идет вариант цепочки, т.е. названия (по }
{ одному в строке) городов в порядке, который требуют условия игры. }
{ }
{ Примечание: Список городов во входном файле не превышает 20. }
{ Время тестирования - 2 секунды. (Pentium) }
{ }
{ ПРИМЕР: }
{ ┌──────── TOWN.IN ──────────────┬─────────── TOWN.OUT ───────────────┐ }
{ │5 │5 │ }
{ │НОВОСИБИРСК │САМАРА │ }
{ │АСТРАХАН │АСТРАХАН │ }
{ │САМАРА │НОВОСИБИРСК │ }
{ │ВЛАДИМИР │КИРОВ │ }
{ │КИРОВ │ВЛАДИМИР │ }
{ └───────────────────────────────┴────────────────────────────────────┘ }
{--------------------------------------------------------------------------}
{$M $8000,0,$1FFFF}
program towns; { "Города". Решение А.Никитина, Самара }
const mnt = 20; { максимальное количество слов на входе }
var list,chain,store :array [1..mnt] of string; { для списка и цепочек }
numin :integer; { реальное количество слов на входе }
pc :integer; { Указатель на хвост цепочки }
ml :integer; { Длина наибольшей цепочки }
sym :char; { Первичная буква для перебора }
procedure read_data; { Начальные установки и чтение данных }
var i : integer;
begin
pc:=0; ml:=0; numin:=0;
assign(input,'TOWN.IN'); reset(input);
fillchar(chain,sizeof(chain),0);
readln(numin);
if (numinmnt) then numin:=mnt;
for i:=1 to numin do readln(list[i]);
close(input);
end;
procedure write_results; { Запись результатов в файл }
var i : integer;
begin
assign(output,'TOWN.OUT'); rewrite(output);
writeln(ml);
if (ml0) then begin
for i:=1 to ml do writeln(store[i]);
end;
close(output);
end;
procedure store_chain; { Запоминаем только более длинную цепочку }
var i:integer;
begin
if (pcml) then begin
store:=chain;
ml:=pc;
end;
end;
{ Возвращает указатель названия по 1-й букве, 0 - такого элемента нет }
function find_next_item( c:char; n:integer ):integer;
var i:integer;
begin
i:=1; find_next_item:=0;
while (i0) do begin
if (list[i][1]=c) then dec(n);
inc(i);
end;
if (n=0) then find_next_item:=pred(i);
end;
{ Алгоритм построения цепочек. }
procedure build_chain( c:char; n:integer ); { Метод: перебор с возвратом. }
var i:integer; { Известен как "back-tracking" }
begin
i:=find_next_item(c,n);
if (i0) then begin
inc(pc); chain[pc]:=list[i]; list[i][1]:='X'; { вычеркиваем }
build_chain(list[i][length(list[i])], 1);
dec(pc); list[i][1]:=c; { возвращаем }
build_chain(c, n+1);
end else store_chain;
end;
begin
read_data;
for sym:='А' to 'Я' do build_chain(sym,1);
write_results;
end.
33. Бэк-трекинг
Обход шахматной доски конем
Маршрут см. в файле OUTPUT.TXT
{--------------------------------------------------------------------------}
{$G+}
const wb=8; nb=wb*wb;
s:array[1..8,1..2] of integer =
((-2,1),(-1,2),(1,2),(2,1),(2,-1),(1,-2),(-1,-2),(-2,-1));
var b: array[1..wb,1..wb] of boolean;
m: array[1..nb,1..2] of integer;
p: integer;
procedure PrintAndExit;
var i:integer;
begin
assign(output,'output.txt'); rewrite(output);
for i:=1 to nb-1 do write(m[i,1],':',m[i,2],',');
writeln(m[nb,1],':',m[nb,2]); halt;
end;
procedure Solution(r,c:integer);
var d,i,j:integer;
begin
if (ppred(nb)) then PrintAndExit;
for d:=1 to 8 do begin
i:=r+s[d,1]; j:=c+s[d,2];
if NOT(i in[1..wb]) or NOT(j in[1..wb]) or (b[i,j]) then continue;
inc( p );
m[p,1]:=i; m[p,2]:=j; b[i,j]:=true;
Solution( i,j );
dec( p );
b[i,j]:=false;
end;
end;
var i,j:integer;
begin
fillchar(b,sizeof(b),false);
for i:=1 to wb div 2 do
for j:=1 to wb div 2 do begin
p:=1; m[p,1]:=i; m[p,2]:=j; b[i,j]:=true;
Solution(i,j);
b[i,j]:=false;
end;
end.
Проход по лабиринту
{ Есть матрица n:m, состоящая из 0 и 1. 1 - это стенка, 0 - проход. }
{ Надо найти оптимальный проход из точки is,js (нчаало) в точку ie, je }
{ (конец). }
{ }
{ Входной файл LAB.IN содержит: }
{ 1-я строка - размер поля }
{ 2-я строка - координаты начальной позиции (row,col) }
{ 3-я строка - координаты конечной позиции (row,col) }
{ 4-я строка и далее - схему лабиринта из 0 и 1 }
{ Например: }
{ 10 10 }
{ 2 10 }
{ 1 6 }
{ 1 1 1 1 1 0 1 1 1 1 }
{ 1 0 0 0 0 0 1 0 1 0 }
{ 1 0 1 1 1 1 1 0 1 0 }
{ 1 0 1 0 1 0 0 0 1 0 }
{ 1 0 1 0 1 0 0 0 1 0 }
{ 0 0 1 0 1 0 0 0 1 0 }
{ 0 0 1 0 1 1 1 1 1 0 }
{ 1 0 0 1 0 1 0 0 0 0 }
{ 1 1 0 0 0 0 0 1 0 0 }
{ 1 1 1 1 1 1 1 1 1 1 }
{ }
{ Выходной файл LAB.OUT содержит маршрут прохода (i1:j1 ... in:jn): }
{ 1:10 }
{ 2:10 }
{ 3:10 }
{ .... }
{--------------------------------------------------------------------------}
const LN = 50; LM = 50;
var a:array[1..LN,1..LM] of byte;
p:array[1..LN*LM,1..2] of byte;
s:array[1..LN*LM,1..2] of byte;
n,m,si,sj,ei,ej,index,min:integer;
procedure INIT;
var i,j:integer;
begin
assign(input,'lab.in'); reset(input);
assign(output,'lab.out'); rewrite(output);
readln(n,m);
readln(si,sj);
readln(ei,ej);
for i:=1 to n do begin
for j:=1 to n-1 do begin
read(a[i,j]);
end;
readln(a[i,n]);
end;
index:=0; min:=ln*lm;
end;
procedure Store;
begin
if (min index) then begin
move( p, s, sizeof(p) );
min:=index;
end;
end;
procedure DONE;
var i:integer;
begin
for i:=1 to min do writeln(s[i,1],':',s[i,2]);
end;
procedure FindPath(i,j:integer);
begin
a[i,j]:=2;
inc(index);
p[index,1]:=i; p[index,2]:=j;
if (i=ei) and (j=ej) then begin
Store;
end else begin
if (i1) and (a[i-1,j]=0) then FindPath(i-1,j);
if (i
if (j1) and (a[i,j-1]=0) then FindPath(i,j-1);
if (j
end;
dec(index);
a[i,j]:=0;
end;
begin
INIT;
FindPath(si,sj);
DONE;
end.
Домино
{--------------------------------------------------------------------------}
{ Берутся случайных N костяшек из одного набора домино (1
{ Задача состоит в том, чтобы образовать из этих N костяшек самую длинную }
{ цепочку, состыковывая их по правилам домино частями с равным количеством }
{ точек. }
{ }
{ Входные данные: Входной файл с именем "D.IN" содержит информацию о }
{ наборе костяшек. 1-я строка - количество костяшек. }
{ 2-я и последующие строки - парные наборы точек (числа разделены }
{ пробелом). В каждой строке записана пара точек, указанной на одной }
{ костяшке. Количество пар соответствует числу из первой строки. }
{ Выходные данные: результаты работы программы записываются в файл "D.OUT".}
{ 1-я строка содержит длину максимальной цепочки костяшек. 2-я строка }
{ содержит пример такой цепочки, при этом пары (цифры) на костяшках }
{ записываются без пробелов, подряд, а между костяшками в цепочке ставится }
{ двоеточие. }
{ Пример входного файла: Пример выходного файла: }
{ 5 5 }
{ 1 2 56:62:21:13:36 }
{ 1 3 }
{ 2 6 }
{ 3 6 }
{ 5 6 }
{--------------------------------------------------------------------------}
{ Задача "Домино", решение: А.Никитина, Самара }
{$M $C000,0,650000}
const max = 28;
maxtime = 60;
tl :longint = (maxtime*18); { чуть меньше 60 сек }
yes :boolean = false; {флаг выхода, если уже есть цепочка из n}
var m :array [0..6,0..6] of boolean;
n :byte; {кол-во костяшек на входе, 1..28}
cep,best :array [1..max*2] of byte; { цепочка/память }
p,maxlen :integer; { указатель на хвост цепочки/длина макс.цеп. }
jiffy :longint absolute $0040:$006C; { секундомер, точнее тикомер }
procedure ReadData; { начальные установки и считывание данных }
var i,a,b : byte;
begin
tl:=jiffy + tl;
p:=1; maxlen:=0;
assign(input,'d.in'); reset(input);
fillchar(cep,sizeof(cep),0);
fillchar(m,sizeof(m),false);
readln(n);
for i:=1 to n do begin
readln(a,b);
m[a,b]:=true; m[b,a]:=true;
end;
close(input);
end;
procedure WriteResults; { запись результата }
var i : integer;
begin
assign(output,'d.out'); rewrite(output);
writeln(maxlen div 2);
if (maxlen1) then begin
i:=1;
while (i
write(best[i],best[i+1],':');
inc(i,2);
end;
write(best[pred(maxlen)],best[maxlen]);
end;
close(output);
end;
{ более длинная цепочка запоминается в массиве best }
procedure s_cep;
begin
if (p-1maxlen) then begin
move(cep,best,p-1);
maxlen:=p-1;
yes:=(maxlen div 2=n);
end;
end;
{ сущеуствует ли еще подходящие костяшки? }
function exist(k:integer):boolean;
var i : integer;
begin
i:=0; while (i
exist:=(i
end;
{ построение цепочек }
procedure make_cep(f:integer);
var s:integer;
begin
if (yes) or (tl-jiffyпора остановиться?}
if (m[f,f]) then begin {исключение позволяет улучшить перебор}
m[f,f]:=false; { убираем костяшку }
cep[p]:=f; cep[succ(p)]:=f; inc(p,2); {идея исключения - Савин}
if exist(f) then make_cep(f) else s_cep;
dec(p,2);
m[f,f]:=true; { возвращаем костяшку }
end else
for s:=0 to 6 do {стандартный бэк-трекинг}
if (m[f,s]) then begin
m[f,s]:=false; m[s,f]:=false; { убираем костяшку }
cep[p]:=f; cep[succ(p)]:=s; inc(p,2);
if exist(s) then make_cep(s) else s_cep;
dec(p,2);
m[f,s]:=true; m[s,f]:=true; { возвращаем костяшку }
end;
end;
var i:integer;
begin
ReadData;
for i:=0 to 6 do make_cep(i);
WriteResults;
end.
Последовательность
{--------------------------------------------------------------------------}
{ Дана последовательность натуральных чисел (значение каждого числа }
{ от 1 до 1000). После-довательность может быть не отсортирована. }
{ Надо найти вариант самой большой (по количеству элементов) неубывающей }
{ последовательности, составленной из чисел этого ряда. Порядок включения }
{ чисел в неубывающую последовательность должен соответствовать порядку }
{ следования чисел в первоначальной последова-тельности. Иными словами, }
{ числа с большими номерам и в новой последовательности размещаются правее }
{ чисел с меньшими номерами. }
{ }
{ Входные данные: файл SEQ.IN в 1-й строке содержит количество чисел в }
{ последовательности - N (1
{ Со 2-й строки и далее указан ряд чисел, каждое число размещается на }
{ новой строке. Поиск ошибок в файле не требуется, входные данные }
{ корректны. }
{ }
{ Выходные данные: }
{ В файле SEQ.OUT помещаются выходные данные. }
{ 1-я строка содержит длину максимальной неубыващей последовательности. }
{ 2-я строка и далее - пример такой последовательности, каждое число в }
{ порядке следования размещается на новой строке. }
{ }
{ Пример возможного теста: }
{ }
{ Файл "SEQ.IN" Файл "SEQ.OUT" }
{ 12 7 }
{ 59 4 }
{ 4 21 }
{ 21 27 }
{ 36 34 }
{ 18 45 }
{ 27 47 }
{ 79 93 }
{ 34 }
{ 45 }
{ 47 }
{ 34 }
{ 93 }
{--------------------------------------------------------------------------}
{$M $8000,0,$4ffff} (* последовательность, Никитин *)
Const MaxItem = 100;
TimeLimit = 29*18; {29 sec}
var Numbers, Seq, Best: array[1..MaxItem] of integer;
pc,maxpc,num:integer;
timer:longint absolute $0040:$006C;
jiffy:longint;
Procedure Init;
var i:integer;
begin
jiffy:=timer;
fillchar(Numbers, Sizeof(Numbers),#0);
Seq:=Numbers; Best:=Numbers; pc:=0; maxpc:=0;
assign(input,'seq.in'); reset(input);
readln(num); if numMaxItem then num:=MaxItem;
for i:=1 to num do readln(Numbers[i]);
close(input);
end;
Procedure Done;
var i:integer;
begin
assign(output,'seq.out'); rewrite(output);
writeln(maxpc);
for i:=1 to maxpc do writeln(Best[i]);
close(output);
end;
procedure StoreChain;
begin
if (pcmaxpc) then begin
Best:=Seq;
maxpc:=pc;
if (maxpc=num) then begin
Done;
Halt(0);
end;
end;
end;
function testFWD(i:integer):integer;
var m:integer;
begin
m:=Numbers[i]; inc(i);
while (iNumbers[i]) do inc(i);
if inum then testFWD:=0 else testFWD:=i;
end;
procedure solution(n:integer); { Основная процедура }
var i,s:integer;
begin
if ((timer-jiffy)TimeLimit) then exit;
i:=testFWD(n);
if (i=0) then begin
StoreChain;
end else begin
inc(pc); {проверили этот путь}
Seq[pc]:=Numbers[i];
solution(i);
dec(pc); {идем по другому}
s:=Numbers[i]; Numbers[i]:=-1; {вычеркнули}
solution(n);
Numbers[i]:=s; {вернули}
end;
end;
var index:integer;
begin
Init;
index:=1;
repeat
pc:=1;
Seq[pc]:=Numbers[index];
solution(index);
while (index=Seq[pc]) do inc(index);
until (indexnum);
Done;
end.
