Примеры программ на языке Паскаль

(Источник: А.Никитин, ТАСУР, КЭВА)
 

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

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

3. Определить, является ли слово "перевертышем". 2

4. Печать всех делителей натурального числа A.. 2

5. Печать всех совершенных чисел до 10000. 3

6. Печать всех простых чисел до 500. 3

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

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

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

10. Печать всех элементов массива из интервала C...D.. 4

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

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

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

Вариант с циклом WHILE.. 5

Вариант с циклом FOR.. 5

14. Сортировка массива "пузырьком" по возрастанию.. 5

15. Решение уравнения: A*x^2 + B*x + C = 0. 6

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

17. Какая точка (A или B) ближе к началу координат. 6

18. Вычисление площади треугольника по 3 вершинам.. 6

19. Попадает ли точка M(x,y) в круг с центром O(Xc,Yc) и радиусом R 7

20. Перевод десятичного числа в двоичное. 7

21. Перевод двоичного числа в десятичное. 7

22. Перевод десятичного числа в шестнадцатеричное. 7

23. Перевод шестнадцатеричного числа в десятичное. 8

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

Нахождение НОД и НОК двух чисел. 8

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

Генерация перестановок. 9

Быстрая сортировка. 9

25. Решение системы 2-х уравнений с двумя неизвестными. 10

26. Решение системы 3-х уравнений с тремя неизвестными. 10

27. Геометрические алгоритмы.. 11

Пересекаются ли 2 отрезка?. 11

Точка внутри сектора или нет?. 11

С какой стороны вектора лежит точка?. 12

С какой стороны вектора лежит точка? Вариант 1. 13

Точка внутри треугольника?  Вариант 2. 13

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

Моделирование сложения двоичных чисел. 14

Моделирование вычитания двоичных чисел. 14

Возведение целого числа в натуральную степень. 15

Умножение длинных натуральных десятичных чисел. 16

29. Умножение по Аль-Хорезми, в ROW - 1 число,в COL - 2 число. 16

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

31. Обработка текста. 17

Подсчет количества слов в тексте. 17

Выделение слов из текста. 17

Выделение чисел из текста. 18

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

Перевод в маленькие буквы (нижний регистр) 18

Перевод в заглавные буквы (верхний регистр) 19

Удаление из текста комметариев типа {...}. 19

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

33. Бэк-трекинг. 21

Обход шахматной доски конем.. 21

Проход по лабиринту. 22

Домино. 23

Последовательность. 25

Магические квадраты.. 27

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

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 s:string;
    i,j,n:integer;
begin
    readln(s);
    s:=s[length(s)] + copy(s,1,length(s)-1);
 writeln(s);
end.

3. Определить, является ли слово "перевертышем"

{ Например, "шалаш", "казак" - перевертыш }
program primer1;
var s1,s2:string;
    i:integer;
begin
    readln(s1); s2:='';
    for i:=length(s1) downto 1 do begin
       s2:=s2+s1[i];
    end;
    if s1=s2 then writeln(s1, ' - перевертыш')
             else  writeln(s1, ' - не перевертыш');
end.

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.

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.

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.

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

var a:array[1..10] of integer;
    s:longint;
    i:integer;
begin
     writeln('введите 10 элементов массива');
     s:=0;
     for i:=1 to 10 do begin
        readln( a[i] );
        s:=s+a[i];
 end;
     writeln( 'Сумма элементов массива = ', s );
end.

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

var a:array[1..10,1..2] of integer;
    s:longint;
    i,j:integer;
begin
     writeln('введете 20 элементов массива');
 s:=0;
     for i:=1 to 10 do begin
        for j:=1 to 2 do begin
           readln( a[i,j] );
           s:=s+a[i,j];
        end;
     end;
 writeln( 'Сумма элементов массива = ', s );
end.

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

var a:array[1..10] of integer;
    min:integer;
    i:integer;
begin
     writeln('введите 10 элементов массива');
     min:=MAXINT;
     for i:=1 to 10 do begin
        readln( a[i] );
        if min>a[i] then min:=a[i];
 end;
     writeln( 'Максимальный элемент массива = ', min );
end.

10. Печать всех элементов массива из интервала C...D

var a:array[1..10] of integer;
    c,d:integer;
    i:integer;
