Я. Илья (15 января 2012 - 12:14) писал:

 LVP (15 января 2012 - 16:55) писал:

Andrew (14 ноября 2012 - 15:42) писал:

var a:array [1..1000000] of longint;
    i,n:longint;
procedure qSort(l,r:longint);
  var i,j,z,x:longint;
begin
   i:=l;
   j:=r;
   x:=a[(i+j)div 2];{находим  средний элемент}
   repeat
	while a[i]<x do i:=i+1;{ищем слева элемент который >=x }
	while a[j]>x do j:=j-1;{а справа элемент который <=x }
	if i<=j then begin
                        z:=a[i];
                        a[i]:=a[j];
                        a[j]:=z;
                        i:=i+1;
                        j:=j-1;
                      end; {меняем местами элементы a[i] и a[j] и изменяем индикаторы i и j}
   until (i>j);
   if i<r then qSort(i,r);
   if j>l then qSort(l,j);
end;
begin        
readln(n);
for i:=1 to n do
  read(a[i]);
qSort(1,n); {задаём границы сортировки}
for i:=1 to n do
  write(a[i],' ');
end.

type mas= array [0..1000] of byte;
var p,q:mas;
	n,m,i,j,s,k,d:longint;
	b:array [1..1000] of char;
begin
   readln(n,m);
   for i:=1 to n do read(b[i]);
   s:=0;
   for i:=0 to m do p[i]:=i; //Часть 1
  REPEAT
 
//Часть 2
for i:=0 to m do q[i]:=p[i];
while q[0]=0 do
	Begin
  	while q[0]=0 do
	begin
	for i:=1 to m do write(b[q[i]]);
  	writeln;
  	inc(s);
	j:=m;
  	while q[j-1]>q[j] do dec(j);
    
	k:=m;
  	while q[j-1]>q[k] do dec(k);
	d:=q[j-1];
	q[j-1]:=q[k];
	q[k]:=d;
	for i:=j to (m+j-1)div 2 do
  	begin
   	d:=q[m+j-i];
   	q[m+j-i]:=q[i];
   	q[i]:=d;
  	end;
	end;
	end;
 
//Часть 3
 
  j:=m;
while (j>0) and(p[j]=j+n-m) do dec(j);
  if j>0 then begin
            	p[j]:=p[j]+1;
            	for i:=j+1 to m do p[i]:=p[i-1]+1;
   			end;
  
  
UNTIL j=0;
writeln(s);
end.

type mas= array [0..1000] of byte;
var p:mas;
 	n,m,i,j,s:longint;
 	b:array [1..1000] of char;
  procedure perestan(q:mas);
   var i,j,k,d:longint;
 
begin
   while q[0]=0 do
	begin
 	for i:=1 to m do write(b[q[i]],' ');
  	writeln;
  	inc(s);
 	j:=m;
  	while q[j-1]>q[j] do dec(j);
    
 	k:=m;
  	while q[j-1]>q[k] do dec(k);
 	d:=q[j-1];
 	q[j-1]:=q[k];
 	q[k]:=d;
 	for i:=j to (m+j-1)div 2 do
  	begin
   	d:=q[m+j-i];
   	q[m+j-i]:=q[i];
   	q[i]:=d;
  	end;
	end;
end;

begin
   readln(n,m);

   for i:=1 to n do read(b[i]);
   for i:=0 to m do p[i]:=i;

  REPEAT
   perestan(p);
   j:=m;
	while (j>0) and(p[j]=j+n-m) do dec(j);
   if j>0 then begin
            	p[j]:=p[j]+1;
            	for i:=j+1 to m do p[i]:=p[i-1]+1;
           	end;
until j=0;

writeln(s);

end.

 
procedure shift_up(pos:longint);
begin
  while (pos<>1) and (a[pos div 2] < a[pos]) do //пока не дошли до предка и потомок больше предка
    begin
      x:=a[pos div 2]; //меняем их местами
      a[pos div 2]:=a[pos];
      a[pos]:=x;
      pos:=pos div 2; //теперь мы в предке вершины pos
    end;
