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

Выпуск № 611
от 23.03.2008, 22:05

Вопрос № 127.830

дан массив целых чисел, определить есть ли две пары соседних элементов с одинаковыми знаками

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

Отвечает: Delph Здравствуйте, Степанов Александр Сергеевич! Программа в приложении. Приложение: Program Pr127830; Uses CRT; Const N = 10; Var Arr: Array[1..N] of Integer; i, r: Integer; bool: Boolean; Begin ClrScr; WriteLn('Введите ', N, ' чисел:'); for i := 1 to N do begin Write('Arr[', i, '] = '); ReadLn(Arr[i]); end; bool := False; WriteLn; for i := 2 to N do begin if Arr[i - 1] * Arr[i] > 0 then begin if not bool then WriteLn('Найдены пары соседних однознаковых элементов:'); bool := True; Write('Arr[', i - 1, '] = ', Arr[i - 1]); WriteLn(' и Arr[', i, '] = ', Arr[i]); end; end; if not bool then WriteLn('Соседних однознаковых элементов не найдено'); ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Студент) Ответ отправлен: 18.03.2008, 08:41 Оценка за ответ: 5

Отвечает: Пупорев Юрий Борисович Здравствуйте, Степанов Александр Сергеевич! Ответ а приложении. Приложение: uses crt; var a:array[1..20] of integer; n,i,k:integer; begin clrscr; write('n=');readln(n); randomize; for i:=1 to n do begin a[i]:=random(20)-10; write(a[i],' '); end; k:=0; for i:=1 to n-1 do if (a[i]*a[i+1]>0) then begin k:=k+1; end; if k>=2 then writeln('Yes!') else writeln('No.'); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 10:12

Вопрос № 127.837

Помогите мне плиз.У меня не выходят эти программы.Ламаю голову третий день.Буду очень благодарен 1) Применяя сортировку обменами, расположить элементы вектора A размерности n, что большие r, по убыванию. 2) Путем последовательной перестановки строк и столбиков расположить наибольший элемент матрицы А в правом верхнем кутье, а наименьший - в левом нижнем

