Разрешение ввода только цифр
{--------------------------------------------------------------------------}
{ На входе - текст с цифрами (но будут вводиться только цифры }
{--------------------------------------------------------------------------}
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.