begin
     writeln('введите 10 элементов массива');
 for i:=1 to 10 do readln( a[i] );
 writeln('введите интервал C и D');
 readln( c,d );
     for i:=1 to 10 do begin
        if (a[i]>=C) and (a[i]<=D) then writeln(a[i]);
 end;
end.

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

var a:array[1..10] of integer;
    x:integer;
    i:integer;
begin
     writeln('введите 10 элементов массива');
     for i:=1 to 10 do readln( a[i] );
     x:=a[10];
     for i:=10 to 2 do begin
       a[i]:=a[i-1];
     end;
     a[1]:=x;
     writeln('после сдвига:');
     for i:=1 to 10 do writeln( a[i] );
end.

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

var a:array[1..10] of integer;
    i,j,m,p,n:integer;
begin
     writeln('введите 10 элементов массива');
 for i:=1 to 10 do readln( a[i] );
     m:=1; p:=1;
     for i:=1 to 10 do begin
       n:=0;
       for j:=1 to 10 do begin
          if a[i]=a[j] then inc(n);
       end;
       if n>m then begin
          m:=n; p:=i;
       end;
     end;
 writeln('самый часто встречающийся элемент:',a[p]);
end.

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

Вариант с циклом WHILE

 
var a:array[1..10] of integer;
    i,j:integer;
begin
     writeln('введите 10 элементов массива');
     for i:=1 to 10 do readln( a[i] );
     i:=1;
     while (i<10) and (j<11) do begin
       j:=i+1;
       while (j<11) and (a[i]<>a[j]) do inc(j);
       inc(i);
     end;
     if i<11 then writeln('в массиве есть одинаковые элементы')
             else writeln('все элементы массива различны');
end.

Вариант с циклом FOR

var a:array[1..10] of integer;
    i,j:integer;
begin
     writeln('введите 10 элементов массива');
     for i:=1 to 10 do readln( a[i] );
     for i:=1 to 9 do begin
       for j:=i+1 to 10 do begin
          if a[i]=a[j] then break;
       end;
       if j<10 then break;
 end;
     if i<9 then writeln('в массиве есть одинаковые элементы')
             else writeln('все элементы массива различны');
end.

14. Сортировка массива "пузырьком" по возрастанию

const n = 10; { количество элементов в массиве }
var a:array[1..n] of integer;
    i,j,x:integer;
begin
     writeln('введите ',n,' элементов массива');
     for i:=1 to n do readln( a[i] );
 
     for i:=1 to n-1 do begin
         for j:=i+1 to n do begin
           if a[i]>a[j] then begin
              x:=a[i]; a[i]:=a[j]; a[j]:=x;
           end;
         end;
     end;
     writeln('после сортировки:');
     for i:=1 to n do writeln( a[i] );
end.

15. Решение уравнения: A*x^2 + B*x + C = 0

var a,b,c,d,x:real;
begin
     writeln('введите A,B,C');
     readln( a,b,c );
     d:=sqr(b)-4*a*c;
 if d<0 then begin
        writeln('действительных корней нет');
 end else if d=0 then begin
 x:=(-b)/2*a;
        writeln('корень уравнения: ',x);
 end else begin
        x:=(-b+sqrt(d))/2*a;
 writeln('1-й корень уравнения: ',x);
        x:=(-b-sqrt(d))/2*a;
        writeln('2-й корень уравнения: ',x);
     end
end.

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

var x1,y1,x2,y2,d:real;
begin
     writeln('введите A(X1,Y1) и B(X2,Y2)');
     readln( x1,y1,x2,y2 );
     d:=sqrt(sqr(y2-y1)+sqr(x2-x1));
 writeln('длина отрезка |AB|=',d);
end.

17. Какая точка (A или B) ближе к началу координат

var x1,y1,x2,y2,d1,d2:real;
begin
     writeln('введите A(X1,Y1) и B(X2,Y2)');
     readln( x1,y1,x2,y2 );
     d1:=sqrt(sqr(y1)+sqr(x1));
     d2:=sqrt(sqr(y2)+sqr(x2));
     if d1<d2 then writeln('Точка A ближе')
     else if d1>d2 then writeln('Точка B ближе')
 else writeln('Одинаково');
end.

18. Вычисление площади треугольника по 3 вершинам