Отправлен: 17.03.2008, 23:35 Вопрос задал: Петренко Дмитро (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Петренко Дмитро ! Ответ на второй вопрос в приложении. Проверял на разных вариантах, работает. Если вдруг выскочит что-то необычное, пиши, разберемся. Приложение: uses crt; var a:array[1..50,1..50]of integer; n,m,i,j,max,min,imax,jmax,imin,jmin,x:integer; begin clrscr; randomize; write('n=');readln(n); write('m=');readln(m); writeln('Ishodnaia matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(20)+1;{лучше вводить вручную, чтобы макс и мин были в разных строках и столбцах} write(a[i,j]:3); end; writeln; end; readln; max:=a[1,1];min:=a[1,1]; imax:=1;jmax:=1;imin:=1;jmin:=1;{находим номера строк и столбцов с мин и макс} for i:=1 to n do for j:=1 to m do if a[i,j]>max then begin max:=a[i,j]; imax:=i; jmax:=j; end else if a[i,j]<min then begin min:=a[i,j]; imin:=i; jmin:=j; end; writeln('max=',max,' imax=',imax,' jmax=',jmax); writeln('min=',min,' imin=',imin,' jmin=',jmin); readln; for i:=1 to n do {stolbec m-max} begin x:=a[i,m];a[i,m]:=a[i,jmax];a[i,jmax]:=x; end; for j:=1 to m do {stroka 1-max} begin x:=a[1,j];a[1,j]:=a[imax,j];a[imax,j]:=x; end; for i:=1 to n do {stolbec 1-min} begin x:=a[i,1];a[i,1]:=a[i,jmin];a[i,jmin]:=x; end; for j:=1 to m do {stroka n-max} begin x:=a[n,j];a[n,j]:=a[imin,j];a[imin,j]:=x; end; for i:=1 to n do begin for j:=1 to m do begin write(a[i,j]:3); end; writeln; end; readln; end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 12:32

Вопрос № 127.855

Здравствуйте, уважаемые программисты! Вот тут задачка: Вася разработал новый способ вычитания: записываем числа в столбик друг под другом, и большей цифры вычитаем меньшую и записываем результат. Например, 1 1 2 3 8 7 1 3 7 6 1 Недостоющие числа заменяем нулями. Я написал программу, она довольно громоздкая, и я не могу записать полученный результат в инвентированном виде. Подскажите, как это сделать. Программа в приложении. Последний цикл я использовал для наглядности, его можно удалить, т. к. он не универсален. Приложение: Var a, b, a1, b1, i, j, h1, h2, ans: Integer; x, y, z: Array[1..100] Of Integer; Begin WriteLn('Введите два целых числа: '); ReadLn(a, b); a1 := a; b1 := b; h1 := 0; h2 := 0; ans := 0; While (a1 <> 0) Do Begin Inc(h1); a1 := a1 Div 10; End; While (b1 <> 0) Do Begin Inc(h2); b1 := b1 Div 10; End; For i := 1 To h1 Do Begin x[i] := a Mod 10; a := a Div 10; End; For i := 1 To h2 Do Begin y[i] := b Mod 10; b := b Div 10; End; If (h1 < h2) Then Begin For i := 1 To h2 Do Begin z[i] := Abs(x[i]-y[i]); End; End Else Begin For i := 1 To h2 Do Begin z[i] := Abs(x[i]-y[i]); End; End; For i := 1 To 4 Do Begin Write(z[i]); End; WriteLn; End.

Отправлен: 18.03.2008, 05:08 Вопрос задал: Хощенко Артём Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 4)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Хощенко Артём Владимирович! Убрал все лишнее из кода. Удачи! Приложение: Var a, b, i, h: Integer; x, y, z: Array[1..100] Of Integer; Begin Write('Введите X: '); ReadLn(a); Write('Введите Y: '); ReadLn(b); h := 0; While (a <> 0)or( b <> 0) Do Begin Inc(h); x[h]:=a mod 10; y[h]:=b mod 10; a := a Div 10; b := b div 10 End; For i := 1 To h Do z[i] := Abs(x[i]-y[i]); Write('Результат: '); For i := h DownTo 1 Do Write(z[i]); WriteLn; ReadLn; End. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 19.03.2008, 15:56 Оценка за ответ: 5 Комментарий оценки: Спасибо! Всё правда проще можно было сделать!

Вопрос № 127.866

ВВедите три числа.Если они могут быть длинами сторон остроугольного треугольника,выведите их в порядке убывания и вычислите их площадь.

Отправлен: 18.03.2008, 07:52 Вопрос задала: Лиманская Юлия Вадимовна (статус: Посетитель) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Delph Здравствуйте, Лиманская Юлия Вадимовна! Решение Вашей задачки в приложении. Приложение: Program Pr127867; Uses CRT; Var a, b, c, p, S: Real; Begin ClrScr; WriteLn('Введите стороны треугольника:'); Write('a = '); ReadLn(a); Write('b = '); ReadLn(b); if b < a then begin p := a; a := b; b := p; end; Write('c = '); ReadLn(c); if c < a then begin p := a; a := c; c := p; end; if c < b then begin p := b; b := c; c := p; end; if ((a <= 0.0) or (b <= 0.0) or (c <= 0.0)) then begin WriteLn('Все стороны треугольника должны быть положительны!'); end else if ((a >= b + c) or (b >= a + c) or (c >= a + b)) then begin WriteLn('Каждая из сторон должна быть меньше суммы двух других!'); end else begin WriteLn; WriteLn('c = ', c); WriteLn('b = ', b); WriteLn('a = ', a); p := (a + b + c) / 2; { Полупериметр } S := sqrt(p * (p - a) * (p - b) * (p - c)); { формула Герона } WriteLn('Площадь треугольника = ', S); end; ReadLn; End. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Студент) Ответ отправлен: 18.03.2008, 08:16