end;

 
procedure shift_up(pos:longint);
var x:longint;
begin
  if pos=1 then exit; //если мы в самом вверху, то вылетаем
  if a[pos div 2] < a[pos] //если потомок больше предка
    then //то меняем их местами
      begin 
        x:=a[pos div 2];
        a[pos div 2]:=a[pos];
        a[pos]:=x;
        shift_up(pos div 2); //подымаем предка наверх
      end;
end;

 
procedure shift_down(pos:longint);
var pos2,x:longint;
begin
  while (2*pos<=n) do //пока мы не пришли в последний элемент
    begin
      pos2:=pos; 
      if (a[2*pos]>a[pos2]) //если левый потомок больше предка
        then pos2:=2*pos; //номеру предка присваем номер потомка
      if (2*pos+1<=n) and (a[2*pos+1]>a[pos2]) //если правый потомок есть и он больше предка
        then pos2:=2*pos+1; //номеру предка присваем номер потомка
      if (pos=pos2) then break; //если предок это потомок тогда вылетаем
      x:=a[pos]; //меняем местами предка и потомка
      a[pos]:=a[pos2];
      a[pos2]:=x;
      pos:=pos2; //номеру потомка присваем номер предка
    end;
end;

 
procedure shift_down(pos:longint);
var pos2:longint;
begin
  pos2:=pos; 
  if pos*2>n  then exit; //если пришли в последний элемент то вылетаем
  if a[pos*2]>a[pos2] //если левый потомок больше предка
    then pos2:=pos*2; //номеру предка присваем номер потомка
  if (pos*2+1<=n) and (a[pos*2+1]>a[pos2]) //если правый потомок есть и он больше предка 
    then pos2:=pos*2+1; //номеру предка присваем номер потомка
  if pos=pos2 then exit; //если предок это потомок тогда вылетаем
  x:=a[pos]; //меняем местами предка и потомка
  a[pos]:=a[pos2];
  a[pos2]:=x;
  shift_down(pos2);//топим потомка
end;

Грядки

Прямоугольный садовый участок шириной N и длиной M метров разбит на квадраты со стороной 1 метр. На этом участке вскопаны грядки. Грядкой называется совокупность квадратов, удовлетворяющая таким условиям:
из любого квадрата этой грядки можно попасть в любой другой квадрат этой же грядки, последовательно переходя по грядке из квадрата в квадрат через их общую сторону;
никакие две грядки не пересекаются и не касаются друг друга ни по вертикальной, ни по горизонтальной сторонам квадратов (касание грядок углами квадратов допускается).
Подсчитайте количество грядок на садовом участке.

Входные данные

В первой строке входного файла INPUT.TXT находятся числа N и M через пробел, далее идут N строк по M символов. Символ # обозначает территорию грядки, точка соответствует незанятой территории. Других символов в исходном файле нет. (1 <= N, M <= 200)

Выходные данные

В выходной файл OUTPUT.TXT выведите количество грядок на садовом участке.

Примеры

INPUT.TXT

5 10

##......#.

.#..#...#.

.###....#.

..##....#.

........#.

OUTPUT.TXT

3

Основной код

var g:array [1..200,1..200] of char; k,i,j,n,m:integer;
procedure dfs(x,y:longint);
begin
g[x,y]:='o';
if (y<m )and(g[x,y+1]='#') then dfs(x,y+1);
if (y>1 )and(g[x,y-1]='#') then dfs(x,y-1);
if (x<n )and(g[x+1,y]='#') then dfs(x+1,y);
if (x>1 )and(g[x-1,y]='#') then dfs(x-1,y);
end;
begin
readln(n,m);
k:=0;
for i:=1 to n do begin
   				for j:=1 to m do
   				read(g[i,j]);
  readln;
end;
for i:=1 to n do
  for j:=1 to m do begin
                	if (g[i,j]='#')
 					then begin
       					k:=k+1;
       					dfs(i,j);
                      	end;
                	end;