var x1,y1,x2,y2,x3,y3,a,b,c,p,s:real;
begin
     writeln('введите A(X1,Y1), B(X2,Y2) и C(X3,Y3)');
     readln( x1,y1,x2,y2,x3,y3 );
     c:=sqrt(sqr(y1-y2)+sqr(x1-x2));
     a:=sqrt(sqr(y2-y3)+sqr(x2-x3));
     b:=sqrt(sqr(y1-y3)+sqr(x1-x3));
     p:=(a+b+c)/2;
     s:=p*sqrt((p-a)*(p-b)*(p-c));
 writeln('площадь треугольника = ',s);
end.

19. Попадает ли точка M(x,y) в круг с центром O(Xc,Yc) и радиусом R

var xc,yc,mx,my,d,r:real;
begin
     writeln('введите M(X,Y), O(Xc,Yc) и R');
     readln( mx,my,xc,yc,r );
     d:=sqrt(sqr(xc-mx)+sqr(yc-my));
 if d<=r then writeln ('точка M лежит в круге')
             else writeln ('точка M лежит вне круга');
end.

20. Перевод десятичного числа в двоичное

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.

21. Перевод двоичного числа в десятичное

var a : string;
 
function BIN_DEC(x:string):longint;
const digits:array [0..1] of char = ('0','1');
var res,ves:longint; i,j:byte;
begin
   res:=0; ves:=1;
   for i:=length(x) downto 1 do begin
      j:=0;
      while (digits[j]<>x[i]) do inc(j);
      res:=res+ves*j;
      ves:=ves*2;
   end;
   BIN_DEC:=res;
end;
 
begin { основная программа }
  readln( a );
 writeln( BIN_DEC(a) );
end.

22. Перевод десятичного числа в шестнадцатеричное

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.

23. Перевод шестнадцатеричного числа в десятичное

var a : string;
 
function HEX_DEC(x:string):longint;
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,ves:longint; i,j:byte;
begin
   res:=0; ves:=1;
   for i:=length(x) downto 1 do begin
      j:=0; a[i]:=UpCase(a[i]);
      while (digits[j]<>x[i]) do inc(j);
      res:=res+ves*j;
      ves:=ves*16;
   end;
   HEX_DEC:=res;
end;
 
begin { основная программа }
  readln( a );
 writeln( HEX_DEC(a) );
end.

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

Нахождение НОД и НОК двух чисел

var a,b:longint;
 
function NOD(x,y:longint):longint; { фукнция поиска наиб. общ. делителя }
begin
   if x<>0 then NOD:=NOD(y mod x,x) else NOD:=y;
end;
 
function NOK(x,y:longint):longint; { фукнция поиска наим. общ. кратного }
begin
   NOK:=( x div NOD(x,y) ) * y;
end;
 
begin { основная программа }
    readln(a,b);
    writeln( 'НОД этих чисел = ', NOD(a,b) );
    writeln( 'НОК этих чисел = ', NOK(a,b) );
end.

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

var n:integer;
 
function f(x:integer):longint;
begin
   if x = 1 then f := 1 else f := x * f(x-1);
end;
 
begin
     writeln('введите N (N=1..13)');
     readln(n);
     writeln('N!=',f(n));
end.

Генерация перестановок

const n = 3; { количество элементов в перестановке}
var   a:array[1..n] of integer;
      index : integer;
 
procedure generate (l,r:integer);
var i,v:integer;
begin
      if (l=r) then begin
        for i:=1 to n do write(a[i],' ');
        writeln;
      end else begin
        for i := l to r do begin
           v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[j]}
 generate(l+1,r);              {вызов новой генерации}
 v:=a[l]; a[l]:=a[i]; a[i]:=v; {обмен a[i],a[j]}
        end;
      end;
end;
 
begin
      for index := 1 to N do A[index]:=index;
 generate( 1,n );
end.

Быстрая сортировка