Отвечает: Костя Симанович Здравствуйте, Лиманская Юлия Вадимовна! Насколько я помню из геометрии остроугольный треугольник это треугольник углы которого меньше 90 градусов. Поэтому предлагаю использовать для решения задачи теорему косинусов. cos(90) = 0 , cos(0) = 1, значит если угол острый то косинус угла будет в диапазоне от 0 до 1, но крайние случаи не рассматриваем (для упрощения задачи, но если хотите можно ввести в задачу эту проверку), а угол 90 градусов это прямоугольный треугольник и под Ваше условие не попадает. поэтому в задаче проверяется, что бы косинус угла был больше 0, но не меньше 1. так же я не стал проверять в задаче ввод отрицательных чисел. (хотя если такое возможно, то чтобы не усложнять решение можно воспользоваться функцией ABS ). Вариант решения в приложении. В предыдущем ответе Delph проверяется условие (Каждая из сторон должна быть меньше суммы двух других) помоему не достаточна для определения остроугольного треугольника. т. к. если взять класс ический прямоугольный треугольник со сторонами 3, 4, 5 то сумма двух сторон будет всегда больше третьей стороны. (p. s. по геометрии я был не отличник если не прав поправьте). Отредактировано по просьбе эксперта. ----- ∙ Отредактировал: Николай Владимирович / Н.В. (Профессионал) ∙ Дата редактирования: 18.03.2008, 13:24 Приложение: program treug; var ab, bc, cd : real; a, b , c : real; // cos углов s : real; // площадь p : real; // полупериметр begin writeln('ab = '); readln(ab); writeln('bc = '); readln(bc); writeln('cd = '); readln(cd); if (ab = 0) or (bc = 0) or (cd = 0) then writeln('Стороны не могут иметь 0 длину') else begin a := (ab*ab + cd*cd - bc*bc)/(2*ab*cd); b := (ab*ab + bc*bc - cd*cd)/(2*ab*bc); c := (bc*bc + cd*cd - ab*ab)/(2*bc*cd); if a > 0 then if b > 0 then if c > 0 then begin writeln('Треугольник остроугольный'); writeln('Вычисляем площадь.'); p := (ab + bc + cd)/2; s := sqrt(p*(p - ab)*(p - bc)*(p-cd)); {сортируем стороны} if ab < bc then begin a := ab; ab := bc; bc := a; end; if ab < cd then begin a := ab; ab := cd; cd := a; end; if bc < cd then begin a := bc; bc := cd; cd := a; end; writeln(ab); writeln(bc); writeln(cd); writeln; writeln('Площадь треугольника = ', s:2:2); end else writeln('треугольник не остроугольный') else writeln('треугольник не остроугольный') else writeln('треугольник не остроугольный'); end; readln; end.

Ответ отправил: Костя Симанович (статус: 2-ой класс) Ответ отправлен: 18.03.2008, 10:36

Отвечает: Пупорев Юрий Борисович Здравствуйте, Лиманская Юлия Вадимовна! Мне кажется мое решение неплохое. Лего решен вопрос с расположением по убыванию(сортировка в массиве), нет многочисленных сравнений и переборов, а также формулы Герона, одна элементарная планиметрия. Суть решения задачи сводится к нескольким постулатам планиметрии. 1.Треугольник существует, если большая сторона меньше суммы двух других. 2.Наибольший угол лежит против большей стороны (c). 3.Сos этого угла равен (a^2+b^2-c^2)/(2ab). 3.Если синус большего угла >0, треугольник остроугольный. 4.Площадь треугольника равна 1/2ab*sinC sinC=sqrt(1-cos^2). Код в приложении. Приложение: uses crt; var a:array[1..3]of real; i,j:integer; x,cs,sn,s:real; begin clrscr; for i:=1 to 3 do begin write('a[',i,']='); readln(a[i]); end; for i:=1 to 2 do for j:=1 to 2 do if a[j]<a[j+1] then begin x:=a[j];a[j]:=a[j+1];a[j+1]:=x; end; cs:=(sqr(a[2])+sqr(a[3])-sqr(a[1]))/(2*a[2]*a[3]); sn:=sqrt(1-sqr(cs)); if (a[1]<(a[2]+a[3]))and(cs>0) then begin write(a[1]:5:2,' ',a[2]:5:2,' ',a[3]:5:2); writeln; writeln('Treugolnik ostrougolny'); end else writeln('Treugolnik ne ostrougolny ili ne sushestvuet'); s:=0.5*a[2]*a[3]*sn; writeln('Ploshad= ',s:5:2); readln; end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 19.03.2008, 16:16

Вопрос № 127.907

По заданным значениям x,y,z вычислите значения u: u=min(x,max(y,z))

