Список задач которые нужно знать наизусть для победы волимпиадахпопрограммированию (А.Штафун): - подсчет различныхбукввслове
- перестановка букв вслове (циклическийсдвигвправо)
- определения,являетсялислово "перевертышем"
- печать всехделителейнатуральногочисла A
- печать всехсовершенныхчиселдо 10000
- печать всехпростыхчиселдо 500
- подсчетсуммыцифрчисла
- подсчет суммыэлементоводномерногомассива
- подсчет суммыэлементовдвухмерногомассива
- поиск максимальногоэлементавмассиве
- поиск минимальногоэлементавмассиве
- поиск среднегоарифметическоговмассиве
- печать всех элементовмассиваизинтервала C..D
- циклический сдвигэлементовмассивавправо
- печать самого часто встречающегосяэлементаизмассива
- все лиэлементымассиваразличны?
-сортировкамассива "пузырьком"
-решениеуравнения: A*x^2 + B*x + C = 0
-вычислениедлиныотрезка |AB|
- какая точка (A или B) ближекначалукоординат
- вычисление площадитреугольникапо 3вершинам
- попадает ли точка M(x,y) в круг сцентром O(Xc,Yc)ирадиусом R
- перевода десятичногочиславдвоичное
- перевода двоичногочиславдесятичное
- перевода десятичногочиславшестнадцатеричное
- перевода шестнадцатеричногочиславдесятичное
- рекурсивные алгоритмы: нахождения НОД иНОКдвухчисел
- рекурсивныеалгоритмы:вычислениефакториал
- рекурсивныеалгоритмы:генерацияперестановок
- рекурсивныеалгоритмы:быстраясортировка
- решение системы 2-х уравненйсдвумянеизвестными
- решение системы 3-х уравненйстремянеизвестными
- определениепересечениядвухотрезков
- определение положенияточкиотносительносектора
- положениеточкиотносительновектора
- положениеточкиотносительнотреугольника (вариант 1)
- положениеточкиотносительнотреугольника (вариант 2)
- моделированиесложениядвоичныхчисел
- моделированиевычитаниядвоичныхчисел
- возведение целого числавнатуральнуюстепень (вариант 1)
- возведение целого числавнатуральнуюстепень (вариант 2)
- умножение длинныхнатуральныхдесятичныхчисел
- кодировка: пример простойкодировки (сдвигпоключу)
- обработка текста: подсчет количествасловвтексте
- обработка текста: выделениесловизтекста
- обработка текста: выделениечиселизтекста
- обработка текста: разрешениевводатолькоцифр
- обработка текста: перевод вмаленькиебуквы (нижнийрегистр)
- обработка текста: перевод взаглавныебуквы (верхнийрегистр)
- обработка текста: удаление изтекстакомметариевтипа {...}
-бэк-трекинг:Города
- бэк-трекинг: Обходшахматнойдоскиконем
- бэк-трекинг:Проходполабиринту
-бэк-трекинг:Домино
-бэк-трекинг:Последовательность
- бэк-трекинг: Магический квадрат
А вот собственно и их решения на Паскале, так как языком олимпиад считается PASCAL :
{ Составить программу печати всехделителейнатуральногочисла A }
var a,n,c,d:word;
begin {основнаяпрограмма }
readln( a );
n:=1;
while ( n <= sqrt(a) ) do begin
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.
{ Составить программу печати всехсовершенныхчиселдо 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 (j<>d) then inc(s,d); {дважды нескладыватькореньчисла}
end;
end;
if s=i then writeln(i);
end;
end.
{ Составить программу печати всехпростыхчиселдо 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 <= lim) do inc( j );
if (j > lim) then write( i,' ' );
end;
end.
{ Подсчетсуммыцифрчисла }
var a,x:integer;
i,s:integer;
begin
writeln('введитецелоечисло');
readln( a ); x:=a;
s:=0;
while ( x<>0 ) do begin
s := s + (x mod 10);
x := x div 10;
end;
writeln( 'Суммацифрчисла ',a,' = ', s );
end.
{ печать самого часто встречающегосяэлементаизмассива }
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 n>m then begin
m:=n; p:=i;
end;
end;
writeln('самыйчастовстречающийсяэлемент:',a[p]);
end.
{ вычисление длины отрезка,знаякоординаты Aи B }
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.
{ какая точка (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<d2 then writeln('Точка Aближе')
else if d1>d2 then writeln('Точка Bближе')
else writeln('Одинаково');
end.
{ попадает ли точка 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<=r then writeln ('точка Mлежитвкруге')
else writeln ('точка Mлежитвнекруга');
end.
{ Составить программу перевода десятичногочиславдвоичное }
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 (x<>0) 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.
{ Составить программу перевода двоичногочиславдесятичное }
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.
{ Составить программу перевода десятичногочиславшестнадцатеричное }
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 (x<>0) 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.
{ Составить программу перевода шестнадцатеричногочиславдесятичное }
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;
{ Рекурсивные алгоритмы: нахождения НОД иНОКдвухчисел }
var a,b:longint;
function NOD(x,y:longint):longint; { фукнция поисканаиб.общ.делителя }
begin
if x<>0 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;
{рекурсивныеалгоритмы:генерацияперестановок }
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[J], то уменьшаем J на 1 и проводимследующеесравнениеэлемен- }
{ тов A[I] с A[J]. Последовательное уменьшение индекса Jисравнениеука- }
{ занных элементов A[I] с A[J] продолжаем до техпор,покавыполняется }
{ условие A[I] <= A[J]. Как только A[I] станетбольше A[J],меняемместа- }
{ ми элементы A[I] с A[J], увеличиваем индекс I на 1ипродолжаемсравне- }
{ ние элементов A[I] с A[J]. Последовательноеувеличениеиндекса Iи }
{ сравнение (элементов A[I] с A[J]) продолжаем до техпор,покавыполня- }
{ ется условие A[I] <= A[J]. Как только 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]<x) do inc(i);
while (x<A[j]) do dec(j);
if ( i<=j ) then
begin
y:=A[i]; a[i]:=a[j]; a[j]:=y;
inc(i); dec(j);
end;
until (i>j);
if (l<j) then QuickSort(l,j);
if (i<r) then QuickSort(i,r);
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.
{ решение системы 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 ( d<>0 ) and ( (dx=0) or (dy=0) ) then
writeln('нетрешений')
else begin
x:=dx/d; y:=dy/d;
writeln('x = ', x); writeln('y = ', y);
end;
end.
{ решение системы 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 ( e<>0 ) 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.
{ геометрические алгоритмы:Пересекаютсяли 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<0) and (v3*v4<0);
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<0 then sign:=-1 else sign:=1;
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 s>0 then WherePoint:=1
else if s<0 then WherePoint:=-1
else WherePoint:=0;
end;
Begin (*Телоосновнойпрограммы *)
i:=WherePoint(1,1,8,8,2,5);
if i > 0 then writeln('точкаслеваотвектора')
else if i < 0 then writeln('точкасправаотвектора')
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 s>0 then WherePoint:=1
else if s<0 then WherePoint:=-1
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<=0 then EXIT;
s3:=WherePoint(cx,cy,ax,ay,px,py);
if s3*s2<=0 then EXIT;
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*error>s1+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.
{ арифметические алгоритмы: моделированиесложениядвоичныхчисел }
{ ------------------------------------------------------------------------ }
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)<length(s1) do s2:='0'+s2
else while length(s1)<length(s2) do s1:='0'+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 carry<>0 then s:='1'+s;
BinAdd:=s;
end;
{ вычитание двоичных строк, первое числодолжнобыть >=второго }
function BinSub(s1,s2:string):string;
var s:string; l,i,j:byte;
begin
{выравниваниестрокподлине}
if length(s1)>length(s2) then while length(s2)<length(s1) do s2:='0'+s2
else while length(s1)<length(s2) do s1:='0'+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-j>0) 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;
function Degree(a,b:integer):longint;
var r:longint;
begin
r:=1;
while b>0 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 b>0 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<=high(row)) do begin
write(char(row[dp]+ord('0')));
inc(dp);
end;
writeln;
end;
{Умножение по Аль-Хорезми,в 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 (cc>0) do begin
i:=cr; j:=cc; sum:=carry;
while (i<=nr) and (j>=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 cr>1 then dec(cr) else dec(cc);
end;
while (carry<>0) 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.
{ Кодировка: Пример простойкодировки (сдвигпоключу) }
{--------------------------------------------------------------------------}
{ Алгоритм: каждый код символа увеличиваетсянанекотороечисло - "ключ" }
{--------------------------------------------------------------------------}
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.
{ Обработка текста: Подсчет количествасловвтексте }
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - количествословвтексте }
{--------------------------------------------------------------------------}
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<=length(s)) do inc(i);
if (i<=length(s)) then inc(wc);
while (s[i] in Alpha) and (i<=length(s)) do inc(i);
Until (i>length(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<=length(s)) do inc(i);
t:='';
while (s[i] in Alpha) and (i<=length(s)) do begin
t:=t+s[i];
inc(i);
end;
if length(t)<>0 then writeln(t);
Until (i>length(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<=length(s)) do inc(i);
d:='';
while (s[i] in Digits) and (i<=length(s)) do begin
d:=d+s[i];
inc(i);
end;
if length(d)<>0 then writeln(d);
Until (i>length(s));
end.
{ Обработка текста: Разрешениевводатолькоцифр }
{--------------------------------------------------------------------------}
{ На входе - текст с цифрами (но будутвводитьсятолькоцифры }
{--------------------------------------------------------------------------}
uses crt;
const ENTER=#13;
var c:char;
begin
writeln('Вводитебуквыицифры');
c:=readkey;
while (c<>ENTER) 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.
{Бэк-трекинг:Города }
{--------------------------------------------------------------------------}
{Задача "Города". (А.Н.Никитин) }
{ Широко известна игра "Города". Называетсякакой-нибудьгород,допус- }
{ тим, "Саратов". Кончается на "в", значит требуетсяназватьдругойгород, }
{ у которого в названии первая буква "в". Этоможетбыть "Воронеж".Следу- }
{ ющий город должен начинаться на "ж" и т.д.Запрещеноповторятьназвание }
{ городов. Надо написать программу, которая изнабораназванийгородов }
{ (все названия разные) строитцепочкумаксимальнойдлины. }
{ }
{ Входные данные: файл 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 (numin>mnt) 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 (ml>0) then begin
for i:=1 to ml do writeln(store[i]);
end;
close(output);
end;
procedure store_chain; { Запоминаем толькоболеедлиннуюцепочку }
var i:integer;
begin
if (pc>ml) 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 (i<=numin) and (n>0) 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 (i>0) 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.
{ Бэк-трекинг: Обход шахматной доски конем, маршрутсм.вфайле 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 (p>pred(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;
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 (i>1) and (a[i-1,j]=0) then FindPath(i-1,j);
if (i<n) and (a[i+1,j]=0) then FindPath(i+1,j);
if (j>1) and (a[i,j-1]=0) then FindPath(i,j-1);
if (j<m) and (a[i,j+1]=0) then FindPath(i,j+1);
end;
dec(index);
a[i,j]:=0;
end;
begin
INIT;
FindPath(si,sj);
DONE;
end.
{Бэк-трекинг:Домино }
{--------------------------------------------------------------------------}
{ Берутся случайных N костяшек изодногонаборадомино (1<=N<=28). }
{ Задача состоит в том, чтобы образовать из этих 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 (maxlen>1) then begin
i:=1;
while (i<pred(maxlen)) do begin
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-1>maxlen) 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<=6) and not(m[k,i]) do inc(i);
exist:=(i<=6);
end;
{построениецепочек }
procedure make_cep(f:integer);
var s:integer;
begin
if (yes) or (tl-jiffy<=0) then exit; {пораостановиться?}
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<=N<=100). }
{ Со 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 }
{--------------------------------------------------------------------------}
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 num>MaxItem 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 (pc>maxpc) 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 (i<=num) and (m>Numbers[i]) do inc(i);
if i>num 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<=num) and (Numbers[index]>=Seq[pc]) do inc(index);
until (index>num);
Done;
end.
{Бэк-трекинг:Магическиеквадраты }
{ Построить матрицу NxN, в которой сумма элементов вкаждойстроке,в }
{ столбце, в каждой диагонали (их 2)имеютодинаковуюсумму. }
{ Подсказка: такая сумма может быть определеназаранееиравна }
{ n*n(n*n+1) div (2*n) }
{--------------------------------------------------------------------------}
const N=3; SQRN = N*N; {будетматрица NxN}
IdealSum = N*(SQRN+1) div 2;
var a:array[1..SQRN] of byte;
b:array[1..SQRN] of byte;
f:boolean; recurse:longint;
Procedure PRINT;
var i,j:integer;
begin
assign(output,'magic.out'); rewrite(output);
for i:=1 to N do begin
for j:=1 to N do write(a[pred(i)*N+j],' ');
writeln;
end;
end;
function TestRow(i:integer):boolean;
var j,s:integer;
begin
s:=0; i:=(i-1)*n;
for j:=1 to N do s:=s+a[i+j];
TestRow:=(s=IdealSum);
end;
function TestCol(i:integer):boolean;
var j,s:integer;
begin
s:=0;
for j:=1 to N do s:=s+a[(j-1)*N+i];
TestCol:=(s=IdealSum);
end;
function TestDiag:boolean;
var j,s:integer;
begin
s:=0;
for j:=1 to N do s:=s+a[(N-j)*N+j];
TestDiag:=(s=IdealSum);
end;
function TestMagic:boolean; {Тест всей матрицы насоотв.маг.квадрату}
var srow,scol,sdiag1,sdiag2,i,j:integer;
begin
TestMagic:=FALSE;
sdiag1:=0; sdiag2:=0;
for i:=1 to N do begin
srow:=0; scol:=0;
for j:=1 to N do begin
srow:=srow+a[pred(i)*N+j];
scol:=scol+a[pred(j)*N+i];
end;
if (srow<>scol) or (scol<>IdealSum) then EXIT;
sdiag1:=sdiag1+a[pred(i)*N+i];
sdiag2:=sdiag2+a[(N-i)*N+i];
end;
if (sdiag1<>sdiag2) or (sdiag2<>IdealSum) then EXIT;
TestMagic:=TRUE;
end;
procedure SqMagic(k:integer);
var i:integer; still:boolean;
begin
i:=1;
while (i<=SQRN) and NOT(f) do begin
still:=true;
if b[i]=0 then begin
b[i]:=1; a[k]:=i;
if k=SQRN then begin
if TestMagic then begin PRINT; f:=true; still:=false; end;
end else if (k mod n=0) then begin {еслизавершенастрока}
if NOT(TestRow(k div n)) then still:=false;
end else if (k>SQRN-N) then begin {еслизавершенстолбец}
if NOT(TestCol(k mod n)) then still:=false;
end else if (k=SQRN-N+1) then begin {еслизавершенадиагональ}
if NOT(TestDiag) then still:=false;
end;
if still then SqMagic(k+1);
b[i]:=0;
end;
inc(i);
end;
end;
begin
f:=false; recurse:=0;
fillchar(a,sizeof(a),0); fillchar(b,sizeof(b),0);
SqMagic(1);
end.