Язык программирования Паскаль Тема ПРАКТИКА

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

 

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Домино

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

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

 

 

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.

Скачано с www.znanio.ru