Отправлен: 18.03.2008, 11:27 Вопрос задала: Лиманская Юлия Вадимовна (статус: Посетитель) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Лиманская Юлия Вадимовна! Программа в приложении. Удачи! Приложение: function min(a,b:real):real; begin if a < b then min := a else min := b; end; function max(a,b:real):real; begin if a > b then max := a else max := b; end; var u, x,y,z:real; begin Write('Input x:'); ReadLn(x); Write('Input y:'); ReadLn(y); Write('Input z:'); ReadLn(z); u := min(x,max(y,z)); WriteLn('u = ',u); ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессионал) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 18.03.2008, 11:37 Оценка за ответ: 5

Отвечает: Пупорев Юрий Борисович !!! Здравствуйте, Лиманская Юлия Вадимовна! Решение в приложении. Ответ неверный. При вводе двух одинаковых значений любых двух чисел в результате будет выведен 0. Ошибка в условных операторах: Вместо if y>z then max:=y else if z>y then max:=z; должно быть if y>z then max:=y else max:=z; и вместо if x<max then min:=x else if max<x then min:=max; надо написать if x<max then min:=x else min:=max; (В задании не сказано, что все числа различные.) ----- ∙ Отредактировал: Николай Владимирович / Н.В. (Профессионал) ∙ Дата редактирования: 18.03.2008, 14:22 Приложение: uses crt; var x,y,z,u,min,max:real; begin clrscr; Write('x=');readln(x); Write('y=');readln(y); Write('z=');readln(z); if y>z then max:=y else if z>y then max:=z; if x<max then min:=x else if max<x then min:=max; u:=min; writeln('u=',u:4:2); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 13:54

Отвечает: Шемет Станислав Васильевич Здравствуйте, Лиманская Юлия Вадимовна! Программа в приложении. Удачи !!! Приложение: Var X,y,z,U:integer; Function Min(a,b:integer):integer; Begin if A<b then Min:=a else Min:=b; end; Function Max(a,b:integer):integer; Begin If a>b then MAx:=a else MAx:=b; end; Begin Writeln('Enter X,Y,Z :'); REadln(x,y,z); u:=min(x,max(y,z)); Writeln('min(x,max(y,z))=',u); Readln; end. --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 4-ый класс) Ответ отправлен: 18.03.2008, 21:09

Вопрос № 127.908

дан двумерный массив. Выполнить следующие преобразование: последний отрицательный элементы каждой строки заменить на ноль

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

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Степанов Александр Сергеевич! Программа в приложении. Удачи! Приложение: const N = 10; M = 5; var A : array[1..N,1..M] of integer; procedure replace(line:integer); var i : integer; done : boolean; begin i := M; done := false; while (not done) and (i > 0) do begin if A[line,i] < 0 then begin A[line,i] := 0; done := true; end; dec(i); end; end; var i, j, max : integer; begin randomize; for i := 1 to N do begin for j := 1 to M do begin A[i,j] := random(20)-10; Write(A[i,j]:3); end; WriteLn; end; WriteLn; for i := 1 to N do replace(i); for i := 1 to N do begin for j := 1 to M do Write(A[i,j]:3); WriteLn; end; ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессионал) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 18.03.2008, 11:45

Отвечает: Пупорев Юрий Борисович !!! Здравствуйте, Степанов Александр Сергеевич! Ответ в приложении. Неверный ответ. Требуется заменить "последний отрицательный элемент каждой строки", а не последний элемент строки, если он отрицательный. ----- ∙ Отредактировал: Николай Владимирович / Н.В. (Профессионал) ∙ Дата редактирования: 18.03.2008, 14:40 Приложение: uses crt; var a:array[1..50,1..50]of integer; n,m,i,j:integer; begin clrscr; write('n=');readln(n); write('m=');readln(m); writeln('Ishodnaia matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10)-5; write(a[i,j]:3); end; writeln; end; readln; for i:=1 to n do if a[i,m]<0 then begin a[i,m]:=0; end; writeln('Rezultat:'); for i:=1 to n do begin for j:=1 to m do begin write(a[i,j]:3); end; writeln; end; readln; end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 14:17

Вопрос № 127.912

дана строка. подсчитать количество гласных латинских букв в данной строке

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

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Степанов Александр Сергеевич! Программа в приложении. Удачи! Приложение: const glas = 'AEIOUYaeiouy'; { гласные буквы - проверьте на всякий случай, все ли здесь указаны...} var s : string; i, count : integer; begin Write('Vvedite stroku: '); ReadLn(s); count := 0; for i := 1 to length(glas) do while pos(copy(glas,i,1),s)>0 do begin delete(s, pos(copy(glas,i,1),s), 1); inc(count) end; WriteLn('Glasnyh bukv: ',count); ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессионал) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 18.03.2008, 12:05