writeln(k);
end.

Типы данных char и string

char - символьный тип

string - строковый тип

Символьный тип

Значением переменных символьного типа char является один символ. Каждому символу соответствует код символа - целое число в диапазоне от 0 до 255. Значит, символьный тип является порядковым. В таких языках программирования как C, Java тип char относят к целым типам, что разумно, т.к. в памяти компьютера нет символов - есть только их числовые коды. Значит, все действия по обработке символов сводятся к действиям над целыми числами, расположенными строго по порядку.

Над данными символьного типа определены операции отношения: =, <>, <, >, <=, >=.

Для данных символьного типа определены стандартные функции:

• chr(x) - возвращает значение символа его коду;
  
• ord(ch) - возвращает код заданного символа ch;
  
• pred(ch) - возвращает предыдущий символ;
  
• succ(ch) - возвращает следующий символ;
  
• upcase(ch) - преобразует строчную букву в заглавную.

• ord('A') = 65
  
• chr(128) = 'Б'
  
• pred('Б') = 'А'
  
• succ('Г') = 'Д'
  
• upcase('n') = 'N'

var s:string;
	i:longint;
begin
readln(s);
for i:=length(s) downto 1 do
  write(s[i]);
writeln;
for i:=1 to length(s) do
  if (s[i]=' ') and (s[i+1]<>' ') then writeln
   else write(s[i]);
end.

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 a:array [1..1000] of longint;
	n,i,s:longint;
begin
readln(n);  //ввод n - числа элементов в массиве
for i:=1 to n do //ввод чисел массива
  read(a[i]);
for i:=1 to n do //подсчет суммы всех элементов
  s:=s+a[i];
writeln(s); //вывод суммы
end.

Перестановка из n элементов - это соединения из n различных элементов, взятых в определенном порядке.

var b:string; p:array [0..255] of integer; c,n,i,j,r,q,d,k:longint;
  begin
   readln(B)/>; 
    n:=length(B)/>;
    
    for i:=0 to n do p[i]:=i;
    
    while p[0]=0 do
     Begin
 
       for i:=1 to n do write(b[p[i]]);
         writeln;
       
       j:=n;
        while p[j-1]>p[j] do j:=j-1;
       
       k:=n;
        while p[j-1]>p[k] do k:=k-1;
       
       d:=p[k];
       p[k]:=p[j-1];
       p[j-1]:=d;
       
       for i:=j to (n+j-1)div 2 do 
        begin
        d:=p[i];
        p[i]:=p[n-i+j];
        p[n-i+j]:=d;
        end;
    end;
 end.

Число называется совершенным, если оно равно сумме всех своих делителей, меньших его самого. Требуется найти все совершенные числа от n до m (1 <= n,m <=100000)


Ввод

Два числа n и m

Вывод

В каждой строке вывести совершенные числа на промежутке от n до m. Если таких нет, вывести Absent.

Пример
______
6 6

6
______
4 5

Absent
______

Решение

Циклом бежим от n до m и находим сумму делителей числа i. Если сумма равна i, тогда выводим число i.

var n,m,i:int64;
    f:boolean;
function pr(x:int64):boolean;
var d,s:int64;
begin
  s:=1;
  if(x=1)then begin pr:=false; exit; end;
  d:=2;
  while int64(d)*d<x do
    begin
      if(x mod d=0)then s:=s+d+(x div d);
      d:=d+1;
    end;
  if d*d=x then s:=s+d;
  pr:=(s=x); //if s=x then pr:=true else pr:=false;
end;
begin
  assign(input,'input.txt'); reset(input);
    assign(output,'output.txt'); rewrite(output);
  readln(n,m);
  f:=false;
  for i:=n to m do
    if(pr(i))then begin writeln(i); f:=true; end;
  if not(f) then writeln('Absent');
end.

• Сортируем вершины топологически.
  
• Инвертируем граф (т.е. меняем направления ребер, например если было ребро из 2 в 3 вершину, то делаем из 3 во 2)
  