{  ----------------------------------------------------------------------- }
{                           БЫСТРАЯ СОРТИРОВКА.                            }
{       Устанавливаем I=1 и J=N. Сравниваем элементы  A[I]  и  A[J].  Если }
{  A[I]<=A[J], то уменьшаем J на 1 и проводим  следующее сравнение элемен- }
{  тов A[I] с A[J]. Последовательное уменьшение индекса J и сравнение ука- }
{  занных элементов  A[I] с A[J] продолжаем  до тех пор,  пока выполняется }
{  условие A[I] <= A[J]. Как только A[I] станет больше A[J], меняем места- }
{  ми элементы A[I] с A[J], увеличиваем индекс I на 1 и продолжаем сравне- }
{  ние  элементов  A[I] с A[J]. Последовательное увеличение  индекса  I  и }
{  сравнение (элементов A[I] с A[J]) продолжаем до тех  пор, пока выполня- }
{  ется условие A[I] <= A[J].  Как  только A[I] станет больше A[J],  опять }
{  меняем местами элементы A[I] с A[J], снова начинаем уменьшать J.        }
{       Чередуя уменьшение J и увеличение I, сравнение и необходимые обме- }
{  ны, приходим к некоторому элементу, называемому  пороговым или главным, }
{  характеризующим условие  I=J. В результате элементы массива оказываются }
{  разделенными на две части так, что все элементы слева - меньше главного }
{  элемента, а все элементы справа - больше главного элемента.             }
{       К этим  массивам применяем рассмотренный алгоритм, получаем четыре }
{  части и т.д. Процесс закончим, когда массив A станет полностью отсорти- }
{  рованным.                                                               }
{       При программировании алгоритма "Быстрой сортировки" удобно исполь- }
{  зовать рекурентные вызовы процедуры сортировки (рекурсию).              }
{  ----------------------------------------------------------------------- }
 
var a:array[1..10] of integer; { массив элементов }
    n:integer;
 
procedure QuickSort( L, R : Integer ); { Быстрая сортировка массива A[] }
var i,j,x,y : integer;
begin
  i := l; j := r;
  x := a[(l+r) div 2];
  repeat
    while (A[i]<x) do inc(i);
    while (x<A[j]) do dec(j);
    if ( i<=j ) then
    begin
      y:=A[i]; a[i]:=a[j]; a[j]:=y;
      inc(i); dec(j);
    end;
  until (i>j);
  if (l<j) then QuickSort(l,j);
  if (i<r) then QuickSort(i,r);
end;
 
begin
     writeln('введите 10 элементов массива:');
 for n:=1 to 10 do readln(a[n]);
 QuickSort( 1, 10 ); { на входе: левая и правая граница сортировки }
 writeln('после сортировки:');
     for n:=1 to 10 do writeln(a[n]);
end.

25. Решение системы 2-х уравнений с двумя неизвестными

{ ------------------------------------------------------------------------ }
{ решение уравнений вида                                                   }
{ |a1*x + b1*y = c1                                                        }
{ |a2*x + b2*y = c2                                                        }
{                                                                          }
{ метод решения:                                                           }
{      |c1 b1|           |a1 c1|                                           }
{      |c2 b2|           |a2 c2|                                           }
{ x = ---------     y = ---------                                          }
{      |a1 b1|           |a1 b1|                                           }
{      |a2 b2|           |a2 b2|                                           }
{                                                                          }
{ выражаем определители второго порядка:                                   }
{ x = (c1*b2-c2*b1)/(a1*b2-a2*b1)                                          }
{ y = (a1*c2-a2*c1)/(a1*b2-a2*b1)                                          }
{ ------------------------------------------------------------------------ }
var a1,a2,b1,b2,c1,c2,x,y,d,dx,dy:real;
begin
   writeln('введите коэффициенты уравнения: a1,b1,c1,a2,b2,c2');
   readln(a1,b1,c1,a2,b2,c2);
   d  := (a1*b2-a2*b1);
   dx := (c1*b2-c2*b1);
   dy := (a1*c2-a2*c1);
   if ( d=0 ) and ( (dx=0) or (dy=0) ) then
      writeln('бесконечное множество решений')
   else if ( d<>0 ) and ( (dx=0) or (dy=0) ) then
      writeln('нет решений')
   else begin
      x:=dx/d; y:=dy/d;
      writeln('x = ', x);  writeln('y = ', y);
 end;
end.

26. Решение системы 3-х уравнений с тремя неизвестными