Отвечает: Пупорев Юрий Борисович Здравствуйте, Степанов Александр Сергеевич! Решение в приложении. Приложение: uses crt; const gl=['a','e','i','j','o','u','y','A','E','I','J','O','U','Y']; var s:string; i,k:integer; begin clrscr; write('s: ');readln(s); k:=0; for i:=1 to length(s) do if s[i] in gl then begin k:=k+1; end; writeln('Kolichestvo glasnyh bukv=',k); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 14:29

Вопрос № 127.957

Уважаемые эксперты помогите написать программу в Турбо Паскале.Сформировать двумерный массив С размером 3 на 5, с помощью генератора случайных и вывести элементы массива на экран и в файл.Вычислить сумму положительных элементов в каждой строке матрицы С (оформить вычисление сумм в виде процедур).Из полученных сумм составить одномерный массив D. Вы вывести элементы массива D на экран и в файл.

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

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Midvi! Программа в приложении. Удачи! Приложение: const N = 3; M = 5; var C : array[1..N,1..M] of integer; D : array[1..N] of integer; function summ(line:integer):integer; var i, res : integer; begin res := 0; for i := 1 to M do if C[line,i] > 0 then res := res + C[line,i]; summ := res; end; var i, j, max : integer; f : Text; begin Assign(f,'127957_o.txt'); ReWrite(f); randomize; for i := 1 to N do begin for j := 1 to M do begin C[i,j] := random(20)-10; Write(C[i,j]:3); Write(f,C[i,j]:3); end; WriteLn; WriteLn(f); end; WriteLn; WriteLn(f); for i := 1 to N do D[i] := summ(i); for i := 1 to N do begin Write(D[i]:3); Write(f, D[i]:3); WriteLn; end; Close(f); ReadLn; end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессионал) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 18.03.2008, 16:14

Отвечает: Пупорев Юрий Борисович Здравствуйте, Midvi! Решение в приложении. Показан вывод на экран и в файл, с небольшими комментариями. Приложение: uses crt; type mass=array[1..3]of integer; matr=array[1..3,1..5]of integer; var C:matr;D:mass;i,j:integer;f:text; function Summ(n:integer;a:matr):integer;{функция} var sum:integer; begin sum:=0; for j:=1 to n do if a[i,j]>0 then begin sum:=sum+a[i,j]; end; Summ:=sum; end; begin {начало программы} clrscr; randomize; writeln('Ishodnaia matrica:'); for i:=1 to 3 do begin for j:=1 to 5 do begin C[i,j]:=random(20)-5; write(C[i,j]:4); end; writeln; end; readln; writeln('massiv summ:'); for i:=1 to 3 do begin D[i]:=Summ(5,C); write(D[i],' '); end; readln; assign(f,'FFFF.txt'); {создаем файл} rewrite(f); {открываем для записи} writeln(f,'matrica C:'); for i:=1 to 3 do begin for j:=1to 5 do begin write(f,C[i,j]:3); {записываем матрицу} end; writeln(f,''); end; writeln(f,''); writeln(f,'massiv summ:'); {записываем массив} for i:=1 to 3 do write(f,D[i]:3); close(f); end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 19:50

Вопрос № 127.962

Помогите сделать задачу, с массивами у меня проблемы Определить число и сумму позитивных элементов к первому видемного в массивах A(n, l), B(c,k), D(r,s). Примечание N, c, l, k, r, s< (меньше ровное) 10

