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

Выпуск № 435
от 06.08.2007, 18:05

Вопрос № 96.888

Сделайте пожалуйста!!!!!!!! нужно Разбить на процедуры и функции эту прогу: uses crt; var i,j,n,c:integer; a:array[1..20,1..20]of real; min,max,tmp:real; Begin clrscr; textcolor(14); write('Vvedite razmer matrici:'); readln(n); for i:=1 to n do begin for j:=1 to n do begin if i<j then a[i,j]:=sin(i+j)/cos(i+j) else if i=j then a[i,j]:=1 else a[i,j]:=cos(i+j)/sin(i+j); write(a[i,j]:10:3,' '); end; writeln; writeln; end; c:=0; for i:=1 to n do begin for j:=1 to n do begin if a[i,j]<0 then c:=c+1; end; end; min:=a[1,1];max:=a[1,1]; for i:=1 to n do begin for j:=1 to n do begin if (j<i) and (min>a[i,j]) then min:=a[i,j]; if (i>j) and (max<a[i,j]) then max:=a[i,j]; end; end; writeln('Min el-t vishe glavnoi dioganali=',min:9:3); writeln('Max el-t nije glavnoi dioganali=',max:10:3); writeln; writeln; writeln('Vivod transponirovannoi matrici'); for i:=2 to n do begin for j:=1 to i-1 do begin tmp:=a[i,j]; a[i,j]:=a[j,i]; a[j,i]:=tmp; end; end; for i:=1 to n do begin writeln; for j:=1 to n do begin write(a[i,j]:10:3,' '); end; end; textcolor(13); writeln; writeln('Kolichestvo otricatelnix elementov: ',c); readkey; end. Приложение: срочно нужно!!!!!!!!!

Отправлен: 31.07.2007, 19:50 Вопрос задал: Harlamenkov Alexandr Nikolaevich (статус: Посетитель) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Louken Здравствуйте, Harlamenkov Alexandr Nikolaevich! Пришлось исправить поиск максимального и минимального элементов матрицы. Задача в приложении: Приложение: uses crt; const cText = 14; {Cvet Texta} MaxSize = 8; {Max razmer matrici, prosto bolhe 8 ne pomeshaetsya na ekrane} var n:integer; a:array[1..MaxSize,1..MaxSize]of real; {Schitivaem razmer, do teh por, poka on budet lejati v predelah [1..MaxSize]} procedure ReadSizeMatrici; begin Repeat clrscr; write('Vvedite razmer matrici: '); readln(n); Until (n>0) and (n<=MaxSize); end; {Zapolnyaem matricu} procedure FillMatrix; var i,j: integer; begin for i:=1 to n do for j:=1 to n do begin if i<j then a[i,j]:=sin(i+j)/cos(i+j) else if i=j then a[i,j]:=1 else a[i,j]:=cos(i+j)/sin(i+j); end; end; {Vivodim na ekran matricu} procedure PrintMatrix; var i,j: integer; begin textcolor(15); for i:=1 to n do begin for j:=1 to n do write(a[i,j]:8:3,' '); writeln; end; textcolor(cText); end; {Podschet kolichestva otricatelnih elementov matrici} function GetCountNegativeElem: integer; var i,j,res: integer; begin res:=0; for i:=1 to n do for j:=1 to n do if a[i,j]<0 then res:=res+1; GetCountNegativeElem:=res; end; {Poisk max i min elementov matrici} procedure SearchMinAndMax(var min,max:real); var i,j: integer; begin min:=a[1,1];max:=a[1,1]; for i:=1 to n do for j:=1 to n do begin if (j>i) and (min>a[i,j]) then min:=a[i,j]; if (j<i) and (max<a[i,j]) then max:=a[i,j]; end; end; {Nahodim transponirovannu matricu} procedure TransponirovMatrix; var i,j:integer; tmp:real; begin for i:=2 to n do for j:=1 to i-1 do begin tmp:=a[i,j]; a[i,j]:=a[j,i]; a[j,i]:=tmp; end; end; var c:integer; min,max:real; Begin textcolor(cText); ReadSizeMatrici; FillMatrix; PrintMatrix; c:=GetCountNegativeElem; SearchMinAndMax(min,max); writeln('Min el-t vishe glavnoi dioganali=',min:9:3); writeln('Max el-t nije glavnoi dioganali=',max:10:3); writeln; writeln('Vivod transponirovannoi matrici:'); TransponirovMatrix; PrintMatrix; textcolor(13); write('Kolichestvo otricatelnix elementov: ',c); readkey; end.

Ответ отправил: Louken (статус: Студент) Ответ отправлен: 31.07.2007, 21:55