• Пробегаемся по отсортированному массиву и если находим не помеченную вершину, то увеличиваем счетчик кол-во к.с.с. и пускаем dfs2 от этой вершины

 
procedure dfs(v:longint);
var i:longint;
begin
  used[v]:=true;//помечаем вершину
  for i:=1 to n do //перебираем все вершины
    if not(used[i]) and (g[v,i]=1) then dfs(i); //если вершина не помеченна и есть путь из нашей вершину в нее, то запускаем глубину от этой вершины
  cnt:=cnt+1;//кол-во вершин тоположке
  dag[cnt]:=v; //кидаем нашу вершину в топологически отсортированный массив
end;

 
for i:=1 to n do
    for j:=1 to n do
      if (g[i,j]=1) then g1[j,i]:=1; //здесь думаю все понятно

 
scc:=0;
  for i:=cnt downto 1 do
    if not(used[dag[i]]) //если вершина не помеченна
      then
        begin
          scc:=scc+1; //на 1 увеличиваем кол-во к.с.с.
          dfs2(dag[i]); //пускаем dfs2 от нашей вершины
        end;
  writeln(scc);

 
procedure dfs2(v:longint);
var i:longint;
begin
  used[v]:=true; //помечаем вершину
  for i:=1 to n do//перебираем все вершины
    if not(used[i]) and (g1[v,i]=1) then dfs2(i);//если вершина не помеченна и есть путь из нашей вершину в нее, то запускаем глубину от этой вершины
end;

for i:=1 to n do
  if not(used[i]) then dfs(i);

 
procedure dfs(v:longint);
var i:longint;
begin
  used[v]:=false; //помечаем вершину, типа мы здесь были
  for i:=1 to n do
    if (not(used[i])) and (g[v,i]=1) //если мы не были в этой вершине и есть путь из вершины v в нашу
      then
        begin
          parent[i]:=v; //предком для нашей вершины является вершина v, т.е. мы пришли из неё
          dfs(i); //глубиной идем от нашей вершины
        end;
  inc(cnt); //увеличиваем счетчик
  dag[cnt]:=v; //в массив тоположки кидаем нашу вершину v
end;

for i:=cnt downto 1 do
  write(dag[i],' ');

var p:array [0..1000] of integer;
	b:array [0..1000] of char;
	i,j,m,n,s:longint;
   begin
  
	readln(n,m);
	for i:=0 to n-1 do read(b[i]);
  
	for i:=0 to m do p[i]:=0;
  
   while p[0]=0 do
	begin
    
	j:=m;
	while p[j]=n-1 do begin
           			p[j]:=0;
           			j:=j-1;
           			end;
	p[j]:=p[j]+1;
    
	for i:=1 to m do write(b[p[i]]);
	s:=s+1;
	writeln;
    
	end;
	writeln(s);
   end.

Алгоритм Флойда

Полный ориентированный взвешенный граф задан матрицей смежности. Постройте матрицу кратчайших путей между его вершинами. Гарантируется, что в графе нет циклов отрицательного веса.

Входные данные

В первой строке входного файла INPUT.TXT записано единственное число N (1 <= N <= 100) - количество вершин графа. В следующих N строках по N чисел - матрица смежности графа (j-ое число в i-ой строке соответствует весу ребра из вершины i в вершину j). Все числа по модулю не превышают 100. На главной диагонали матрицы - всегда нули.

Выходные данные

В выходной файл OUTPUT.TXT выведите N строк по N чисел - матрицу кратчайших расстояний между парами вершин. j-ое число в i-ой строке должно быть равно весу кратчайшего пути из вершины i в вершину j.

Пример

INPUT.TXT

4

0 5 9 100

100 0 2 8

100 100 0 7

4 100 100 0

OUTPUT.TXT

0 5 7 13

12 0 2 8

11 16 0 7

4 9 11 0

