1. Вычислить сумму элементов трех матриц А(3,3),В(3,4),С(4,4).(процедуры и функции).
2. Задано некоторое множество М и множество Т того же типа, подсчитать сколько элементов из множеств Т и М совпадают.

Отправлен: 30.05.2009, 11:00
Вопрос задал: x-cite, Посетитель
Всего ответов: 1
Страница вопроса >>

Приложение:
1. Вычислить сумму элементов трех матриц А(3,3),В(3,4),С(4,4).(процедуры и функции). uses crt; type matr=array[1..4,1..4] of integer;{тип матриц} procedure Vvod(var mt:matr;x,y:byte;c:char);{создание и вывод на экран} var i,j:byte; begin writeln(\'Matrica \',c); for i:=1 to x do begin for j:=1 to y do begin mt[i,j]:=random(10); write(mt[i,j]:3); end; writeln; end; end; function Summ(mt:matr;x,y:byte):integer;{подсчет суммы элементов} var i,j:byte; s:integer; begin s:=0; for i:=1 to x do for j:=1 to y do s:=s+mt[i,j]; Summ:=s; end; var a,b,c:matr; begin clrscr; Vvod(a,3,3,\'A\');{создаем матрицу заданных размеров, выводим на экран и считаем сумму, 3 раза} writeln(\'Summa elementov=\',Summ(a,3,3)); Vvod(b,3,4,\'B\'); writeln(\'Summa elementov=\',Summ(b,3,4)); Vvod(c,4,4,\'C\'); writeln(\'Summa elementov=\',Summ(c,4,4)); readln end. 2. Задано некоторое множество М и множество Т того же типа, подсчитать сколько элементов из множеств Т и М совпадают. uses crt; var m,t,res:set of byte;{заданные и результирующее множества типа byte (числа от 0 до 255)} i,k:byte; begin clrscr; m:=[1,5,6,48,23,4,9,21];{заполняем множества(можно и рандомом)} t:=[5,21,1,4,84,123]; writeln(\'Mnozestvo M:\');{выведем их на экран} for i:=0 to 255 do if i in m then write(i,\' \'); writeln; writeln(\'Mnozestvo T:\'); for i:=0 to 255 do if i in t then write(i,\' \'); writeln; res:=m*t;{выполним пересечение(умножение) множеств, в нем будут только совпадающие} k:=0; writeln(\'Sovpadayut elementy:\'); for i:=0 to 255 do{выведем его на экран и посчитаем число элементов} if i in res then begin write(i,\' \'); k:=k+1; end; writeln; write(\'Vsego sovpadaet=\',k); readln end.

Ответ отправил: Пупорев Юрий Борисович, Специалист
Ответ отправлен: 30.05.2009, 12:18

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250063 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Даны a,b,c,x.Выяснит пройдет ли кирпич с ребрами a,b,c в квадратное отверстие со стороной x.Кирпич надо засовывать так,чтобы ребра были параллельны или перпендикулярны.

Отправлен: 30.05.2009, 11:03
Вопрос задал: Zoyaya, Посетитель
Всего ответов: 2
Страница вопроса >>

Приложение:
uses crt; var a,b,c,x,res:integer; begin clrscr; write(\'a=\');readln(a); write(\'b=\');readln(b); write(\'c=\');readln(c); write(\'x=\');readln(x); res:=ord(a<x)+ord(b<x)+ord(c<x); {если условие выполняется, значение=true, ord(true)=1, если нет, ord(false)=0} if res>=2 then write(\'Yes!\'){если условие выполняется хотя бы 2 раза, т.е. хотя бы 2 стороны меньше размеров квадрата, то пройдет, иначе нет. Если пренебречь трением, то можно вместо <x написать <=x} else write(\'No!\'); readln end.

Ответ отправил: Пупорев Юрий Борисович, Специалист
Ответ отправлен: 30.05.2009, 11:54

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250060 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Ответ отправил: Yusupov Roman, 1-й класс
Ответ отправлен: 30.05.2009, 16:42

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250067 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Доброго времени суток. Если задача которая рисует движение математического маятника.
1. при вводе некоторых значений она подвешивает компьютер после некторого времени работы.
2. Если можно оптимизируйте программу
3. напишите коментарии что за что отвечает, ибо рисование в паскале на очень плачевном уровне.
Надеюсь достаточно понятно описал проблему. Если имеются какие -нибудь вопросы, спрашивайте

Отправлен: 30.05.2009, 16:45
Вопрос задал: Bel9illi, Посетитель
Всего ответов: 1
Страница вопроса >>

Приложение:
uses Graph,Crt; var x0,y0,x,y,h,l,z,d,e:integer; ShowBall:pointer; procedure OutPutBall(aa:integer); var bb:integer; begin {запоминает текущее значение} bb:=aa; repeat{} x:=x0-round(l*cos(2*pi*(270+d*bb)/360)); y:=Y0-round(l*sin(2*pi*(270+d*bb)/360)); {выводим изображение на экран} SetColor(white); MoveTo(x0,y0); LineTo(x,y); PutImage(x-6,y-6,ShowBall^,NormalPut); {задержка показа изображения} Delay(10000); {стираем изображение на экране} PutImage(x-6,y-6,ShowBall^,XorPut); SetColor(black); MoveTo(x0,y0); LineTo(x,y); dec(bb); until abs(bb)=aa;{} end; begin {вводим длину нити} repeat write(\'enter ball l:=\'); readln(l); until l>20; {вводим отклонение шара} repeat write(\'enter ball h:=\'); readln(h); until (h<l)and(h>5); {пересчитываем отклонение в угол} h:=round(360*ArcTan(h/sqrt(sqr(l)-sqr(h)))/(2*pi)); repeat{вводим затухание 0-незатухающие колебания, 1-затухающие колебания} write(\'enter ball z:=\'); readln(z); until (z=0 )or (z=1); {pfgecrftv uhfabre} d:=detect; InitGraph(d,e,\'\'); if GraphResult<>0 then begin{ошибка выходим} write(\'InitGaphError\'); ReadKey; end else begin {подгодовительная часть графического режима запоминаем изображение шара} ClearDevice; SetColor(green); SetFillStyle(1,green); FillEllipse(10,10,5,5); GetMem(ShowBall,ImageSize(4,4,16,16)); GetImage(4,4,16,16,ShowBall^); ClearDevice; {статическая часть программы в графическом режиме, рисуем платформу} SetColor(brown); SetFillStyle(1,brown); Bar(GetMaxX div 2 -20,0,GetMaxX div 2 +20,5); {координаты верхней-центральной части} x0:=GetMaxX div 2; Y0:=6; {напрвление} d:=1; repeat {выводим один цикл маятника} OutPutBall(h); {меняем направление} d:=-d; {после двух циклов вводим затухание} if d>0 then h:=h-z; {продолжаем пока не нажата любая клавиша, либо пока не достигнем нулевого угла} until KeyPressed or (h=0); ReadKey;{в любом случае считываем клавишу} FreeMem(ShowBall,ImageSize(4,4,16,16));{освобождаем память занятую под шар} CloseGraph; end; end. Украина, Киев
Тел.: +38-097-953-66-19
Адрес: Украина, Киев

-----
Итерация от человека. Рекурсия — от Бога. — Л. Питер Дойч

Ответ отправил: Зенченко Константин Николаевич, Модератор
Ответ отправлен: 01.06.2009, 23:16

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250213 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

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

Буду очень благодарен. Заранее спасибо

Отправлен: 30.05.2009, 21:57
Вопрос задал: Лямин Михаил, 1-й класс
Всего ответов: 2
Страница вопроса >>

const
  N = 10;

var
  a: array [1..N] of integer;
  i: integer;
  f: boolean;

begin
  Write('Исходный массив: ');
  randomize;
  for i := 1 to N do
    begin
      a[i] := random(50);

     Write(a[i], ' ');
    end;
  f := true;
  i := 4;
  repeat
    if a[i] >= a[i - 2] then
      begin
        f := false;
        break;
      end;
    i := i + 2;
  until i > N;
  if f then
    Write('Образует')
  else
    Write('Необразует');
  ReadLn;
end.

const
  N = 10;

var
  a: array [1..N] of integer;
  i, min_i, mul: integer;

begin
  Write('Исходный массив: ');
  randomize;
  for i := 1 to N do
    begin
      a[i] := random(20) - 10;
      Write(a[i], ' ');
    end;
  min_i := 1;
  for i := 2 to N do
    if a[i] < a[min_i] then
      min_i := i;
  mul := 1;

 for i := min_i + 1 to N do
    if (a[i] mod 3 = 0) and (a[i] <> 0) then
      mul := mul * a[i];
  WriteLn;
  WriteLn('Ответ: ', mul);
  ReadLn;
end.

Ответ отправил: Абельхарисов Руслан/Marked One, Практикант
Ответ отправлен: 30.05.2009, 22:53

Оценка ответа: 5
Комментарий к оценке:
Спасибо огромное!

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250083 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Приложение:
№2. uses crt; const rz=[\',\',\';\',\':\',\'-\',\'.\',\'!\',\'?\',\'(\',\')\',\'[\',\']\',\'{\',\'}\'];{разделители слов} var s:string; c,bk:char; i,j,k,mx:byte; begin clrscr; writeln(\'Vvedite predlozenie:\'); readln(s); s:=\' \'+s;{добавим прбел в начало} for i:=1 to length(s) do if s[i] in rz then s[i]:=\' \';{заменим все разделители на пробелы} i:=2; mx:=0;{начнем со второго символа(первый пробел)} while i<=length(s)do{пока не конец строки} begin if (s[i-1]=\' \')and(s[i]<>\' \')then{если перед символом пробел, а он не пробел, начало слова} begin c:=s[i];{запомним символ} k:=1;{один есть} for j:=i+1 to length(s)do{смотрим строку дальше} if (s[j-1]=\' \')and(s[j]=c)then k:=k+1;{если еще раз этот символ первый в слове, считаем} if k>mx then{если их болше, чем предущий максимум} begin mx:=k;{это максимум} bk:=c;{запомним его} end; end; i:=i+1;{к следующему символу} end; write(\'Bukv=\',bk); readln end. №4. uses crt; const gl=[\'A\',\'E\',\'I\',\'O\',\'U\',\'Y\'];{гласные прописные латинские} var s:string; i,j,kg,ks:byte; c:char; mg,ms:set of char;{множества гласных и согласных} begin clrscr; writeln(\'Vvedite slovo:\'); readln(s); for i:=1 to length(s)do s[i]:=upcase(s[i]);{преобразуем малые латинские в большие} i:=1;kg:=0;ks:=0;{первый символ строки, нужных букв нет} mg:=[];ms:=[];{множества пустые} while i<=length(s)do{пока не конец строки} begin c:=s[i];{запоминаем символ} if (c in gl)and not(c in mg) then{если гласная, и ее еще нет в множестве} begin kg:=kg+1;{считаем} include(mg,c);{включаем в множество} end else if not(c in gl)and not(c in ms) then{то же с согласными} begin ks:=ks+1; include(ms,c); end; i:=i+1;{к следующему символу} end; if (kg>1)and(ks>1)then write(\'Yes!\'){если включений тех и других было больше 1, то можно} else write(\'No!\'); readln end.

Ответ отправил: Пупорев Юрий Борисович, Специалист
Ответ отправлен: 31.05.2009, 07:59

Оценка ответа: 5
Комментарий к оценке:

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250093 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Уважаемые эксперты помогите справиться с модулем

Реализовать в виде модуля набор подпрограмм для вычисления определителя матрицы
Матрицу описать следующим образом:

Const NMax=10;
Type Matrica=Array[1..NMax,1..NMax] of real;

заранее спасибо

Отправлен: 30.05.2009, 22:07
Вопрос задал: А.В.Мукулов, Посетитель
Всего ответов: 1
Страница вопроса >>

Приложение:
МОДУЛЬ. unit opred;{имя модуля=имя файла} interface{интерфейсная часть-модули, константы, типы, объявления подпрограмм} uses crt; const nmax=10; type Matrica=array [1..nmax,1..nmax] of real; procedure Vvod(var mt:matrica;var r:byte);{создание матрицы и вывод ее на экран} procedure Per(var mt:Matrica; k,r:byte;var p:byte);{перестановка строк, если главный элемент=0} function znak(p:byte):integer;{определение знака определителя} procedure opr(mt:Matrica;r:byte;var det:real);{вычисление определителя} implementation{раздел описания подпрограмм} procedure Vvod(var mt:matrica;var r:byte); var i,j:byte; begin repeat write(\'Vvedite poryadok matricy: \'); readln(r); until r in [1..nmax];{проверяем правильность введенного размера матрицы} writeln(\'Vvedite \',r*r,\' elementov matricy:\'); for i:=1 to r do for j:=1 to r do begin write(\'el[\',i,\',\',j,\']=\'); readln(mt[i,j]); end; clrscr; writeln(\'Ischodnaia matritsha:\'); for i:=1 to r do begin for j:=1 to r do write(mt[i,j]:6:2); writeln; end; end; procedure Per(var mt:Matrica; k,r:byte;var p:byte); var i,j:byte; z:real; begin z:=mt[k,k];{текущий главный элемент} i:=k;{индекс его строки} p:=0;{перестановок пока 0} for j:=k+1 to r do{ищем по строкам ниже текущей} begin if abs(mt[j,k])>z then{максимальный по модулю элемент в этом столбце} begin z:=abs(mt[j,k]); i:=j;{запоминаем номер строки} p:=p+1;{считаем количество перестановок} end; end; if i>k then{если есть такая строка ниже данной} for j:=k to r do{делаем обмен элементов строк} begin z:=mt[i,j]; mt[i,j]:=mt[k,j]; mt[k,j]:=z; end; end; function znak(p:byte):integer; begin if p mod 2=0 then znak:=1 {если число перестановок четное +1} else znak:=-1;{если нечетное -1} end; procedure opr(mt:Matrica;r:byte;var det:real); var k,i,j,p:byte; z:real; begin det:=1; for k:=1 to r do begin if mt[k,k]=0 then per(mt,k,r,p);{если главный элемент=0, перестановка} det:=znak(p)*det*mt[k,k];{меняем знак определителя} for j:=k+1 to r do{делаем преобразования и вычисления} begin z:=mt[j,k]/mt[k,k]; for i:=k to r do begin mt[j,i]:=mt[j,i]-z*mt[k,i]; end; end; end; end; end. ПРОГРАММА. program opredelitel; uses crt,opred;{подключаем наш модуль} var n:byte; a:Matrica; det:real; begin clrscr; Vvod(a,n);{создаем матрицу} opr(a,n,det);{считаем определитель} write(\'opr=\',det:0:2); readln end. Прикрепленный файл: загрузить >>

Ответ отправил: Пупорев Юрий Борисович, Специалист
Ответ отправлен: 31.05.2009, 06:40

Оценка ответа: 5

Как сказать этому эксперту "спасибо"?

Отправить SMS #thank 250091 на номер 1151 (Россия) | Еще номера >>

Отправить WebMoney: Неплохо (25 руб.) Хорошо (35 руб.) Отлично (50 руб.) БЛЕСТЯЩЕ! (75 руб.)

Вам помогли? Пожалуйста, поблагодарите эксперта за это!

подать вопрос экспертам этой рассылки >>