Отвечает: Delph Здравствуйте, Harlamenkov Alexandr Nikolaevich! Обработанную прогу смотрите в приложении. Приложение: program Proga; uses crt; var i,j,n,c: integer; a: array[1..20,1..20] of real; min,max,tmp: real; procedure InitMatrix(n: integer); var i, j: integer; begin for i:=1 to n do begin for j:=1 to n do begin if i<j then a[i,j]:=sin(i+j)/cos(i+j) else if i=j then a[i,j]:=1 else a[i,j]:=cos(i+j)/sin(i+j); write(a[i,j]:10:3,' '); end; writeln; writeln; end; end; function MinusCount(n: integer): integer; var i, j, c: integer; begin c:=0; for i:=1 to n do begin for j:=1 to n do begin if a[i,j]<0 then c:=c+1; end; end; MinusCount := c; end; procedure MinMax(n: integer); var i, j: integer; begin min:=a[1,1];max:=a[1,1]; for i:=1 to n do begin for j:=1 to n do begin if (j<i) and (min>a[i,j]) then min:=a[i,j]; if (i>j) and (max<a[i,j]) then max:=a[i,j]; end; end; writeln('Min el-t vishe glavnoi dioganali=',min:9:3); writeln('Max el-t nije glavnoi dioganali=',max:10:3); writeln; writeln; end; procedure Transpon(n: integer); var i, j: integer; begin writeln('Vivod transponirovannoi matrici'); for i:=2 to n do begin for j:=1 to i-1 do begin tmp:=a[i,j]; a[i,j]:=a[j,i]; a[j,i]:=tmp; end; end; for i:=1 to n do begin writeln; for j:=1 to n do begin write(a[i,j]:10:3,' '); end; end; end; Begin clrscr; textcolor(14); write('Vvedite razmer matrici:'); readln(n); InitMatrix(n); c := MinusCount(n); MinMax(n); Transpon(n); textcolor(13); writeln; writeln('Kolichestvo otricatelnix elementov: ',c); readkey; end.

Ответ отправил: Delph (статус: 5-ый класс) Ответ отправлен: 01.08.2007, 08:00 Оценка за ответ: 5

Отвечает: Дмитрий С. Здравствуйте, Harlamenkov Alexandr Nikolaevich! Вот подрихтовал немножко,и если исходный код Ваш, то,думаю, разберётесь ;). но всяк случай парочку комментов всё-таки черкну.. uses crt; var i,j,n,c:integer; a:array[1..20,1..20]of real; min,max,tmp:real; procedure Input_Matrix(var n: integer); // процеДура заполняет массив и показывает внесённые значения. Входящй параметр "n" здесь и далее будет обозначать размер массива. begin for i:=1 to n do begin for j:=1 to n do begin if i<j then a[i,j]:=sin(i+j)/cos(i+j) else if i=j then a[i,j]:=1 else a[i,j]:=cos(i+j)/sin(i+j); write(a[i,j]:10:3,' '); // Считаю, что добавление пробела при выводе в этом случае излишне, т.к. компенсируется форматированным выводом a[i,j]:10:3 end; end; function Count_Elem(var n: integer): integer; // как известно,функция от процедуры отличается тем,что она возвращает результат определённого типа. В нашем случае функция вернё количество отрицательных элементов массива begin for i:=1 to n do begin for j:=1 to n do begin if a[i,j]<0 then inc(c); // Неудержался от корректива - уж очень я люблю стандартную функцию "inc" (увеличивает переменную на единичку, или большее число, указанное во втором (необязательном параметре)) end;end; Count_Elem := c; // на этом моменте функция получает свой результат end; procedure Find_min_max_value(var n: integer); // Процедура поиска минимального и максимального элемента begin for i:=1 to n do begin for j:=1 to n do begin if (j<i) and (min>a[i,j]) then min:=a[i,j]; if (i>j) and (max<a[i,j]) then max:=a[i,j]; end;end; end; procedure Transp_matrix(var n: integer); // транспонирование матрицы begin for i:=2 to n do begin for j:=1 to i-1 do begin tmp:=a[i,j]; a[i,j]:=a[j,i]; a[j,i]:=tmp; end;end; end; procedure Print_Matrix(var n: integer); // вывод массива на экран begin for i:=1 to n do begin writeln; for j:=1 to n do begin write(a[i,j]:10:3,' '); end;end; end; Begin clrscr; textcolor(14); write('Vvedite razmer matrici:'); readln(n); Input_Matrix(n); // вот пример вызова процедуры writeln; writeln; end; c:=0; min:=a[1,1];max:=a[1,1]; Find_min_max_value(n); writeln('Min el-t vishe glavnoi dioganali=',min:9:3); writeln('Max el-t nije glavnoi dioganali=',max:10:3); writeln; writeln; writeln('Vivod transponirovannoi matrici'); Transp_matrix(n); Print_Matrix(n); textcolor(13); writeln; writeln('Kolichestvo otricatelnix elementov: ', Count_Elem(n)); readkey; end. Удачи!! --------- Наши программисты самые программистые программисты!..