Отправлен: 18.03.2008, 16:22 Вопрос задал: Петренко Дмитро (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Verena Здравствуйте, Петренко Дмитро ! Программа в приложении определяет сумму и количество положительных элементов в матрицах при помощи вызова процедуры Pozs. Ввод матрицы не стала оформлять в виде процедуры, но если понадобится, это можно легко сделать, выделив кусок с вводом данных и поместив его в тело новой процедуры. Удачи! Приложение: Type mas = array [1..10, 1..10] of integer; Var a, b, d: mas; j, i, n, c, l, k, r, s, kol, sum: integer; procedure Pozs (var a: mas; m, n: integer; var kol, sum: integer); {Процедура нахождения суммы и количества положительных элементов} Var i, j: integer; begin kol:= 0; sum:= 0; {Обнуляем переменные} for i:=1 to m do {Обходим матрицу} for j:=1 to n do if (a[i,j]>0) then {Если элемент положителен} begin inc (kol); {Увеличиваем счётчик} sum:= sum+a[i,j]; {Увеличиваем сумму} end; end; Begin {Ввод информации} writeln ('Vvedite n, l: '); readln (n, l); writeln ('Vvedite matritzu A: '); for i:=1 to n do for j:=1 to l do readln (a[i,j]); writeln ('Vvedite c, k: '); readln (c, k); writeln ('Vvedite matritzu B: '); for i:=1 to c do for j:=1 to k do readln (b[i,j]); writeln ('Vvedite r, s: '); readln (r, s); writeln ('Vvedite matritzu D: '); for i:=1 to r do for j:=1 to s do readln (d[i,j]); {Вызов процедур} Pozs (a, n, l, kol, sum); writeln ('A: kol=', kol:7, ' sum=', sum:7); Pozs (b, c, k, kol, sum); writeln ('B: kol=', kol:7, ' sum=', sum:7); Pozs (d, r, s, kol, sum); writeln ('D: kol=', kol:7, ' sum=', sum:7); end. --------- Эта история - не для истории, понимаешь?

Ответ отправила: Verena (статус: Практикант) Ответ отправлен: 20.03.2008, 17:31 Оценка за ответ: 5 Комментарий оценки: спасибо тебе большое !

Вопрос № 128.005

Помогите пожалуйста написать сортировку в виде модуля и желательно чтобы двумерный массив был представлен в виде двух одномерных. Алгоритм сортировки оформить в виде процедуры в модуле. Сортировка осуществляется по третьей строке и сортирует весь массив. Сама задача: Дан список учеников класса и отметки каждого из учеников за выпол-нение двух контрольных работ. Требуется: подсчитать число учеников, выполнивших первую работу на 5; подсчитать число учеников, выполнив-ших обе работы на 5. Упорядочить список учеников по среднему баллу за обе контрольные работы. Приложение: Решенная задача без сортировки: program jimm0b; uses crt; const n=3; m=10; type mas=array[1..n,1..m] of real; procedure view(x:mas); var i,j:integer; begin for i:=1 to 2 do begin for j:=1 to m do write(x[i,j]:5); writeln; end; end; procedure create_random(var x:mas); var i,j:integer; begin for i:=1 to 2 do for j:=1 to m do x[i,j]:=random(4)+2; end; procedure create (var x:mas); var i,j:integer; begin clrscr; For i:=1 to n do for j:=1 to m do begin write('vvedite A[',i,';',j,']='); readln(x[i,j]); end; end; var A:mas; Ch,i,j,l1,k:integer; l,c:real; begin clrscr; randomize; writeln('1-vvod mas'); writeln('2-random'); writeln; repeat write('vvedite #pynkta'); readln(ch); case ch of 1:Create(a); 2:create_random(a); else writeln('povtorite vvod'); end; until (ch=1) or (ch=2); clrscr; writeln('ishodny mas'); View(a); For j:=1 to m do begin if a[1,j]=5 then inc(k); end; for j:=1 to m do begin if (a[1,j]=5) and (a[2,j]=5) then inc(l1); end; writeln; writeln(k:5,l1:3); for j:=1 to m do begin a[3,j]:=((a[1,j]+a[2,j])/2); write(a[3,j]:3); readkey; end; end. Сортировка: repeat l:=0; For j:=1 to m-1 do begin if a[3,j]>a[3,j+1] then begin for i:=1 to n do begin c:=a[i,j]; a[i,j]:=a[i,j+1]; a[i,j+1]:=c;end; l:=1;end;end; until l=0; for i:=1 to 2 do for j:=1 to m do write(a[i,j]:3); for i:=1 to n do for j:=1 to m do write(a[i,j]:3); writeln; readln; end.

Отправлен: 18.03.2008, 20:44 Вопрос задал: Муратов Дмитрий Анатольевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Муратов Дмитрий Анатольевич! Ваша задача типичная на записи, где в одном одномерном массиве можно хранить несколько связанных полей. Вы прочитаете код, разберетесь в нем и поймете, что это намного лучше в некоторых случаях, чем просто двумерные массивы. Сделал модуль с одной процедурой, как вы просили. Его нужно набрать в редакторе и откомпилировать(запуститью После этого у вас появится файл с расширением *.tpu это и будет модудь, такой же как например Crt. Отдельно сама задача. Проверял, все работает. Короче удачи! Приложение: Модуль. unit Sort; interface type uchenik=record fam:string[20]; ocen1,ocen2:byte; sr_bl:real; end; uch=array[1..30]of uchenik; procedure Srtr(n:integer;var a:uch); implementation procedure Srtr(n:integer;var a:uch); var i,j:integer;x:real; begin a[i].sr_bl:=(a[i].ocen1+a[i].ocen2)/2; for i:=1 to n-1 do for j:=1 to n-1 do if a[i].sr_bl>a[i+1].sr_bl then begin x:=a[i];a[i]:=a[i+1];a[i+1]:=x; end; end; Программа. program q8005; uses crt,Sort; var i,n,k1,k2:integer; sp:uch; begin clrscr; write('Vvedite kolichestvo uchenikov:');readln(n); for i:=1 to n do begin write('familia: ');readln(sp[i].fam); write('ocenka 1: ');readln(sp[i].ocen1); write('ocenka 2: ');readln(sp[i].ocen2); sp[i].sr_bl:=(sp[i].ocen1+sp[i].ocen2)/2; end; k1:=0; for i:=1 to n do if sp[i].ocen1=5 then begin k1:=k1+1; end; k2:=0; for i:=1 to n do if (sp[i].ocen1=5)and(sp[i].ocen2=5) then begin k2:=k2+1; end; writeln('Pervaia rabota= ',k1); writeln('Obe raboty= ',k2); Srtr(n,sp); writeln; writeln('Otsortirovanny spisok:'); writeln; for i:=1 to n do begin writeln(sp[i].fam:8,sp[i].ocen1:3,sp[i].ocen2:3,sp[i].sr_bl:5:1); end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: 8-ой класс) Ответ отправлен: 18.03.2008, 22:57 Оценка за ответ: 4

Вопрос № 128.009

Написать прогрмму. Которая будет редактировать файл .txt, а именно убирать слова больше 8-и знаков и меньше 4-х, а затем сохранять файл пример: lamer hello abrakadabra live game щ0 xax т.е xax щ0 abrakadabra должны удалится И вобще реально ли это организовать? Всем заранее спасибо.

Отправлен: 18.03.2008, 21:14 Вопрос задал: Petrosyan Evgenievich (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Николай Владимирович / Н.В. Здравствуйте, Petrosyan Evgenievich! Программа в приложении. Удачи! Приложение: const filename = 'file.txt'; var f, f1 : text; s : string; begin Assign(f, filename); Reset(f); rename(f,'_'+filename); Assign(f1, filename); ReWrite(f1); while not eof(f) do begin ReadLn(f,s); if not((length(s)<4)or(length(s)>8)) then WriteLn(f1,s); end; erase(f); Close(f); Close(f1); end.

Ответ отправил: Николай Владимирович / Н.В. (статус: Профессионал) Россия, Москва WWW: nvsoft.org ICQ: 420720 ---- Ответ отправлен: 18.03.2008, 21:33

Отвечает: Кудинов Антон Павлович !!! Здравствуйте, Petrosyan Evgenievich! procedure trans(fn:string); var fs,fd:text; s:string; begin assign(fs,fn); assign(fd,'out.txt'); reset(fs); rewrite(fd); while not { oef } eof(fs) do begin readln(fs,s); if length(s) in [4..8] then writeln(fd,s); end; close(fs); close(fd); end; без проверки Исправлена опечатка. Результат выводится в другой файл, а не в исходный. ----- ∙ Отредактировал: Николай Владимирович / Н.В. (Профессионал) ∙ Дата редактирования: 18.03.2008, 22:04

Ответ отправил: Кудинов Антон Павлович (статус: 2-ой класс) Ответ отправлен: 18.03.2008, 21:57

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