{ ------------------------------------------------------------------------ }
{ решение уравнений вида:                                                  }
{ |a1*x + b1*y + c1*z = d1|                                                }
{ |a2*x + b2*y + c2*z = d2|                                                }
{ |a3*x + b3*y + c3*z = d3|                                                }
{                                                                          }
{ метод решения:                                                           }
{     |d1 b1 c1|       |a1 d1 c1|       |a1 b1 d1|                         }
{     |d2 b2 c2|       |a2 d2 c2|       |a2 b2 d2|                         }
{     |d3 b3 c3|       |a3 d3 c3|       |a3 b3 d3|                         }
{ x = ----------   y = ----------   z = ----------                         }
{     |a1 b1 c1|       |a1 b1 c1|       |a1 b1 c1|                         }
{     |a2 b2 c2|       |a2 b2 c2|       |a2 b2 c2|                         }
{     |a3 b3 c3|       |a3 b3 c3|       |a3 b3 c3|                         }
{                                                                          }
{ выражаем определители третьего порядка:                                  }
{ e  := (a1*b2*c3+b1*c2*a3+c1*a2*b3-a3*b2*c1-b3*c2*a1-c3*a2*b1);           }
{ ex := (d1*b2*c3+b1*c2*d3+c1*d2*b3-d3*b2*c1-b3*c2*d1-c3*d2*b1);           }
{ ey := (a1*d2*c3+d1*c2*a3+c1*a2*d3-a3*d2*c1-d3*c2*a1-c3*a2*d1);           }
{ ez := (a1*b2*d3+b1*d2*a3+d1*a2*b3-a3*b2*d1-b3*d2*a1-d3*a2*b1);           }
{ x = ex/e                                                                 }
{ y = ey/e                                                                 }
{ z = ez/e                                                                 }
{ ------------------------------------------------------------------------ }
var a1,a2,a3,b1,b2,b3,c1,c2,c3,d1,d2,d3,x,y,z,e,ex,ey,ez:real;
begin
 writeln('введите коэффициенты уравнения:a1,b1,c1,d1,a2,b2,c2,d2,a3,b3,c3,d3');
 readln(a1,b1,c1,d1,a2,b2,c2,d2,a3,b3,c3,d3);
 e  := (a1*b2*c3+b1*c2*a3+c1*a2*b3-a3*b2*c1-b3*c2*a1-c3*a2*b1);
 ex := (d1*b2*c3+b1*c2*d3+c1*d2*b3-d3*b2*c1-b3*c2*d1-c3*d2*b1);
 ey := (a1*d2*c3+d1*c2*a3+c1*a2*d3-a3*d2*c1-d3*c2*a1-c3*a2*d1);
 ez := (a1*b2*d3+b1*d2*a3+d1*a2*b3-a3*b2*d1-b3*d2*a1-d3*a2*b1);
 if ( e=0 ) and ( (ex=0) or (ey=0) or (ez=0) ) then
    writeln('бесконечное множество решений')
 else if ( e<>0 ) and ( (ex=0) or (ey=0) or (ez=0) ) then
    writeln('нет решений')
 else begin
    x:=ex/e; y:=ey/e; z:=ez/e;
    writeln('x = ', x); writeln('y = ', y); writeln('z = ', z);
 end;
end.

27. Геометрические алгоритмы

Пересекаются ли 2 отрезка?

{ ------------------------------------------------------------------------ }
{ Определяет пересечение отрезков A(ax1,ay1,ax2,ay2) и B (bx1,by1,bx2,by2),}
{ функция возвращает TRUE - если отрезки пересекаются, а если пересекаются }
{ в концах или вовсе не пересекаются, возвращается FALSE (ложь)            }
{ ------------------------------------------------------------------------ }
function Intersection(ax1,ay1,ax2,ay2,bx1,by1,bx2,by2:real):boolean;
var v1,v2,v3,v4:real;
begin
   v1:=(bx2-bx1)*(ay1-by1)-(by2-by1)*(ax1-bx1);
   v2:=(bx2-bx1)*(ay2-by1)-(by2-by1)*(ax2-bx1);
   v3:=(ax2-ax1)*(by1-ay1)-(ay2-ay1)*(bx1-ax1);
   v4:=(ax2-ax1)*(by2-ay1)-(ay2-ay1)*(bx2-ax1);
   Intersection:=(v1*v2<0) and (v3*v4<0);
end;
 
begin { основная программа, вызов функции - тест }
 writeln(Intersection(1,1,5,5,1,2,3,1)); {test1, yes Intersection}
   writeln(Intersection(1,1,5,5,1,2,1,3)); {test2, no  Intersection}
end.