Ответ отправил: Дмитрий С. (статус: 3-ий класс) Ответ отправлен: 01.08.2007, 13:38

Вопрос № 96.902

Здравствуйте ув. эксперт(ы)! Я составил целоцисленную матрицу по формуле Iij=i+j, i>j; i*j, i<=j; - найти мах элемент, лежащий выше главной диагонали; - Вывести номер строки и номер столбца мах элемента; - Найти среднее арифметическое всех элементов столбца, содержащего мах элемент; - Отсортировать строку, содержащую мах элемент, в порядке убывания; Нужна помощь следующего характера: разбить эте прогу на процедуры и эти элементы: - найти мах элемент, лежащий выше главной диагонали; - Вывести номер строки и номер столбца мах элемента; - Найти среднее арифметическое всех элементов столбца, содержащего мах элемент; - Отсортировать строку, содержащую мах элемент, в порядке убывания; чтобы заполнялись из отдельного файла... программу прилагаю. Спасибо))) Приложение: uses crt; var i,j,x,y,n:integer; max:integer; sum:integer; tmp:integer; sred:real; a:array[1..20,1..20]of integer; Begin clrscr; write('Vvedite razmer matrici:'); readln(n); writeln('Icxodhaya matrica:'); Writeln; for i:=1 to n do begin for j:=1 to n do begin if i>j then a[i,j]:=i+j else a[i,j]:=i*j; write(a[i,j]:5,' '); end; writeln; end; max:=a[1,1]; x:=1; y:=1; for i:=1 to n do for j:=1 to n do if (i<j) and (max<a[i,j]) then begin max:=a[i,j]; x:=i; y:=j; end; sum:=0; for i:=1 to n do sum:=sum+A[i,y]; sred:=sum/n; for i:=1 to n do for j:=1 to n-1 do begin if A[x,j]<A[x,j+1] then begin tmp:=A[x,j]; A[x,j]:=A[x,j+1]; A[x,j+1]:=tmp; end; end; writeln; writeln('Max el-t vyshe glavnoi dioganali=',max:10); Writeln; Writeln('Nomer stroki max elementa = ',x); Writeln('Nomer stolbca max elementa= ',y); Writeln('Srednee arifmeticheskoe ',y,' stolbca = ',sred:5:3); writeln; writeln('otcortirovannaya matrica:'); writeln; for i:=1 to n do begin for j:=1 to n do begin write(A[i,j]:5,' '); end; writeln; end; readkey; end.

Отправлен: 31.07.2007, 21:20 Вопрос задал: Безгубенко Валерий Сергеевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Безгубенко Валерий Сергеевич! Смотрите приложение. Удачи! Приложение: program q96902; uses crt; type mass=array[1..20,1..20]of integer; var x,y,n:integer; a:mass; {формируем массив} procedure defineMassiv(n:integer;var a:mass); var i,j:integer; begin for i:=1 to n do begin for j:=1 to n do begin if i>j then a[i,j]:=i+j else a[i,j]:=i*j; write(a[i,j]:5); end; writeln; end; end; {ишем максимум} procedure findMaximum(var x,y:integer;a:mass); var i,j:integer; begin for i:=1 to n do for j:=1 to n do if (i<j) and (a[x,y]<a[i,j]) then begin x:=i; y:=j; end; end; {ищем сумму столбца} function findSumma(y:integer;a:mass):integer; var i,j:integer; begin j:=0; for i:=1 to n do j:=j+a[i,y]; findSumma:=j; end; {сортируем строку} procedure sortMassiv(n,x:integer;var a:mass); var i,j,t:integer; begin for i:=1 to n-1 do for j:=i+1 to n do if a[x,i]<a[x,j] then begin t:=a[x,i]; a[x,i]:=a[x,j]; a[x,j]:=t; end; end; {виводим массив} procedure outputMassiv(a:mass); var i,j:integer; begin for i:=1 to n do begin for j:=1 to n do write(a[i,j]:5); writeln; end; end; {вводим из файла} procedure inputMassiv(n:integer;var a:mass); var i,j:integer; f:file of integer; s:string; begin writeln('enter file name:'); readln(s); assign(f,s); reset(f); for i:=1 to n do for j:=1 to n do if not(eof(f))then read(f,a[i,j]); end; Begin clrscr; write('Vvedite razmer matrici[<20]:'); readln(n); writeln('Icxodhaya matrica:'); Writeln; defineMassiv(n,a); x:=1; y:=2; findMaximum(x,y,a); writeln; writeln('Max el-t vyshe glavnoi dioganali=',a[x,y]:10); writeln('Nomer stroki max elementa = ',x:14); writeln('Nomer stolbca max elementa= ',y:14); writeln; writeln('Srednee arifmeticheskoe ',y,' stolbca = ',(findSumma(y,a)/n):5:3); sortMassiv(n,x,a); writeln; writeln('otcortirovannaya matrica:'); writeln; outputMassiv(a); readkey; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Практикант) Ответ отправлен: 01.08.2007, 12:36

