LVP (15 января 2012 - 16:55) писал:
Я человек 20 удалил, но они опять зарегались.
37 публикаций создано Санек (учитываются публикации только с 25-сентября 23)
Отправлено от Санек в 14 ноября 2012 - 17:29 in Структуры данных
Отправлено от Санек в 21 декабря 2011 - 17:52 in Сортировка и перебор
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.
Отправлено от Санек в 22 декабря 2011 - 08:27 in Комбинаторика
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.
Отправлено от Санек в 21 декабря 2011 - 18:18 in Графы
Грядки
Прямоугольный садовый участок шириной 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.
Отправлено от Санек в 16 ноября 2012 - 16:16 in Структуры данных
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;
Отправлено от Санек в 25 декабря 2011 - 18:56 in Строки
Типы данных char и string
char - символьный тип
string - строковый тип
Символьный тип
Значением переменных символьного типа char является один символ. Каждому символу соответствует код символа - целое число в диапазоне от 0 до 255. Значит, символьный тип является порядковым. В таких языках программирования как C, Java тип char относят к целым типам, что разумно, т.к. в памяти компьютера нет символов - есть только их числовые коды. Значит, все действия по обработке символов сводятся к действиям над целыми числами, расположенными строго по порядку.
Над данными символьного типа определены операции отношения: =, <>, <, >, <=, >=.
Для данных символьного типа определены стандартные функции:
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.
Отправлено от Санек в 23 декабря 2011 - 14:14 in Рекурсия
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.
Отправлено от Санек в 24 сентября 2012 - 12:15 in Флудилка
Отправлено от Санек в 17 января 2012 - 18:53 in Комбинаторика
Отправлено от Санек в 22 декабря 2011 - 10:24 in Одномерные массивы
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.
Отправлено от Санек в 21 декабря 2011 - 18:08 in Комбинаторика
Перестановка из 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.
Отправлено от Санек в 23 декабря 2011 - 19:18 in Динамическое программирование
var f:array [1..70] of int64; i,n:longint; begin readln(n); //считываем число ступенек f[1]:=1; //если у нас 1 ступенька, то кол-во способов 1, т.к. есть один способ сигануть с вершины лесенки до основания, если всего одна ступенька (проверьте сами) f[2]:=2; //если у нас 2 ступеньки, то кол-во способов 2, т.к. есть два способа сигануть с вершины лесенки до основания, если всего две ступеньки (проверьте сами) f[3]:=4; //если у нас 3 ступеньки, то кол-во способов 4, т.к. есть четыре способа сигануть с вершины лесенки до основания, если всего три ступеньки (проверьте сами) for i:=4 to n do f[i]:=f[i-2]+f[i-1]+f[i-3]; //А дальше динамика. В массив ответов заносим сумму вариантов "сигания" с i-1, i-2, i-3 ступенек. writeln(f[n]); //ответ на задачу end.
Отправлено от Санек в 20 ноября 2012 - 17:49 in Графы
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;
Отправлено от Санек в 22 декабря 2011 - 16:16 in Геометрия
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.
Отправлено от Санек в 22 декабря 2011 - 09:06 in Целочисленная арифметика
function pr(x:longint):boolean; var d:longint; begin if x mod 2 =0 then pr:=(x=2) else begin d:=3; while (d*d<=x)and(x mod d <>0) do d:=d+2; pr:=(d*d>x)and(x<>1); end; end;
Задача
Вывести все простые числа от M до N включительно.
Ограничения: 2 <= M <= N <= 300 000.
Ввод: В первой строке находятся разделённые пробелом M и N.
Вывод: Вывести числа в порядке возрастания, по одному в строке. Если между M и N включительно нет простых - вывести "Absent".
Примеры
Ввод 1
2 5
Вывод 1
2
3
5
var n,m,i,f:LONGINT; function pr(x:longint):boolean; var d:longint; begin if x mod 2 =0 then pr:=(x=2) else begin d:=3; while (d*d<=x)and(x mod d <>0) do d:=d+2; pr:=(d*d>x)and(x<>1); end; end; begin f:=0; readln(n,m); for i:=n to m do if pr(i) then begin writeln(i); f:=1; end; if f=0 then writeln('Absent'); end.
Отправлено от Санек в 22 декабря 2011 - 08:59 in Целочисленная арифметика
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.
Отправлено от Санек в 21 декабря 2011 - 18:22 in Графы
Алгоритм Флойда
Полный ориентированный взвешенный граф задан матрицей смежности. Постройте матрицу кратчайших путей между его вершинами. Гарантируется, что в графе нет циклов отрицательного веса.
Входные данные
В первой строке входного файла 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.
Отправлено от Санек в 22 декабря 2011 - 09:13 in Сортировка и перебор
var a:array[1..10000] of integer; i,j,x,n:integer; begin readln(n); writeln('введите ',n,' элементов массива'); for i:=1 to n do read( a[i] ); for i:=1 to n-1 do for j:=1 to n-i do if a[j]>a[j+1] then begin x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x; end; writeln('после сортировки:'); for i:=1 to n do write( a[i],' ' ); end.
Отправлено от Санек в 22 декабря 2011 - 09:14 in Сортировка
var a:array[1..10000] of integer; i,j,x,n:integer; begin readln(n); writeln('введите ',n,' элементов массива'); for i:=1 to n do read( a[i] ); for i:=1 to n-1 do for j:=1 to n-i do if a[j]>a[j+1] then begin x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x; end; writeln('после сортировки:'); for i:=1 to n do write( a[i],' ' ); end.
Отправлено от Санек в 23 декабря 2011 - 14:29 in Геометрия
var xc,yc,mx,my,d,r:real; begin readln( mx,my,xc,yc,r ); //mx,my - координаты точки M, xc,yc,r - координаты круга и его радиус d:=sqrt(sqr(xc-mx)+sqr(yc-my)); if d<=r then writeln ('точка M лежит в круге') else writeln ('точка M лежит вне круга'); end.
Отправлено от Санек в 22 декабря 2011 - 12:41 in Комбинаторика
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.
Отправлено от Санек в 22 декабря 2011 - 09:16 in Сортировка и перебор
Задана матрица A размера NxM. Вам необходимо отсортировать числа в каждой строке матрицы в порядке возрастания.
Формат ввода:
В первой строке находятся числа N и M. Далее следует описание самой матрицы - N строк по M чисел в каждой.
Ограничения:
1 <= N, M <= 100
-100 <= A[i,j] <= 100
Формат вывода:
Ответ на задачу - исходная матрица, каждая строка которой отсортирована по возрастанию.
Пример ввода:
3 4
1 2 3 4
4 3 2 1
4 1 3 2
Пример вывода:
1 2 3 4
1 2 3 4
1 2 3 4
Здесь применяется метод быстрой сортировки
var a:array [1..1000] of longint; n,m,i,j:longint; procedure qsort(l,r:longint); var i,j,x,p:longint; begin i:=l; j:=r; x:=a[(i+j)div 2]; repeat while a[i]<x do i:=i+1; while a[j]>x do j:=j-1; if i<=j then begin p:=a[i]; a[i]:=a[j]; a[j]:=p; i:=i+1; j:=j-1; end; until i>j; if i<r then qsort(i,r); if j>l then qsort(l,j); end; begin readln(n,m); for i:=1 to n do begin for j:=1 to m do read(a[j]); qsort(1,m); for j:=1 to m do write(a[j],' '); writeln; end; end.
Отправлено от Санек в 23 декабря 2011 - 19:10 in Динамическое программирование
var a,f:array [1..10000]of longint; n,i,max,j:longint; begin readln(n); //читаем кол-во чисел for i:=1 to n do read(a[i]); //считываем последовательность for i:=1 to n do f[i]:=1; //забиваем массив ответов 1 for i:=1 to n do for j:=1 to i-1 do if (a[i]>a[j]) and (f[j]+1>f[i]) then f[i]:=f[j]+1; //ищем длину возрастающей последовательности на каждом шаге последовательности for i:=1 to n do if f[i]>max then max:=f[i]; //находим максимальную подпоследовательность в массиве ответов writeln(max); end.