Точка внутри сектора или нет?

{ ------------------------------------------------------------------------ }
{ Если точка внутри сектора (или на сторонах) - TRUE, если нет - FALSE     }
{ tx,ty - вершина сектора                                                  }
{ x1,y1,x2,y2 - точки на сторонах сектора                                  }
{ px,py - точка на плоскости                                               }
{                                                                          }
{ ------------------------------------------------------------------------ }
 
{возвращает знак числа, 1 - положительное число, -1 - отрицательное, 0 - 0 }
function sign(r:real):integer;
begin
     sign:=0; if r=0 then exit;
     if r<0 then sign:=-1 else sign:=1;
end;
 
function InsideSector(tx,ty,x1,y1,x2,y2,px,py:real):boolean;
var x,y,a1,a2,b1,b2,c1,c2:real;
var i1,i2,i3,i4:integer;
begin
  x:=(tx+x1+x2)/3; y:=(ty+y1+y2)/3;
  a1:=ty-y1; b1:=x1-tx; c1:=tx*y1-ty*x1;
  a2:=ty-y2; b2:=x2-tx; c2:=tx*y2-ty*x2;
  i1:=sign(a1*x+b1*y+c1); i2:=sign(a2*x+b2*y+b2);
  i3:=sign(a1*px+b1*py+c1); i4:=sign(a2*px+b2*py+c2);
  InsideSector:=((i1=i3) and (i2=i4)) or
                 ((i1=0) and (i2=i4)) or
                 ((i1=i3) and (i2=0));
end;
begin { основная программа, вызов функции - тест }
 writeln(InsideSector(1,1,5,1,1,5,3,3)); {test1, yes Inside}
   writeln(InsideSector(1,1,5,1,7,2,3,3)); {test2, no  Intersection}
end.

С какой стороны вектора лежит точка?

{ ------------------------------------------------------------------------ }
{ Если vector(a) и vector(b) - вектора a и b соответственно, то:           }
{                                                                          }
{ vector(a)*vector(b) = ax*by - ay*bx = a*b*sin(beta-alfa)                 }
{ ax,ay,bx,by - координаты концов векторов                                 }
{ a - длина вектора a                                                      }
{ b - длина вектора b                                                      }
{ alfa - угол альфа для вектора a                                          }
{ beta - угол бета для вектора b                                           }
{                                                                          }
{ Вывод: при общей начальной точке двух векторов их векторное произведение }
{        больше нуля, если второй вектор направлен влево от первого,       }
{        и меньше нуля, если вправо.                                       }
{                                                                          }
{ Если известны две точки, то вектор, основанный на них можно получить     }
{ вычитанием двух векторов направленных из начала координат:               }
{ Например, есть точка A и точка B                                         }
{ вектор|AB| = Вектор|B| - Вектор|A|, иным словом AB_x = Bx-Ax, AB_y= By-Ay}
{                                                                          }
{ Таким образом, получается:                                               }
{ Если есть вектор |AB|, заданный координатами ax,ay,bx,by и точка px,py,  }
{ то для того чтобы узнать лежит ли она слева или справа, надо узнать знак }
{ произведения:                                                            }
{ (bx-ax)*(py-ay)-(by-ay)*(px-ax)                                          }
{ ------------------------------------------------------------------------ }
 
var i:integer;
 
(* функция определеяет положение точки относительно вектора               *)
Function WherePoint(ax,ay,bx,by,px,py:real):integer;
var s :real;
begin
    s:=(bx-ax)*(py-ay)-(by-ay)*(px-ax);
    if s>0 then WherePoint:=1
    else if s<0 then WherePoint:=-1
    else WherePoint:=0;
end;
 
Begin (* Тело основной программы *)
   i:=WherePoint(1,1,8,8,2,5);
 if i > 0 then writeln('точка слева от вектора')
   else if i < 0 then writeln('точка справа от вектора')
   else writeln('на векторе, прямо по вектору или сзади вектора');
End.

С какой стороны вектора лежит точка? Вариант 1

{ ------------------------------------------------------------------------ }
{ Идея: обходим треугольник по часовой стрелке.                            }
{       Точка должна лежать справа от всех сторон, если она внутри         }
{ ------------------------------------------------------------------------ }
 
