Хостинг Портала RusFAQ.ru:
MosHoster.ru - Профессиональный хостинг на Windows 2008

РАССЫЛКИ ПОРТАЛА RUSFAQ.RU

Чемпионы рейтинга экспертов в этой рассылке

Николай // Programmator Статус: Студент Рейтинг: 146 ∙ повысить рейтинг >>

Micren Статус: Студент Рейтинг: 142 ∙ повысить рейтинг >>

Пупорев Юрий Борисович Статус: Специалист Рейтинг: 140 ∙ повысить рейтинг >>

/ КОМПЬЮТЕРЫ И ПО / Языки программирования / Pascal

Выпуск № 790
от 22.01.2009, 19:35

Вопрос № 157891: Не могу решить задачу в Паскале В множестве точек на плоскости найти пару точек с максимальным расстоянием между ними, для проверки нарисовать рисунок(в Паскале) ...

Вопрос № 157.891

Не могу решить задачу в Паскале В множестве точек на плоскости найти пару точек с максимальным расстоянием между ними, для проверки нарисовать рисунок(в Паскале)

Отправлен: 16.01.2009, 19:40 Вопрос задала: Mariyavo (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Mariyavo! Программа в приложении. Успешной сдачи! Приложение: uses crt,graph; {подключаем модули для работы с экранм и графикой} type Tpoint=record {тип точка} ind:byte; {номер точки} x,y:integer; {координаты} end; const n=20; {количество точек} function Rast(a,b:Tpoint):integer; {функция определяет расстояние по координатам} begin Rast:=trunc(sqrt(sqr(a.x-b.x)+sqr(a.y-b.y))); end; var mt:array[1..n] of Tpoint; {массив точек} i,j,max,imax,jmax,gd,gm:integer; s:string[3]; begin clrscr; randomize; writeln('Massiv tochek:'); writeln('Ind X Y'); writeln('---------------'); for i:=1 to n do begin mt[i].ind:=i; mt[i].x:=random(60)-30; {интервал из расчета, что умноженные на 10 войдут на экран и более-менее равномерно на нем расположатся} mt[i].y:=random(40)-20; writeln(mt[i].ind:3,mt[i].x:6,mt[i].y:6); end; max:=0;imax:=1;jmax:=1; for i:=1 to n-1 do for j:=i+1 to n do if Rast(mt[i],mt[j])>max then begin max:=Rast(mt[i],mt[j]);{максимальное расстояние} imax:=i; {номер первой точки} jmax:=j; {второй} end; write('Max rasst=',max,' mezdu tochkami '); write(imax,'(',mt[imax].x,',',mt[imax].y,') '); write(jmax,'(',mt[jmax].x,',',mt[imax].y,')'); readln; gd:=detect; {переходим в графический режим} Initgraph(gd,gm,''); for i:=1 to n do begin str(i,s); {переводим в строку номер точки} PutPixel(GetmaxX div 2+10*mt[i].x,GetmaxY div 2+10*mt[i].y,15); {выводим точки от центра экрана, координату *10} if (i=imax)or(i=jmax)then {если это "крайние" точки} begin Setcolor(12); {выбираем ярко-красный цвет} Circle(GetmaxX div 2+10*mt[i].x,GetmaxY div 2+10*mt[i].y,3); {рисуем границу кружка} Setfillstyle(1,12);{рисуем круг тем же цветом 1-сплошная заливка} Fillellipse(GetmaxX div 2+10*mt[i].x,GetmaxY div 2+10*mt[i].y,2,2); end; Setcolor(15);{возвращаем цвет по умолчанию и выводим подписи номеров точек} OutTextXY(GetmaxX div 2+10*mt[i].x+5,GetmaxY div 2+10*mt[i].y,s); end; readln; Closegraph; end.

Ответ отправил: Пупорев Юрий Борисович (статус: Специалист) Ответ отправлен: 17.01.2009, 14:45 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 241421 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это! Оценка за ответ: 5

Вопрос № 157.910

Помогите пожалуйста написать программу с использованием переменных файлового типа и переменных типа запись. Даны результаты переписи населения, которые хранятся в памяти ЭВМ. Напечатать фамилии, имена и подсчитать общее число жителей, родив-шихся после 1990 года.

Отправлен: 17.01.2009, 00:15 Вопрос задал: Haze832 (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Haze832! Решение Вашей задачи с пояснениями в приложении. Удачной сдачи! Приложение: uses crt; type Tper=record {тип запись с полями по условию задачи} fam:string[15]; nam:string[15]; grz:word; end; var sp:Tper; {переменная этого типа для ввода данных} f:file of Tper; {типизированный файл этого типа для хранения данных} c:char; {символ окончания ввода} k:integer; begin clrscr; assign(f,'perep.dat');{создаем файл} rewrite(f); {открываем для записи} writeln('Vvedite dannye perepisi:'); repeat {цикл ввода данных} write('Familia: ');readln(sp.fam); write('Imya: ');readln(sp.nam); write('God rozdenya: ');readln(sp.grz); write(f,sp); c:=readkey;{ожидаем нажатия клавишы} until c=#27; {если Esc, заканчиваем ввод} clrscr; {очищаем экран} reset(f); {открываем файл для чтения} writeln('Rodilis posle 1990 goda:'); k:=0;b:=0; while not eof(f) do {пока не конец файла} begin read(f,sp); {читаем записи из файла} if sp.grz>1990 then {если поле года рождения больше 1990} begin k:=k+1;{считаем} writeln(sp.fam,' ',sp.nam,' God rozdenya ',sp.grz); {выводим данные} end; end; writeln; writeln('Rodivshihsya posle 1990 goda = ',k); {выводим количество} if k=0 then write('Rodivshihsya posle 1990 goda net!');{если нет никого} close(f); {закрываем файл} readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Специалист) Ответ отправлен: 17.01.2009, 12:09 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 241404 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Вопрос № 157.971

Здравствуйте.Как в Паскале можно проверить, существует ли данный каталог в текущей папке?( или в подкаталогах)? Как сделать это с помощью модуля Dos? Какая ошибка у меня произошла если после инициализации файла вывода ioresult=3? Можно ли при использовании assign-rewrite, указывать имя файла >8 символов? Заранее спасибо.

Отправлен: 17.01.2009, 18:14 Вопрос задал: Dimxmid (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 6)

Отвечает: sir Henry Здравствуйте, Dimxmid! 1. Для проверки существования каталога можно использовать функцию FindFirst() из модуля DOS, т.к. в этой функции можно задавать аттрибуты для поиска. Код: Uses Dos; Var sr: SearchRec; Begin FindFirst('Название_каталога', Directory, sr); If DosError=0 Then WriteLn('Каталог найден!') Else WriteLn('Увы, поиски были безуспешны...'); End. Если нужен поиск по всем подкаталогам, то возни будет больше, т.к. сначала необходимо найти все подкаталоги, далее, задавать их в маску поиска и продолжать поиск с помощью FindFirst()+FindNext() до тех пор, пока нужный каталог не будет найден. 2. IOResult = 3 означает "Путь не найден". 2 означает "Фа йл не найден". 3. Если Вы работаете с Turbo(Borland) Pascal то нельзя. Если Вы работаете с FreePascal, то можно, т.к. FreePascal разрабатывался для работы в современных ОС и всю их аттрибутику понимает без проблем, в отличие от такого замшелого анахронизма как Turbo Pascal. По моему мнению использовать для программирования Turbo Pascal сейчас могут только закостенелые мазохисты. Лучше скачать себе FreePascal и программировать как белый человек.

Ответ отправил: sir Henry (статус: Академик) Россия, Красноярск ---- Ответ отправлен: 17.01.2009, 20:32 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 241438 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это! Оценка за ответ: 5

Вопрос № 157.972

Здравствуйте! Помогите пожалуйста с решением вот этих задач: 1. Даны целочисленная матрица nx3, целые числа k, l (1<=k<=n, 1<=l<=n, k<>l).Преобразовать матрицу так, чтобы строка с исходным номером k непосредственно сле-довала за строкой с исходным номером l, сохранив порядок следования остальных строк. 2. В данной действительной квадратной матрице порядка n найти наибольший по модулю элемент. Получить квадратную матрицу порядка n-1 путем выбрасывания из исходной мат-рицы какой-нибудь строки и столбца, на пересечении которых расположен элемент с най-денным значением. 3. Дана действительная квадратная матрица порядка n, все элементы которой различны. Найти наибольший элемент среди стоящих на главной и побочной диагоналях и поменять его местами с элементом, стоящим на пересечении этих диагоналей.

Отправлен: 17.01.2009, 18:20 Вопрос задал: Popov_ A_V (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Motoden Здравствуйте, Popov_ A_V! Код программы в приложении. Код перенесен в приложение. -------- ∙ Отредактировал: Николай Владимирович / Н.В., Академик ∙ Дата редактирования: 18.01.2009, 11:16 (время московское) Приложение: 1 задание: program triniti; type matr=array[1..10,1..10] of real; var t,j,i,n,k,l:integer; matrix:matr; a:array[1..3] of real; procedure vivod_matrix(i,j:integer; matrix1:matr); var jj,ii:integer; begin ii:=0; while ii<i do begin ii:=ii+1; jj:=0; while jj<j-1 do begin jj:=jj+1; write(matrix1[ii,jj]:3:0); end; jj:=jj+1; writeln(matrix1[ii,jj]:3:0); end; end; begin writeln('Zadaite chislo strok matixi:'); write('n='); readln(n); t:=1; for i:=1 to n do begin for j:=1 to 3 do begin matrix[i,j]:=t; t:=t+1; end; end; j:=3; vivod_matrix(n,j,matrix); writeln('zadaite nomer peredvigaemoi stroki "k":'); write('k='); readln(k); writeln('zadaite stroku "l":'); write('l='); readln(l); for i:=1 to 3 do begin a[i]:=matrix[l+1,i]; matrix[l+1,i]:=matrix[k,i]; end; i:=k-1; while i<n-1 do begin i:=i+1; j:=0; while j<3 do begin j:=j+1; matrix[i,j]:=matrix[i+1,j]; end; end; i:=n+1; for i:=n-1 downto l+2 do begin j:=0; while j<3 do begin j:=j+1; matrix[i,j]:=matrix[i-1,j]; end; end; if k<l then begin j:=0; while j<3 do begin j:=j+1; matrix[l+1,j]:=a[j]; end; end else begin j:=0; while j<3 do begin j:=j+1; matrix[k,j]:=a[j]; end; end; vivod_matrix(n,j,matrix); readln; end.

Ответ отправил: Motoden (статус: 1-й класс) Ответ отправлен: 18.01.2009, 02:24 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 241458 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Отвечает: Пупорев Юрий Борисович Здравствуйте, Popov_ A_V! Вот боле простое и короткое решение первой задачи, а также второй и третьей задач. Приложение: №1. uses crt; const m=3; var a:array[1..20,1..m] of integer; n,i,j,k,l,x:integer; begin clrscr; randomize; write('n=');readln(n); writeln('Ishodnaja matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(20); write(a[i,j]:4); end; writeln; end; repeat {цикл ввода заданных строк с прверкой правильности ввода} write('k=');readln(k); write('l=');readln(l); until (k>=1)and(k<=n)and(l>=1)and(l<=n)and(k<>l); if l>k then //если строка К выше for j:=1 to m do begin x:=a[k,j]; //запоминаем строку К for i:=k to l-1 do //сдвигаем все строки от l-1 вверх на 1, строка К исчезает a[i,j]:=a[i+1,j]; a[l,j]:=x; //на освободившееся место вставляем строку К end else if k>l then //если строка К ниже for j:=1 to m do begin x:=a[k,j]; //запоминаем for i:=k downto l+2 do //тоже сдвигаем, только вниз a[i,j]:=a[i-1,j]; a[l+1,j]:=x; //на свободное место вставляем строку К end; writeln('Rezultat:'); for i:=1 to n do begin for j:=1 to m do write(a[i,j]:4); writeln; end; readln end. №2. uses crt; var n,i,j,imax,jmax:integer; a:array[1..50,1..50]of real; max:real; begin clrscr; write('n=');readln(n); randomize; writeln('Ishodnaya matrica:'); for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=random(10)+random-5; write(a[i,j]:5:1); end; writeln; end; max:=abs(a[1,1]);imax:=1;jmax:=1; for i:=1 to n do for j:=1 to n do if abs(a[i,j])>max then begin max:=a[i,j]; {находим максимальный по модулю элемент} imax:=i; {запоминаем строку, где его нашли} jmax:=j; {запоминаем столбец} end; writeln('max=',max:5:1); writeln('imax=',imax); writeln('jmax=',jmax); for i:=1 to n do {идем по строкам вниз} for j:=jmax to n-1 do begin a[i,j]:=a[i,j+1]; {в каждой строке сдвигаем все элементы от jmax+1 до n на одну позицию влево, нужный столбец исчезает} end; for j:=1 to n do {идем по столбцам вправо} for i:=imax to n-1 do begin a[i,j]:=a[i+1,j]; { в каждом столбце сдвигаем все элементы от imax+1 до n на одну позицию вверх, нужная строка исчезает } end; writeln('Udalenie stroki i stolbca:'); for i:=1 to n-1 do begin for j:=1 to n-1 do write(a[i,j]:5:1); writeln; end; readln; end. end. №3. uses crt; var n,i,j,imax,jmax:integer; a:array[1..50,1..50]of real; max,x:real; begin clrscr; randomize; repeat write('n=');readln(n); until odd(n); {поскольку пересечение диагоналей есть только у нечетных матриц, проверяем чтобы n было нечетным} writeln('Ishodnaya matrica:'); for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=10*random; write(a[i,j]:7:3); end; writeln; end; max:=a[1,1];imax:=1;jmax:=1; for i:=1 to n do for j:=1 to n do if ((i=j)or(j=n-i+1))and (a[i,j]>max) then {если главная диагональ(i=j), или побочная(j=n-i+1, то ищем максимальный элемент)} begin max:=a[i,j]; {находим} imax:=i; {запоминаем строку} jmax:=j; {запоминаем столбец} end; writeln('max=',max:0:3); writeln('imax=',imax); writeln('jmax=',jmax); x:=a[n div 2 +1,n div 2 +1]; {запоминаем элемент на пересечении диагоналей} a[n div 2 +1,n div 2 +1]:=a[imax,jmax]; {ставим на его место максимальный} a[imax,jmax]:=x; {на место максимального элемет с пересечения} writeln('Smena elementov:'); for i:=1 to n do begin for j:=1 to n do if ((i=imax)and(j=jmax))or((i=n div 2+1)and(j=n div 2+1)) then begin Textcolor(12); {выделим красным цветом переставленные элементы} write(a[i,j]:7:3); end else begin Textcolor(0); {остальные обычным, по умолчанию} write(a[i,j]:7:3); end; writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Специалист) Ответ отправлен: 18.01.2009, 09:01 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 241464 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

© 2001-2009, Портал RusFAQ.ru, Россия, Москва. Авторское право: ООО "Мастер-Эксперт Про" Техподдержка портала, тел.: +7 (926) 535-23-31 Хостинг: "Московский хостер" Поддержка: "Московский дизайнер" Авторские права | Реклама на портале ∙ Версия системы: 5.13 от 01.12.2008
RusFAQ.ru | MosHoster.ru | MosDesigner.ru RusIRC.ru | Kalashnikoff.ru | RadioLeader.ru