Разрешение ввода только цифр

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

{ На входе - текст с цифрами (но будут вводиться только цифры }

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

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;

 

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.