Программирование на языке Pascal - ФОРУМ

Объявление

Продолжается конкурс на "Самый прикоьный юзербар" Голосовать и просматривать голоса других вы можете в форуме События, раздел "Голосование"

Информация о пользователе

Привет, Гость! Войдите или зарегистрируйтесь.


Вы здесь » Программирование на языке Pascal - ФОРУМ » Задачи по программированию » Разные коды, кому может понадобится


Разные коды, кому может понадобится

Сообщений 1 страница 30 из 36

1

Здаров! Воощем тут, самые разные коды... пока для начинающих...

Отредактировано baitur (30-01-2008 18:24:49)

0

2

Код:
Начнем с легкого.... 

{ Составить программу подсчета различных букв в слове. }
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.

0

3

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

0

4

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

0

5

{ Составить программу печати всех совершенных чисел до 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.

0

6

{ Составить программу печати всех простых чисел до 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.

0

7

{ Подсчет суммы цифр числа }
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.

0

8

Код:
{ все ли элементы массива различны? }
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.

0

9

{ Составить программу перевода десятичного числа в двоичное }
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.

ну наобарот конвертер не стану писать, итак ясно

0

10

Ну а это уже мини ХЕКС редактор))) грю ж мини))

{ Составить программу перевода десятичного числа в шестнадцатеричное }
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.

0

11

{ реурсивные алгоритмы: генерация перестановок }
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.

0

12

Код:
Ну вот и дошли до быстрой сортировки... Может, кому и полезно будет


{  реурсивные алгоритмы: быстрая сортировка, см. программу внизу           }
{  ----------------------------------------------------------------------- }
{                           БЫСТРАЯ СОРТИРОВКА.                            }
{       Устанавливаем 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.

0

13

{ арифметические алгоритмы: моделирование сложения двоичных чисел          }
{ ------------------------------------------------------------------------ }
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.

0

14

Код:
{ арифметические алгоритмы: моделирование вычитания двоичных чисел         }
{ ------------------------------------------------------------------------ }
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.

0

15

{ Обработка текста: Подсчет количества слов в тексте                       }
{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - количество слов в тексте                   }
{--------------------------------------------------------------------------}
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.

0

16

Код:
{ Бэк-трекинг: Города                                                      }
{--------------------------------------------------------------------------}
{ Задача "Города".                                                         }
{    Широко известна  игра "Города". Называется какой-нибудь город, допус- }
{ тим, "Саратов". Кончается на "в", значит требуется назвать другой город, }
{ у которого в названии первая буква "в". Это может быть "Воронеж". Следу- }
{ ющий город должен начинаться на "ж" и т.д.  Запрещено повторять название }
{ городов. Надо написать программу, которая  из  набора  названий  городов }
{ (все названия разные) строит цепочку максимальной длины.                 }
{                                                                          }
{    Входные данные: файл 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.

+1

17

Код:
Пошли уже вещи посерезнее

{ Бэк-трекинг: Обход шахматной доски конем, маршрут см. в файле 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.

0

18

Код:
Блин, моя любимая задача 


{ Бэк-трекинг: Проход по лабиринту                                         }
{ Есть матрица 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.

0

19

Код:
Ну а эт.... воощем ес че непонятно обращайтесь 
{ Бэк-трекинг: Домино                                                      }
{--------------------------------------------------------------------------} 
{ Берутся случайных 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.

0

20

Код:
Хорошая классическая задача
{ Бэк-трекинг: Последовательность                                          }
{--------------------------------------------------------------------------}
{ Дана последовательность натуральных чисел (значение каждого числа        }
{ от 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.

0

21

Код:
{ Бэк-трекинг: Магические квадраты                                         }
{ Построить матрицу 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.

0

22

Ну, на сегодня всё...

+1

23

Супер !!! Так и продолжай.

0

24

А вот еще одна задачка: даны 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.

0

25

Ребята, ребята!! Плс!!!   Прописывайте в длинных сообщениях код, а то страница грузится долга!
:-(

0

26

ок

0

27

Проредактируйте сообщения плс!

0

28

Все спасибо!!  Так намного лучше!

0

29

Код:
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.

0

30

Код:
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.

0


Вы здесь » Программирование на языке Pascal - ФОРУМ » Задачи по программированию » Разные коды, кому может понадобится


Рейтинг форумов | Создать форум бесплатно