Вопрос № 96.976

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

Отправлен: 01.08.2007, 14:13 Вопрос задал: Безгубенко Валерий Сергеевич (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Omickron Здравствуйте, Безгубенко Валерий Сергеевич! Ну, саму программу писать, конечно, не буду. Сами справитесь. Алгоритм такой: 1. Разбор второго текста по словам с занесением всех слов в динамический массив (без повторов) 2. По ходу разбора по словам первого текста сравнивать каждое выделенное слово со словами из динамического массива (из первого пункта). Если не найдено совпадений - заносить во второй динамический массив. 3. В результате первых двух пунктов в первом дин. массиве будут все слова, встречающиеся во втором тексте, а во втором дин. массиве - слова из первого текста, не встречающиеся во втором тексте. Останется только перебором из второго дин. массива найти самое короткое слово. В принципе, задачка на первый семестр первого курса по Pascal. Тема - строки, массивы. Вместо динамических массивов можно использовать текстовые файлы (это будет немного дольше). Удачи.

Ответ отправил: Omickron (статус: 3-ий класс) Ответ отправлен: 01.08.2007, 14:41

Отвечает: Дмитрий С. Здравствуйте, Безгубенко Валерий Сергеевич! Предлагаю Вам свой варинт решения задачи. Возможно не самый рациональный, поэтому прошу рассматривать, как возможный вариант решения. правильность на 100% не гарантирую, т.к. пишу без компилятора. const mn = [' ', ',', '-', '.', ';']; var text_1, text_2, sl: string; f, f2, tmp: text; procedure ABC(var s: string, var f: text); // при помощи процеДуры заношу в файл слова из текста var a: string; i: integer; begin Repeat a:=''; i := 0; While not s[i] in mn do begin inc(i); a := a + s[i]; end; writeln(f, a); Delete(s, i+1, 1); Until (s='') or (s in mn); end; function Find_Word(f: text): string; // ищем самое маленькое слово var d: integer; s: string; begin d := 0; readln(f, s); d := length(s); while not EOF(f) do begin readln(f, s); if length(s)<d then begin d := length(s); Find_Word := s; end; end; end; Function Get_Result(var s: string; f: text): boolean; var t: string; begin Get_result := true; While not EOF(f) do begin readln(f, t); if t=s then Get_Result := false; end; end; Procedure Del_Text(var s: string); var t: string; begin Rewrite(tmp); while not EOF(f) do begin readln(f, t); if not (t=s) then writeln(tmp, t); end; DeleteFile(f); RenameFile('tmp_File.txt', 'My_File.txt'); Rewrite(tmp); end; begin Assign(f, 'First_File.txt'); // подготавливаем 2 файла, в которые будем заносить слова if not FileExist('My_File.txt') then rewrite(f) else reset(f); Assign(f2, 'Last_File.txt'); if not FileExist('Last_File.txt') then rewrite(f2) else reset(f2); Assign(tmp, 'Tmp_File.txt'); // ещё один файл "для опытов" if not FileExist('tmp_File.txt') then rewrite(tmp) else reset(tmp); // получить 2 строки с текстом sl := ''; ABC(text_1, f); ABC(text_2, f2); Find_Word(text_1); Repeat Del_Text(Find_Word); Until Get_Result(Find_Word, f2); end. Приложение: Алгоритм предполагает, что слова в предложении разделены 1 знаком препинания или пробелом. --------- Наши программисты самые программистые программисты!..

Ответ отправил: Дмитрий С. (статус: 3-ий класс) Ответ отправлен: 01.08.2007, 15:29

© 2001-2007, Портал RusFAQ.ru, Россия, Москва. Авторское право: ООО "Мастер-Эксперт Про" Email: support@rusfaq.ru, тел.: +7 (926) 535-23-31 Хостинг: "Московский хостер" Поддержка: "Московский дизайнер" Авторские права | Реклама на портале Версия системы: 4.54 beta от 01.08.2007
RusFAQ.ru | MosHoster.ru | MosDesigner.ru | RusIRC.ru Kalashnikoff.ru | RadioLeader.ru | RusFUCK.ru