var g:array [1..100,1..100] of longint; n,j,i,k:longint;
function min(x,y:longint):longint;
begin
if x<y then min:=x
		else min:=y;
end;        
begin
//Считываем граф
readln(n);
for i:=1 to n do
  for j:=1 to n do read(g[i,j]);
//Вот это - алгоритм Флойда, т.е простейший для реализации способ нахождения кратчайших расстояний от каждой вершины к каждой
for k:=1 to n do
	for i:=1 to n do
        for j:=1 to n do
   		G[i,j]:=min(G[i,j],G[i,k]+G[k,j]);
//Вывод полученного графа
for i:=1 to n do
  begin  
    for j:=1 to n do
      write(g[i,j],' ');
    writeln;
   end;  
end.  

Задача Кратчайший маршрут

var g:array[1..1000,1..1000] of longint; p,q:array [1..1000] of longint;  i,uk,un,n,m,a,b,v:longint;
begin
 readln(n,m);
 for i:=1 to m do
  begin
   readln(a,B)/>;
   g[a,b]:=g[a,b]+1;
   g[b,a]:=g[b,a]+1;     
  end;
 for i:=1 to n do
  begin
   p[i]:=-1;
   g[i,i]:=0;
  end;
 un:=1;
 uk:=2;
 p[1]:=0;
 q[1]:=1;
 while uk<>un do
  begin
   v:=q[un];
   un:=un+1;
   for i:=1 to n do
    if (g[v,i]>0)and(p[i]=-1) then begin
                                    q[uk]:=i;
                                    uk:=uk+1;
                                    p[i]:=p[v]+1;
                                   end;
  end;
 writeln(p[n]);
end.

Задача №1
Вводятся a,b,c. Найти угол наклона прямой к оси Ox.

Думаю вы знаете что число pi(дальше буду обозначать его так как в паскале) это 180 градусов. Т.е. 3,14 = 180 градусам. Тогда угол наклона прямой к оси Ox можно найти по формуле (угол наклона прямой к оси Ox обозначим u):