(* функция определеяет положение точки относительно вектора               *)
Function WherePoint(ax,ay,bx,by,px,py:real):integer;
var s :real;
begin
    s:=(bx-ax)*(py-ay)-(by-ay)*(px-ax);
    if s>0 then WherePoint:=1
    else if s<0 then WherePoint:=-1
 else WherePoint:=0;
end;
 
(* функция определеяет относительное положение точки: внутри или нет *)
Function PointInsideTreangle(ax,ay,bx,by,cx,cy,px,py:real):boolean;
var s1,s2,s3 :integer;
begin
    PointInsideTreangle:=FALSE;
    s1:=WherePoint(ax,ay,bx,by,px,py);
    s2:=WherePoint(bx,by,cx,cy,px,py);
    if s2*s1<=0 then EXIT;
    s3:=WherePoint(cx,cy,ax,ay,px,py);
    if s3*s2<=0 then EXIT;
    PointInsideTreangle:=TRUE;
end;
 
Begin (* Тело основной программы *)
   writeln(PointInsideTreangle(1,1,8,1,1,8,2,2)); {TEST1, Inside}
   writeln(PointInsideTreangle(1,1,8,1,1,8,6,6)); {TEST2, Outside}
End.

Точка внутри треугольника?  Вариант 2

{ ------------------------------------------------------------------------ }
{ Идея: Пусть есть треугольник ABC и точка P. Если Площадь ABC равна сумме }
{ площадей треугольников ABP,BCP,CAP, то точка внутри треугольника.        }
{ ------------------------------------------------------------------------ }
 
(* функция вычисляет расстояние между точками *)
Function Distance(ax,ay,bx,by:real):real;
begin
  Distance := sqrt(sqr(ax-bx)+sqr(ay-by));
end;
 
(* функция вычисляет площадь треугольника по формуле Герона *)
Function SqrGeron(ax,ay,bx,by,cx,cy:real):real;
var p,a,b,c :real;
Begin
  a:=Distance(cx,cy,bx,by);
  b:=Distance(ax,ay,cx,cy);
  c:=Distance(ax,ay,bx,by);
  p:=(a+b+c)/2;
  SqrGeron:=sqrt(p*(p-a)*(p-b)*(p-c));
End;
 
(* функция определеяет относительное положение точки: внутри или нет *)
Function PointInsideTreangle(ax,ay,bx,by,cx,cy,px,py:real):boolean;
const error = 1.000001;
var s,s1,s2,s3 :real;
begin
    PointInsideTreangle:=TRUE;
    s :=SqrGeron(ax,ay,bx,by,cx,cy);
    s1:=SqrGeron(ax,ay,bx,by,px,py);
    s2:=SqrGeron(bx,by,cx,cy,px,py);
    s3:=SqrGeron(cx,cy,ax,ay,px,py);
    if s*error>s1+s2+s3 then PointInsideTreangle:=TRUE
                        else PointInsideTreangle:=FALSE;
end;
 
Begin (* Тело основной программы *)
   writeln(PointInsideTreangle(1,1,8,1,1,8,2,2)); {TEST1, Inside}
   writeln(PointInsideTreangle(1,1,8,1,1,8,6,6)); {TEST2, Outside}
End.

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

Моделирование сложения двоичных чисел

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

Возведение целого числа в натуральную степень

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

var x,y:integer;
 
function Degree(a,b:integer):longint;
var r:longint;
begin
     r:=1;
     while b>0 do begin
        r:=r*a;
        b:=b-1;
     end;
     Degree:=r;
end;
 
begin
    writeln('введите число и (через пробел) степень числа');
 readln(x,y);
    writeln(Degree(x,y)); { print x^y }
end.

Вариант 2 (более быстрый и эффективный)

var x,y:integer;
 
function Degree(a,b:integer):longint;
var r:longint; c:integer;
begin
     r:=1; c:=a;
     while b>0 do begin
        if odd(b) then begin
                       r:=r*c;
                       dec(b);
                  end else begin
                       c:=c*c;
                       b:=b div 2;
                  end;
     end;
 Degree:=r;
end;
 
begin
    writeln('введите число и (через пробел) степень числа');
 readln(x,y);
    writeln(Degree(x,y)); { print x^y }
end.

Умножение длинных натуральных десятичных чисел

