Здаров! Воощем тут, самые разные коды... пока для начинающих...
Отредактировано baitur (30-01-2008 18:24:49)
Программирование на языке Pascal - ФОРУМ |
Привет, Гость! Войдите или зарегистрируйтесь.
Вы здесь » Программирование на языке Pascal - ФОРУМ » Задачи по программированию » Разные коды, кому может понадобится
Здаров! Воощем тут, самые разные коды... пока для начинающих...
Отредактировано baitur (30-01-2008 18:24:49)
Начнем с легкого.... { Составить программу подсчета различных букв в слове. } var s:string; r:real; i,j,n:integer; begin r:=0; readln(s); for i:=1 to length(s) do begin n:=0; for j:=1 to length(s) do begin if s[i]=s[j] then inc(n); end; r:=r+1/n; end; writeln('количество различных букв = ', r:1:0); end.
№2
{ Составить программу определения, является ли слово "перевертышем" }
{ Например, "шалаш", "казак" - перевертыш }
var 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,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: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.
{ Составить программу перевода десятичного числа в двоичное }
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 : 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.
{ реурсивные алгоритмы: генерация перестановок }
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.
{ арифметические алгоритмы: моделирование сложения двоичных чисел }
{ ------------------------------------------------------------------------ }
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;
begin
writeln('введите 1-е двоичное число:');
readln(sf);
writeln('введите 2-е двоичное число:');
readln(ss);
sr:=BinAdd(sf,ss);
writeln('результат сложения = ',sr);
end.
{ арифметические алгоритмы: моделирование вычитания двоичных чисел } { ------------------------------------------------------------------------ } var sr,sf,ss:string; { вычитание двоичных строк, первое число должно быть >= второго } function BinSub(s1,s2:string):string; var s:string; l,i,j:byte; begin {выравнивание строк по длине} if length(s1)>length(s2) then while length(s2)<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; begin writeln('введите 1-е двоичное число:'); readln(sf); writeln('введите 2-е двоичное число:'); readln(ss); sr:=BinSub(sf,ss); writeln('результат вычитания = ',sr); 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.
{ Бэк-трекинг: Города } {--------------------------------------------------------------------------} { Задача "Города". } { Широко известна игра "Города". Называется какой-нибудь город, допус- } { тим, "Саратов". Кончается на "в", значит требуется назвать другой город, } { у которого в названии первая буква "в". Это может быть "Воронеж". Следу- } { ющий город должен начинаться на "ж" и т.д. Запрещено повторять название } { городов. Надо написать программу, которая из набора названий городов } { (все названия разные) строит цепочку максимальной длины. } { } { Входные данные: файл 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.
Ну, на сегодня всё...
Супер !!! Так и продолжай.
А вот еще одна задачка: даны 2 числа (a,b<=10^1000) найти их сумму
const base=1000; {основание} var a,b,c:array[0..10000] of integer; //Массивы где хранятся числа (по 3 цифры в ячейке) procedure redln(var a:array of integer); //Процедура чтения чисел var ch:char; i:integer; begin fillchar(a,sizeof(a),0); repeat read(ch); until ch in ['0'..'9']; while ch in ['0'..'9'] do begin for i:=a[0] downto 1 do begin a[i+1]:=a[i+1]+(a[i]*10) div base; a[i]:=(a[i]*10) mod base; end; a[1]:=a[1]+ord(ch)-48; if a[a[0]+1]>0 then inc(a[0]); read(ch); end; end; procedure wrt(a:array of integer); //Процедура вывода ответа var s:string; i:integer; begin write (a[a[0]]); for i:=a[0]-1 downto 1 do begin str(a[i],s); while length(s)<3 do s:='0'+s; write(s); end; writeln; end; procedure sum(a,b:array of integer; var c:array of integer); //сама сумма var i,k:integer; begin fillchar(c,sizeof(c),0); if a[0]>b[0] then k:=a[0] else k:=b[0]; for i:=1 to k do begin c[i+1]:=(c[i]+a[i]+b[i]) div base; c[i]:=(c[i]+a[i]+b[i]) mod base; end; if c[k+1]=0 then c[0]:=k else c[0]:=k+1; end; begin redln(a); redln(b); sum(a,b,c); wrt(c); end.
Ребята, ребята!! Плс!!! Прописывайте в длинных сообщениях код, а то страница грузится долга!
Проредактируйте сообщения плс!
Все спасибо!! Так намного лучше!
program gd_to_jd; { Определение интервала времени между двумя датами григорианского календаря : (Y1,M1,DT1) и (Y2,M2,DT2) } uses Crt; var Y1,M1,Y2,M2:integer; DT1,DT2:double; function JD(Y,M:integer; DT:double):double; { /*******************************************/ /* Перевод даты григорианского календаря */ /* в юлианскую дату (алгоритм Меёса) */ /* Y - григорианский год [-4713,9999] */ /* M - григорианский месяц [1,12] */ /* целая часть dm - день [1,31] */ /* дробная часть dt - время, прошедшее */ /* от начала текущего дня [.0,.99999] */ /* Возвращаемое значение - юлианская дата */ /* Целая часть JD - число дней, прошедших */ /* от 1 января 4713 года до новой эры */ /* Дробная часть JD - время, прошедшее */ /* после 12 часов полудня дня JD */ /*******************************************/ } var a,b,mm,yy:integer; c:longint; begin b:=0; yy:=Y; mm:=M; if M<3 then begin yy:=yy-1; mm:=mm+12; end; a := yy div 100; if (Y + M/100. + DT/10000) > 1582.1015 then b :=b + 2 - a + (a div 4); c:=trunc(365.25*yy); if yy<0 then c:=trunc(365.25*yy-0.75); JD:= c+trunc(30.6001*(mm+1))+DT+1720994.5+b; end; function dif_time(Y1,M1:integer; DT1:double; Y2,M2:integer; DT2:double):double; { /***************************************/ /* Определение интервала времени между */ /* двумя григорианскими датами */ /* Y1,Y2 - годы M1,M2 - месяцы */ /* целые части DT1, DT2 - дни */ /* дробные части DT1, DT2 - время дня */ /***************************************/ } var jd1,jd2:double; begin jd1 := JD(Y1,M1,DT1); jd2 := JD(Y2,M2,DT2); dif_time := abs(jd1-jd2); end; begin clrscr; write('Задайте год григорианского календаря : '); readln(Y1); write('Задайте месяц григорианского календаря : '); readln(M1); write('Задайте день и время : '); readln(DT1); write('Задайте год григорианского календаря : '); readln(Y2); write('Задайте месяц григорианского календаря : '); readln(M2); write('Задайте день и время : '); readln(DT2); writeln('Интервал = ',dif_time(Y1,M1,DT1,Y2,M2,DT2):10:0); readln; end.
program WeekDay; { Определение дня недели } uses Crt; var Y,M,D,day:integer; function JD(Y,M:integer; DT:double):double; { /*******************************************/ /* Перевод даты григорианского календаря */ /* в юлианскую дату (алгоритм Меёса) */ /* Y - григорианский год [-4713,9999] */ /* M - григорианский месяц [1,12] */ /* целая часть dm - день [1,31] */ /* дробная часть dt - время, прошедшее */ /* от начала текущего дня [.0,.99999] */ /* Возвращаемое значение - юлианская дата */ /* Целая часть JD - число дней, прошедших */ /* от 1 января 4713 года до новой эры */ /* Дробная часть JD - время, прошедшее */ /* после 12 часов полудня дня JD */ /*******************************************/ } var a,b,mm,yy:integer; c:longint; begin b:=0; yy:=Y; mm:=M; if M<3 then begin yy:=yy-1; mm:=mm+12; end; a := yy div 100; if (Y + M/100. + DT/10000) > 1582.1015 then b :=b + 2 - a + (a div 4); c:=trunc(365.25*yy); if yy<0 then c:=trunc(365.25*yy-0.75); JD:= c+trunc(30.6001*(mm+1))+DT+1720994.5+b; end; function week_day(Y,M,D:integer):integer; { /*******************************************/ /* Определение дня недели */ /* Y - григорианский год */ /* M - григорианский месяц (1 - 12) */ /* D - день (1 - 31) */ /* Возвращаемое значение : */ /* 0 - воскр., 1 - понед., 2 - вторник,... */ /*******************************************/ } begin week_day:= trunc(JD(Y,M,D+1.5)) mod 7; end; begin clrscr; write('Задайте год григорианского календаря : '); readln(Y); write('Задайте месяц григорианского календаря : '); readln(M); write('Задайте день : '); readln(D); day:=week_day(Y,M,D); writeln('день недели = ',day); readln; end.
Вы здесь » Программирование на языке Pascal - ФОРУМ » Задачи по программированию » Разные коды, кому может понадобится