u=arctg(-a/ b *180(градусов)/pi

var a,b,u:real;
begin
readln(a,B)/>;
if b=0 then u:=90
          else u=arctg(-a/B)/>*180/pi;
writeln(u);
end.

var b:array[2..100000] of boolean;
i,j,n:longint;
begin
readln(n);
for i:=2 to n do b[i]:= true;
i:=2;
while i*i<= n do begin
if b[i]= true then begin
       			j:=i*i;
       			while j<=n do begin
                     			b[j]:=false;
                     			j:=j+i;
                     			end;
       			end;
if i=2 then i:=3 else i:=i+2;
end;
for i:=2 to n do
if b[i] then write(i,' ');
end.

var b:string; p,kp:array [0..255] of integer; n,i,j,d,k,l,s:longint;
  begin
   readln(B)/>;
	n:=length(B)/>;
	for i:=1 to n do read(kp[i]);
  
	p[0]:=0;
	for i:=1 to n do
	for j:=1 to kp[i] do
   	begin
    	l:=l+1;
    	p[l]:=i;
   	end;
  
   n:=l;
	while p[0]=0 do
	Begin
   	for i:=1 to n do write(b[p[i]]);
		writeln;
		s:=s+1;
      
   	j:=n;
    	while p[j-1]>=p[j] do j:=j-1;
      
   	k:=n;
    	while p[j-1]>=p[k] do k:=k-1;
      
   	d:=p[k];
   	p[k]:=p[j-1];
   	p[j-1]:=d;
      
   	for i:=j to (n+j-1)div 2 do
    	begin
    	d:=p[i];
    	p[i]:=p[n-i+j];
    	p[n-i+j]:=d;
    	end;
	end;
	writeln(s);
end.

var p: array [0..1000] of byte;
	n,m,i,j,s:longint;
	b:array [1..1000] of char;
 
begin
   readln(n,m);
 
   for i:=1 to n do read(b[i]);
   for i:=0 to m do p[i]:=i;
 
  REPEAT
  
   for i:=1 to m do write(b[p[i]]);
	writeln;
   s:=s+1;
    
   j:=m;
	while (j>0) and(p[j]=j+n-m) do dec(j);
   if j>0 then begin
            	p[j]:=p[j]+1;
            	for i:=j+1 to m do p[i]:=p[i-1]+1;
       		end;
UNTIL j=0;
 
writeln(s);
 
end.

type mas= array [0..1000] of byte;
var p,q:mas;
	n,m,i,j,s,k,d:longint;
	b:array [1..1000] of char;
begin
   readln(n,m);
   for i:=1 to n do read(b[i]);
   s:=0;
   for i:=0 to m do p[i]:=i; //Часть 1
  REPEAT
 
//Часть 2
for i:=0 to m do q[i]:=p[i];
while q[0]=0 do
	Begin
  	while q[0]=0 do
	begin
	for i:=1 to m do write(b[q[i]]);
  	writeln;
  	inc(s);
	j:=m;
  	while q[j-1]>q[j] do dec(j);
    
	k:=m;
  	while q[j-1]>q[k] do dec(k);
	d:=q[j-1];
	q[j-1]:=q[k];
	q[k]:=d;
	for i:=j to (m+j-1)div 2 do
  	begin
   	d:=q[m+j-i];
   	q[m+j-i]:=q[i];
   	q[i]:=d;
  	end;
	end;
	end;
 
//Часть 3
 
  j:=m;
while (j>0) and(p[j]=j+n-m) do dec(j);
  if j>0 then begin
            	p[j]:=p[j]+1;
            	for i:=j+1 to m do p[i]:=p[i-1]+1;
   			end;
  
  
UNTIL j=0;
writeln(s);
end.

type mas= array [0..1000] of byte;
var p:mas;
	n,m,i,j,s:longint;
	b:array [1..1000] of char;
  procedure perestan(q:mas);
   var i,j,k,d:longint;
 
begin
   while q[0]=0 do
	begin
	for i:=1 to m do write(b[q[i]],' ');
  	writeln;
  	inc(s);
	j:=m;
  	while q[j-1]>q[j] do dec(j);
    
	k:=m;
  	while q[j-1]>q[k] do dec(k);
	d:=q[j-1];
	q[j-1]:=q[k];
	q[k]:=d;
	for i:=j to (m+j-1)div 2 do
  	begin
   	d:=q[m+j-i];
   	q[m+j-i]:=q[i];
   	q[i]:=d;
  	end;
	end;
end;
 
begin
   readln(n,m);
 
   for i:=1 to n do read(b[i]);
   for i:=0 to m do p[i]:=i;
 
  REPEAT
   perestan(p);
   j:=m;
	while (j>0) and(p[j]=j+n-m) do dec(j);
   if j>0 then begin
            	p[j]:=p[j]+1;
            	for i:=j+1 to m do p[i]:=p[i-1]+1;
       		end;
until j=0;
 
writeln(s);
 
end.

var x1,x2,x0,y1,y2,y0,s1,s2,s3,a,b,c,p,h:real;
begin
//1 Вариант. Косое произведение векторов
readln(x1,y1,x2,y2,x0,y0);
s1:=abs((x2-x1)*(y0-y1)-(y2-y1)*(x0-x1))/2;
writeln(s1:0:15);
//2 Вариант. По формуле Герона
a:=sqrt((x1-x0)*(x1-x0)+(y1-y0)*(y1-y0));
  b:=sqrt((x2-x0)*(x2-x0)+(y2-y0)*(y2-y0));
   c:=sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1));
p:=(a+b+c)/2;
s2:=sqrt(p*(p-a)*(p-B)/>*(p-c));
writeln(s2:0:15);
//3 Вариант. Произведение высоту на сторону, к которой она проведена
h:=abs((y2-y1)*x0+(x1-x2)*y0+(y1*x2-x1*y2))/sqrt(a*a+b*B)/>;
s3:=h*c/2;
writeln(s3:0:15 );
end.