Подсчет различных букв в слове

Подсчет различных букв в слове

vars: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.

Перестановка букв в слове (циклический сдвиг вправо)

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.

Печать всех делителей натурального числа 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: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.

Подсчет суммы элементов двухмерного массива

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.

Поиск минимального элемента в массиве?

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 min>a[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]<=D) then writeln(a[i]);

end;

end.

Циклический сдвиг элементов массива вправо

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.

Печать самого часто встречающегося элемента из массива

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.

Все ли элементы массива различны?

Вариант с циклом 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<10) and (j<11) do begin

j:=i+1;

while (j<11) and (a[i]<>a[j]) do inc(j);

inc(i);

end;

if i<11 then writeln('в массиве есть одинаковые элементы')

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<10 then break;

end;

if i<9 then writeln('в массиве есть одинаковые элементы')

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<0 then begin

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.

Вычисление длины отрезка

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.

Рекурсивные алгоритмы

Вычисление факториала

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[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 отрезка?

{ ------------------------------------------------------------------------ }

{ Определяет пересечение отрезков 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.

С какой стороны вектора лежит точка? Вариант 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.

Арифметические алгоритмы

Вариант 1 (обычный)

var x,y:integer;

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.

Кодировка. Пример простой кодировки (сдвиг по ключу)

{--------------------------------------------------------------------------}

{ Алгоритм: каждый код символа увеличивается на некоторое число - "ключ" }

{--------------------------------------------------------------------------}

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,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.

Бэк-трекинг: Города

{--------------------------------------------------------------------------}

{ Задача "Города". (А.Н.Никитин) }

{ Широко известна игра "Города". Называется какой-нибудь город, допус- }

{ тим, "Саратов". Кончается на "в", значит требуется назвать другой город, }

{ у которого в названии первая буква "в". Это может быть "Воронеж". Следу- }

{ ющий город должен начинаться на "ж" и т.д. Запрещено повторять название }

{ городов. Надо написать программу, которая из набора названий городов }

{ (все названия разные) строит цепочку максимальной длины. }

{ }

{ Входные данные: файл 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;

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 (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 }

{--------------------------------------------------------------------------}

{$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 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.

Подсчет различных букв в слове

vars: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.