{ Введенное число помещается поразрядно в массив ROW.                      }
{ Могут умножаться числа до 10000 разрядов                                 }
{ ------------------------------------------------------------------------ }
{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
uses crt;
var {-------- use calc factorial ---------}
    row       : array[1..20000] of byte;
    col       : array[1..10000] of byte;
    nr,nc,dp  : integer;
    c         : char;
 
procedure PrintResult;
begin
     write('Р е з у л ь т а т = ');
     while (dp<=high(row)) do begin
        write(char(row[dp]+ord('0')));
        inc(dp);
     end;
     writeln;
end;
 

29. Умножение по Аль-Хорезми, в ROW - 1 число,в COL - 2 число

{Результат пишется в конец массива ROW                    }
procedure Multiplying;
var i,j,cr,cc:integer;
    carry,sum:longint;
begin
    dp:=high(row); cr:=nr; cc:=nc;
    carry := 0;
    while (cc>0) do begin
        i:=cr; j:=cc; sum:=carry;
        while (i<=nr) and (j>=1) do begin
           sum:=sum+row[i]*col[j];
           inc(i); dec(j);
        end;
        row[dp]:=sum mod 10; dec(dp);
        carry:=sum div 10;
        if cr>1 then dec(cr) else dec(cc);
    end;
    while (carry<>0) do begin
        row[dp]:=carry mod 10;
        carry:=carry div 10;
        dec(dp);
    end;
    inc(dp);
end;
 
begin
     {обнуление массивов-множителей}
     fillchar(row,sizeof(row),0); fillchar(col,sizeof(col),0);
 {поразрядный ввод 1-го числа}
     writeln('введите 1-е число число:');
 c:=#0;
     while NOT(c in ['0'..'9']) do c:=readkey;
     nr:=0;
     while (c in ['0'..'9']) do begin
        write(c);
        inc(nr); row[nr]:=ord(c)-ord('0');
        c:=readkey;
     end;
     writeln;
     {поразрядный ввод 2-го числа}
 writeln('введите 2-е число число:');
 while NOT(c in ['0'..'9']) do c:=readkey;
     nc:=0;
     while (c in ['0'..'9']) do begin
        write(c);
        inc(nc); col[nc]:=ord(c)-ord('0');
 c:=readkey;
     end;
     writeln;
     {вызов процедуры умножения, затем - вызов процедуры вывода результата}
     Multiplying; PrintResult;
end.

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

{--------------------------------------------------------------------------}
{ Алгоритм: каждый код символа увеличивается на некоторое число - "ключ"   }
{--------------------------------------------------------------------------}
 
var s:string;
    i,key:integer;
begin
     writeln('Введите текст'); readln(s);
 writeln('Введите ключ (число от 1 до 255)'); readln(key);
 for i:=1 to length(s) do s[i]:=char( ord(s[i]) + key  );
 writeln('Зашифрованный текст: ',s);
end.

31. Обработка текста

Подсчет количества слов в тексте

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

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

{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - список слов                                }
{--------------------------------------------------------------------------}
const Alpha : set of char=['A'..'Z','А'..'П','Р'..'Я','a'..'z','а'..'п','р'..'я'];
var s,t:string;
    i:integer;
begin
     writeln('Введите текст'); readln(s);
 writeln('Список слов в тексте:');
 i:=1;
     Repeat
        while NOT(s[i] in Alpha) and (i<=length(s)) do inc(i);
        t:='';
        while (s[i] in Alpha) and (i<=length(s)) do begin
              t:=t+s[i];
              inc(i);
        end;
        if length(t)<>0 then writeln(t);
     Until (i>length(s));
end.

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

{--------------------------------------------------------------------------}
{ На входе - текст, на выходе - список чисел                               }
{--------------------------------------------------------------------------}
const Digits : set of char=['0'..'9'];
var s,d:string;
    i:integer;
begin
     writeln('Введите текст, в котором есть и цифры:'); readln(s);
     writeln('Список чисел в тексте:');
 i:=1;
     Repeat
        while NOT(s[i] in Digits) and (i<=length(s)) do inc(i);
        d:='';
        while (s[i] in Digits) and (i<=length(s)) do begin
              d:=d+s[i];
              inc(i);
        end;
        if length(d)<>0 then writeln(d);
     Until (i>length(s));
end.

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

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

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

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

33. Бэк-трекинг

Обход шахматной доски конем

Маршрут см. в файле 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.