Вопрос № 169170:
   

   Дан двумерный массив размером 12х12. Найти среднеарифметическое отрицательных чисел.
   

   Отправлен: 09.06.2009, 18:36

   Вопрос задал: Иванов Виктор Олегович, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

    Отвечает _Ayl_, 5-й класс :

    Здравствуйте, Иванов Виктор Олегович.

Программа в Приложении    
     

     Приложение:

     { Дан двумерный массив размером 12х12. Найти среднеарифметическое отрицательных чисел }
Const
  cMaxIndex = 12;

Type
  TRange = 1..cMaxIndex;
  TArray = array [TRange, TRange] of Real;
  TFile  = file of Real;

Var
  a : TArray;
  m : Real;

Procedure SaveArray (a : TArray; fname : openstring);
var
  i, j : TRange;
  f : TFile;

begin
  Assign (f, fname); Rewrite (f);
  for i := 1 to cMaxIndex do
    for j := 1 to cMaxIndex do
      write (f, a [i, j]);
  Close (f);
end;

Procedure LoadArray (var a : TArray; fname : openstring);
var
  i, j : TRange;
  f : TFile;

begin
  Assign (f, fname); Reset (f);
  for i := 1 to cMaxIndex do
    for j := 1 to cMaxIndex do
      read (f, a [i, j]);
  Close (f);
end;

Procedure InputArray (var a : TArray);
var
  i, j : TRange;
  s : string;

begin
  writeln (\'Введите элементы массива:\');
  for i := 1 to cMaxIndex do
    for j := 1 to cMaxIndex do
    begin
      write (\'Элемент a [\', i, \', \', j, \'] --> \');
      readln (a [i, j]);
  end;

  write (\'Введите имя файла для сохранения или "-" для продолжения: \');
  readln (s);
  if s [1] <> \'-\' then SaveArray (a, s);
end;

Procedure GetArray (var a : TArray);
var
  s : string;

begin
  write (\'Введите имя файла для считывания или "-" для ручного ввода массива: \');
  readln (s);
  if s [1] = \'-\' then InputArray (a) else LoadArray (a, s);
end;

Procedure PrintArray (a : TArray);
var
  i, j : TRange;

begin
  for i := 1 to cMaxIndex do
  begin
    for j := 1 to cMaxIndex do
      write (\' \', a [i, j]:12:4);
    writeln;
  end;
end;

Function FindAvg (a : TArray) : Real;
var
  i, j : TRange;
  c : Byte;
  s : Real;

begin
  s := 0;
  c := 0;
  for i := 1 to cMaxIndex do
    for j := 1 to cMaxIndex do
      if a [i, j] < 0 then begin
        s := s + a [i, j];
        Inc (c);
      end;

  if c = 0 then FindAvg := 0
  else FindAvg := s / c;
end;

Begin
  GetArray (a);
  PrintArray (a);
  m := FindAvg (a);
  writeln (\'Среднее арифметическое отрицательных чисел равно: \', m:12:4);
End.
    

    Ответ отправил: _Ayl_, 5-й класс 

    Ответ отправлен: 09.06.2009, 14:09

Оценка ответа: 5
Комментарий к оценке:
Огромное спасибо) Все работает) Благодарю Вас! Вы меня так выручили.
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169171:
   

   Здравствуйте. Помогите пожалуйста с решением вот этой задачи: Найти угол между векторами А(1..n) и В(1..n), используя формулу:

   

   Отправлен: 09.06.2009, 12:36

   Вопрос задал: POPOV_A_V_1, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

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

    Здравствуйте, POPOV_A_V_1!
Решение задачи в приложении.    
     

     Приложение:

     uses crt;
const nmax=20;{максимальный размер векторов}
var a,b:array[1..nmax] of real;
    n,i:byte;
    sk,la,lb,ks,ug:real;
begin
clrscr;
randomize;
repeat
write(\'Размер векторов n=\');
readln(n);
until n in [2..nmax];{проверяем диапазон}
writeln(\'Вектор А:\');
for i:=1 to n do
 begin
  a[i]:=10*random-4;
  write(a[i]:5:1);
 end;
writeln;
writeln(\'Вектор B:\');
for i:=1 to n do
 begin
  b[i]:=10*random-4;
  write(b[i]:5:1);
 end;
writeln;
write(\'Длина вектора А=\');
la:=0;
for i:=1 to n do
la:=la+sqr(a[i]);
la:=sqrt(la);
writeln(la:0:3);
write(\'Длина вектора B=\');
lb:=0;
for i:=1 to n do
lb:=lb+sqr(b[i]);
lb:=sqrt(lb);
writeln(lb:0:3);
write(\'Скалярное произведение=\');
sk:=0;
for i:=1 to n do
sk:=sk+a[i]*b[i];
writeln(sk:0:3);
ks:=sk/(la*lb);
writeln(\'Косинус(ф)=\',ks:0:3);
ug:=arctan(sqrt(1-sqr(ks))/ks);
writeln(\'Угол между векторами=\',ug:0:3);
readln
end.
    

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

    Ответ отправлен: 09.06.2009, 18:15
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169172:
   

   Дана матрица А размером m x n. Определить  k - количество особых элементов массива А, считая его элемент особым, если он больше суммы остальных элементов его столбца
   

   Отправлен: 09.06.2009, 18:38

   Вопрос задал: Иванов Виктор Олегович, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

    Отвечает _Ayl_, 5-й класс :

    Здравствуйте, Иванов Виктор Олегович!

Решение в приложении    
     

     Приложение:

     {
 Дана матрица А размером m x n.
 Определить k - количество особых элементов массива А,
 считая его элемент особым, если он больше суммы
 остальных элементов его столбца
}
{$R-}
Type
  PArray = ^TArray;
  TArray = array [1..1] of Integer;

  TFile  = file of Integer;

Const
  cColumnFlag = false;
  cRowFlag    = true;

  cCurArray   = cColumnFlag;

Var
  a : PArray;
  n, m : Integer;
  i : Integer;
  c : Integer;

Function getIndex (i : Integer; j : Integer; n : Integer; m : Integer) : Integer;
begin
  if cCurArray then
    getIndex := (i - 1) * m + (j - 1)
  else
    getIndex := (j - 1) * n + (i - 1);
end;

Function AllocateArray (n : Integer; m : Integer) : PArray;
var
  a : PArray;

begin
  GetMem (a, (n * m) * sizeof (Integer));
  AllocateArray := a;
end;

Procedure FreeArray (a : PArray; n : Integer; m : Integer);
begin
  FreeMem (a, (n * m) * sizeof (Integer));
end;

Procedure SaveArray (a : PArray; n : Integer; m : Integer; fname : openstring);
var
  i, j : Integer;
  f : TFile;

begin
  Assign (f, fname); Rewrite (f);
  write (f, n, m);
  for i := 1 to n do
    for j := 1 to m do
      write (f, a^ [getIndex (i, j, n, m)]);
  Close (f);
end;

Procedure LoadArray (var a : PArray; var n : Integer; var m : Integer; fname : openstring);
var
  i, j : Integer;
  f : TFile;

begin
  Assign (f, fname); Reset (f);
  read (f, n, m);
  a := AllocateArray (n, m);
  for i := 1 to n do
    for j := 1 to m do
      read (f, a^ [getindex (i, j, n, m)]);
  Close (f);
end;

Procedure InputArray (var a : PArray; var n : Integer; var m : Integer);
var
  i, j : Integer;
  s : string;

begin
  write (\'Введите количество строк массива: \'); readln (n);
  write (\'Введите количество столбцов массива: \'); readln (m);
  a := AllocateArray (n, m);
  writeln (\'Введите элементы массива:\');
  for i := 1 to n do
    for j := 1 to m do
    begin
      write (\'Элемент a [\', i, \', \', j, \'] --> \');
      readln (a^ [getIndex (i, j, n, m)]);
  end;

  write (\'Введите имя файла для сохранения или "-" для продолжения: \');
  readln (s);
  if s [1] <> \'-\' then SaveArray (a, n, m, s);
end;

Procedure GetArray (var a : PArray; var n : Integer; var m : Integer);
var
  s : string;

begin
  write (\'Введите имя файла для считывания или "-" для ручного ввода массива: \');
  readln (s);
  if s [1] = \'-\' then InputArray (a, n, m) else LoadArray (a, n, m, s);
end;

Procedure PrintArray (a : PArray; n : Integer; m : Integer);
var
  i, j : Integer;

begin
  for i := 1 to n do
  begin
    for j := 1 to m do
      write (\' \', a^ [getIndex (i, j, n, m)]:4);
    writeln;
  end;
end;

Function HaveSpecial (a : PArray; n : Integer; c : Integer) : Integer;
var
  i : Integer;
  s : Integer;
  ind : Integer;

begin
  HaveSpecial := 0;
  s := 0;
  ind := getIndex (c, 1, n, 1);  { кол-во столбцов не важно, т.к. массив организован "по столбцам" }
  for i := ind to ind + n - 1 do inc (s, a^ [i]);

  for i := ind to ind + n - 1 do
    if a^ [i] > s - a^ [i] then begin
      HaveSpecial := 1;
      break; { двух особых элементов в колонке быть не может }
  end;
end;

Begin
  GetArray (a, n, m);
  PrintArray (a, n, m);

  c := 0;
  for i := 1 to m do
    Inc (c, HaveSpecial (a, n, i));

  writeln (\'Количество особых элементов массива равно \', c);

  FreeArray (a, n, m);
End.

    

    Ответ отправил: _Ayl_, 5-й класс 

    Ответ отправлен: 09.06.2009, 19:41

Оценка ответа: 5
Комментарий к оценке:
Огромное Вам спасибо! вы меня так выручаете, благодарю Вас! 
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169173:
   

   Дан двумерный массив, содержащий 12 строк и 14 столбцов. Вывести только отрицательные элементы массива по строчно.
   

   Отправлен: 09.06.2009, 18:39

   Вопрос задал: Иванов Виктор Олегович, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

    Отвечает _Ayl_, 5-й класс :

    Здравствуйте, Иванов Виктор Олегович.

Программа в приложении    
     

     Приложение:

     { Дан двумерный массив, содержащий 12 строк и 14 столбцов. Вывести только отрицательные элементы массива по строчно }
Const
  cMaxRow = 12;
  cMaxCol = 14;

Type
  TArrayType = Integer;
  TRangeRow = 1..cMaxRow;
  TRangeCol = 1..cMaxCol;
  TArray = array [TRangeRow, TRangeCol] of TArrayType;
  TFile  = file of TArrayType;

Var
  a : TArray;

Procedure SaveArray (a : TArray; fname : openstring);
var
  i : TRangeRow;
  j : TRangeCol;
  f : TFile;

begin
  Assign (f, fname); Rewrite (f);
  for i := 1 to cMaxRow do
    for j := 1 to cMaxCol do
      write (f, a [i, j]);
  Close (f);
end;

Procedure LoadArray (var a : TArray; fname : openstring);
var
  i : TRangeRow;
  j : TRangeCol;
  f : TFile;

begin
  Assign (f, fname); Reset (f);
  for i := 1 to cMaxRow do
    for j := 1 to cMaxCol do
      read (f, a [i, j]);
  Close (f);
end;

Procedure InputArray (var a : TArray);
var
  i : TRangeRow;
  j : TRangeCol;
  s : string;

begin
  writeln (\'Введите элементы массива:\');
  for i := 1 to cMaxRow do
    for j := 1 to cMaxCol do
    begin
      write (\'Элемент a [\', i, \', \', j, \'] --> \');
      readln (a [i, j]);
  end;

  write (\'Введите имя файла для сохранения или "-" для продолжения: \');
  readln (s);
  if s [1] <> \'-\' then SaveArray (a, s);
end;

Procedure GetArray (var a : TArray);
var
  s : string;

begin
  write (\'Введите имя файла для считывания или "-" для ручного ввода массива: \');
  readln (s);
  if s [1] = \'-\' then InputArray (a) else LoadArray (a, s);
end;

Procedure PrintArray (a : TArray);
var
  i : TRangeRow;
  j : TRangeCol;

begin
  for i := 1 to cMaxRow do
  begin
    for j := 1 to cMaxCol do
      write (\' \', a [i, j]:4);
    writeln;
  end;
end;

Procedure PrintNegative (a : TArray);
var
  i : TRangeRow;
  j : TRangeCol;

begin
  for i := 1 to cMaxRow do
  begin
    for j := 1 to cMaxCol do
      if a [i, j] < 0 then
        write (\' \', a [i, j]:4);
    writeln;
  end;
end;

Begin
  GetArray (a);
  writeln (\'Обрабатываемый массив:\');
  PrintArray (a);
  writeln (\'Отрицательные элементы массива:\');
  PrintNegative (a);
End.
    

    Ответ отправил: _Ayl_, 5-й класс 

    Ответ отправлен: 10.06.2009, 10:09

Оценка ответа: 5
Комментарий к оценке:
Огромное спасибо! Все работет! Благодарю Вас! Вы меня так выручили) 
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169185:
   

   Помогите написать программу, реализующую рисование квадрата, заданного центральной точкой и стороной.
   

   Отправлен: 09.06.2009, 15:18

   Вопрос задал: Семенов Алексей Анатольевич, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

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

    Здравствуйте, Семенов Алексей Анатольевич!
Решение задачи в приложении.    
     

     Приложение:

     uses crt,graph;
var gd,gm,x0,y0,a:integer;
procedure MyRectangle(x0,y0,a:integer);{процедура рисования прямоугольника по заданным условиям}
begin
rectangle(x0-(a div 2),y0-(a div 2),x0+(a div 2),y0+(a div 2));
end;
begin
clrscr;
gd:=detect;
repeat
write(\'Storona kvadrata=\');
readln(a);
until(a>0)and(a<=480);{проверяем чтоб квадрат не выходил за пределы экрана}
repeat
write(\'Koordinata X=\');
readln(x0);
until(x0>a div 2)and(x0<680-a div 2);
{чтоб центр был не ближе половины стороны квадрата от левого и правого краев экрана}
repeat
write(\'Koordinata Y=\');
readln(y0);
until(y0>a div 2)and(y0<480-a div 2);
{чтоб центр был не ближе половины стороны квадрата от верхнего и нижнего краев экрана}
initgraph(gd,gm,\'\');
MyRectangle(x0,y0,a);
readln;
closegraph
end.


    

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

    Ответ отправлен: 09.06.2009, 16:56

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

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169199:
   

   Помогите дорогие эксперты решить несколько задач
1..Строки.
Дана строка, содержащая текст. Провести частотный анализ текста, т.е. указать (в %), сколько раз встречается та или иная буква.
2.Создать запись, содержащую поля: фамилия, имя, дата рождения. Вывести на экран список учеников, фамилии которых начинаются на букву А, с указанием имени и даты рождения; фамилию самого младшего из учеников.
3.Составить программу – тестирование по истории (10 вопросов; 4 варианта ответов к каждому вопросу; выставление
итоговой оценки с рекомендациями). Тестовые задания должны выбираться из файла во время работы программы.

   

   Отправлен: 09.06.2009, 19:31

   Вопрос задал: Mandrigin Alex Lvovich, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

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

    Здравствуйте, Mandrigin Alex Lvovich!
Решение задачи №1 в приложении. Написал 2 варианта, первый только для букв, второй для всех символов, вдруг в условии неточность.    
     

     Приложение:

     1.Только буквы.
uses crt;
const bk=[\'A\'..\'Z\',\'a\'..\'z\',\'А\'..\'п\',\'р\'..\'ё\'];{все буквы}
var s:string;
    a:array[byte] of byte;{массив встречаемости символов в шт.}
    b:array[byte] of char;{массив символов}
    i,j,n,k:byte;
begin
clrscr;
writeln(\'Vvedite text:\');
readln(s);
n:=length(s);
k:=0;
for i:=1 to n do
if s[i] in bk then k:=k+1;{посчитаем сколько всего букв в строке}
for i:=1 to 255 do a[i]:=0;{обнулим массив количеств}
for i:=1 to 255 do{проверяем все символы}
for j:=1 to n do{ищем их в строке}
if chr(i)=s[j] then a[i]:=a[i]+1;{нашли, увеличиваем количество в соответствующей коду символа ячейке массива}
writeln(\'Chastota bukv:\');
j:=0;
for i:=1 to 255 do{проверяем массив встречаемости}
if (a[i]>0)and(chr(i)in bk) then{если не ноль и буква}
 begin
  writeln(chr(i),\' - \',round(a[i]*100/k),\'%\');{выводим его процент}
  j:=j+1;{считаем строки}
  if j mod 24=0 then readln;{через каждые 24 задержка}
 end;
readln
end.
2.Все символы.
uses crt;
var s:string;
    a:array[byte] of byte;
    b:array[byte] of char;
    i,j,n:byte;
    c:char;
begin
clrscr;
writeln(\'Vvedite text:\');
readln(s);
n:=length(s);
for i:=1 to 255 do a[i]:=0;
for i:=1 to 255 do
for j:=1 to n do
if chr(i)=s[j] then a[i]:=a[i]+1;
writeln(\'Chastota simvolov:\');
j:=0;
for i:=1 to 255 do
if a[i]>0 then
 begin
  writeln(chr(i),\' - \',round(a[i]*100/n),\'%\');
  j:=j+1;
  if j mod 24=0 then readln;
 end;
readln
end.

    

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

    Ответ отправлен: 10.06.2009, 12:45
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169201:
   

   Уважаемые эксперты, помогите решить задачу)))
дана целочисленная матрица х(n*n),y(k*k),состоящвя из отрицательных,нулевых и положительных элементов.Составить вектор из min положительных и усредненных элементов каждой строки,упорядочить их по неубыванию.
   

   Отправлен: 09.06.2009, 19:50

   Вопрос задал: fedor k, Х Заблокирован 

   Всего ответов: 1

   Страница вопроса >>
   

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

    Здравствуйте, fedor k!
Решение задачи в приложении.    
     

     Приложение:

     uses crt;
const nmax=20;{максимальный размер матриц}
type matr=array[1..nmax,1..nmax] of integer;{тип матриц}
     mas=array[1..nmax] of integer;{тип векторов}
procedure Vvod(var mt:matr;var n:byte;c:char);{создание и вывод матрицы на экран}
var i,j:byte;
begin
writeln(\'Матрица \',c);
repeat
write(\'Размер=\');
readln(n);
until n in [1..nmax];{проверка диапазона}
for i:=1 to n do
 begin
  for j:=1 to n do
   begin
    mt[i,j]:=random(10)-2;{целые числа от -2 до 7}
    write(mt[i,j]:4);
   end;
  writeln;
 end;
end;

procedure Sort(var v:mas; n:byte);{сортировка обменом по неубывынию}
var i,j:byte;
    b:integer;
begin
writeln(\'Отсортированный по неубыванию:\');
for i:=1 to n-1 do
for j:=i+1 to n do
if v[i]>v[j] then
 begin
  b:=v[i];
  v[i]:=v[j];
  v[j]:=b;
 end;
for i:=1 to n do
write(v[i]:4);
writeln;
end;

procedure VecMin(mt:matr;n:byte;var v,v1:mas);{создание и сортировка вектора минимальных в строках}
var i,j:byte;
    mn:integer;
begin
writeln(\'Вектор минимальных положительных строк:\');
for i:=1 to n do
 begin
  mn:=maxint;{мин=самому большому числу типа integer}
  for j:=1 to n do
  if (mt[i,j]<mn)and(mt[i,j]>0) then mn:=mt[i,j];{если меньше мин и положительное, то оно мин}
  v[i]:=mn;{запишем в вектор}
  write(v[i]:4);
 end;
writeln;
v1:=v;{создадим клон вектора}
Sort(v1,n);{отсортируем его}
end;

procedure VecSrd(mt:matr;n:byte;var v,v1:mas);{то же по усредненным в строках}
var i,j:byte;
    sr:integer;
begin
writeln(\'Вектор средних значений строк:\');
for i:=1 to n do
 begin
  sr:=0;;
  for j:=1 to n do
  sr:=sr+mt[i,j];{суммируем элементы строк}
  v[i]:=round(sr/n);{делим на количество, округляем и в вектор}
  write(v[i]:4);
 end;
writeln;
v1:=v;
Sort(v1,n);
end;
var x,y:matr;
    vx,vx1,vy,vy1:mas;
    n,k:byte;
begin
clrscr;
randomize;
Vvod(x,n,\'X\');
VecMin(x,n,vx,vx1);
VecSrd(x,n,vx,vx1);
readln;
clrscr;
Vvod(y,k,\'Y\');
VecMin(y,k,vy,vy1);
VecSrd(y,k,vy,vy1);
readln
end.
    

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

    Ответ отправлен: 11.06.2009, 08:02
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169202:
   

   Уважаемые эксперты, будьте добры решить задачу

даны вещественные квадратные матрицы x,y,z произвольных размеровсостоящих изотрицательных,нулевых и положительных элементов.элементы находящиеся выше побочной диагонали заненить на ноль,если последний элемент соответствующего столбца меньше нуля.Посчитать разность суммы элементовкахдого столбцадо и после замены.Составить вектор из полученых значений.Вывести исходную и модифицированную матрицу,а так же полученный вектор на экране.
   

   Отправлен: 09.06.2009, 20:02

   Вопрос задал: slavkakoz 

   Всего ответов: 1

   Страница вопроса >>
   

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

    Здравствуйте, slavkakoz!
Решение задачи в приложении.    
     

     Приложение:

     uses crt;
const nmax=20;{максимальный размер матриц}
type matr=array[1..nmax,1..nmax] of real;{тип матриц}
     mas=array[1..nmax] of real;{}
procedure Vvod(var mt:matr;var n:byte;c:char);{тип векторов}
var i,j:byte;
begin
repeat
write(\'Размер матрицы \',c,\'=\');
readln(n);
until n in [1..nmax];{проверка правильности диапазона}
for i:=1 to n do
for j:=1 to n do
mt[i,j]:=10*random-4;{вещественные числа из диапазона (-4,6)}
end;
procedure Vyvod(var mt:matr;n:byte);{вывод матриц на экран}
var i,j:byte;
begin
for i:=1 to n do
 begin
  for j:=1 to n do
  write(mt[i,j]:5:1);
  writeln;
 end;
end;
procedure Zamena(m1:matr;var m2:matr;n:byte);{замена нужных элементов на ноль}
var i,j:byte;
begin
for i:=1 to n do
for j:=1 to n do
if (m1[n,j]<0)and(j<n-i+1) then m2[i,j]:=0
{если последний элемент столбца <0 и данный элемент выше побочной диагонали, то ноль}
else m2[i,j]:=m1[i,j];{иначе переписываем элементы исходной матрицы}
end;
procedure Vector(m1,m2:matr;n:byte;var v:mas;c:char);{создание вектора}
var i,j:byte;
    sm1,sm2:real;
begin
writeln(\'Вектор \',c);
for j:=1 to n do
 begin
  sm1:=0;sm2:=0;
  for i:=1 to n do
   begin
    sm1:=sm1+m1[i,j];{сумма в столбце первой матрицы}
    sm2:=sm2+m2[i,j];{сумма в столбце второй матрицы}
   end;
  v[j]:=sm1-sm2;{разность записываем в вектор}
  write(v[j]:5:1);
 end;
end;

var x,y,z:matr;
    x1,y1,z1:matr;
    vx,vy,vz:mas;
    nx,ny,nz:byte;
begin
clrscr;
randomize;
Vvod(x,nx,\'X\');
writeln(\'Исходная матрица X:\');
Vyvod(x,nx);
Zamena(x,x1,nx);
writeln(\'Модифицированная матрица X:\');
Vyvod(x1,nx);
Vector(x,x1,nx,vx,\'X\');
readln;
clrscr;
Vvod(y,ny,\'Y\');
writeln(\'Исходная матрица Y:\');
Vyvod(y,ny);
Zamena(y,y1,ny);
writeln(\'Модифицированная матрица Y:\');
Vyvod(y1,ny);
Vector(y,y1,ny,vy,\'Y\');
readln;
clrscr;
Vvod(z,nz,\'Z\');
writeln(\'Исходная матрица Z:\');
Vyvod(z,nz);
Zamena(z,z1,nz);
writeln(\'Модифицированная матрица Z:\');
Vyvod(z1,nz);
Vector(z,z1,nz,vz,\'Z\');
readln
end.
    

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

    Ответ отправлен: 11.06.2009, 06:59
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169223:
   

   записать в файл N чисел,введенных с клавиатуры. считать из файла эти числа. поменять местами минимальное и максимальное значения среди этих чисел. вывести на экран полученную последовательность чисел.
   

   Отправлен: 10.06.2009, 09:33

   Вопрос задал: Vovandos 

   Всего ответов: 1

   Страница вопроса >>
   

    Отвечает _Ayl_, 5-й класс :

    Здравствуйте, Vovandos!

Решение в приложении    
     

     Приложение:

     {
 записать в файл N чисел, введенных с клавиатуры
 считать из файла эти числа
 поменять местами минимальное и максимальное значения среди этих чисел
 вывести на экран полученную последовательность чисел
}
Program Numbers;

Var
  f     : text;
  fname : string;
  N     : Word;
  i     : Word;
  a     : Integer;
  mn    : Integer;
  mx    : Integer;

Begin
  write (\'Введите имя файла: \'); readln (fname);
  Assign (f, fname); Rewrite (f);
  write (\'Введите N: \'); readln (N);

  writeln (f, N);
  
  write (\'    1 --> \'); readln (a);
  writeln (f, a);
  mn := a;
  mx := a;
  
  for i := 2 to N do
  begin
    write (i:5, \' --> \'); readln (a);
    writeln (f, a);
    if a < mn then mn := a
    else if a > mx then mx := a;
  end;
  close (f);
  writeln (\'Файл записан\');
  writeln (\'Минимальное число равно \', mn);
  writeln (\'Максимальное число равно \', mx);
  Reset (f);
  readln (f, N);
  writeln;
  writeln (\'Обрабатывается \', N, \' чисел:\');
  for i := 1 to N do
  begin
    readln (f, a);
    if a = mn then a := mx
    else if a = mx then a := mn;
    write (\' \', a:5);
  end;
  close (f);
End.

    

    Ответ отправил: _Ayl_, 5-й класс 

    Ответ отправлен: 10.06.2009, 10:32
    

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169226:
   

   Словом будем называть группу символов, отдельную от других символов пробелом или запятой. В произвольной строке поменять местами первое и последнее слово.
   

   Отправлен: 10.06.2009, 10:03

   Вопрос задал: robocop2000 

   Всего ответов: 1

   Страница вопроса >>
   

    Отвечает Micren, Практикант :

    Здравствуйте, robocop2000.
В строке первым словом считал все, что находится до первого разделителя. Последним, соответственно, все, что находится после последнего разделителя.
Код:

program Pascal_169226;

var
 str,fWord,lWord:String;
 fDelim,lDelim:Integer;
begin
 {*
Вводим строку *}
 WriteLn('Input string:');
 ReadLn(str);
 {* Позиция первого разделителя *}
 fDelim:=1;
 {* Позиция последнего разделителя *}
 lDelim:=Length(str);
 {* Ищем первый разделитель *}
 while fDelim<=lDelim do begin
  if (str[fDelim]=',') or (str[fDelim]=' ') then begin
   break;
  end;
  Inc(fDelim);
 end;
 {* Ищем последний разделитель *}
 while fDelim<=lDelim do begin
  if (
 str[lDelim]=',') or (str[lDelim]=' ') then begin
   break;
  end;
  Dec(lDelim);
 end;

 if fDelim>lDelim then begin
  WriteLn('This is one word');
 end else begin
  {* Копируем первое слово *}
  fWord:=copy(str,1,fDelim-1);
  {* Копируем последнее слово *}
  lWord:=copy(str,lDelim+1,Length(str)-lDelim);
  {* Собираем новую строку *}
  str:=lWord+copy(str,fDelim,lDelim-fDelim+1)+fWord;
  {* Выводим результат *}
  WriteLn('Result
string:');
  WriteLn(str);
 end;
 ReadLn;
end.

Пример:
Код:

Input string:
This is a test string
Result string:
string is a test This
    
    

    Ответ отправил: Micren, Практикант 

    Ответ отправлен: 10.06.2009, 11:22

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

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

   

   
   Вопрос № 169231:
   

   Здравствуйте! Помогите добавить процедуру считывания матрицы из файла в данной программе:
Код:
uses crt;

type
     PtrStr = ^Str;
     Str = array [1..1] of integer;

     PtrMatr = ^Matr;
     Matr = array [1..1] of PtrStr;

var
     matrica: PtrMatr;

    razmer, i, j: integer;

procedure CreateMatr;

 begin
    write ('razmernost matricy: ');
    readln(razmer);

    getmem(matrica, razmer*SizeOf(PtrStr));

    for i:=1 to razmer do
    getmem(matrica^[i], razmer*SizeOf(integer));

    writeln('vvodim elementy:');
    for i:=1 to razmer do
        for j:=1 to razmer do
            readln(matrica^[i]^[j]);

    end;

    procedure destroymatri
 x;
    begin

    for i:=1 to razmer do
    freemem(matrica^[i], razmer*SizeOf(integer));

    freemem(matrica, razmer*SizeOf(PtrStr));


    end;

    procedure otobrajenie;
    begin
     for i:=1 to razmer do
      begin
        writeln;
        for j:=1 to razmer do
           write(matrica^[i]^[j]:5);
      end;
      writeln;
     end;


 procedure sortirovka;
    var buffer1, buffer2, buffer3: integer;
    begin
    buffer3:=1;

     for i:=1 to razmer do
      begin
       buffer1:= matrica^[i]^[1];
       buffer2:= matrica^[i]^[razmer+1-i];
       for j:=0 to razmer-1 do
          begin
          if matrica^[i]^[j+1] <= buffer1  then
            begin
            buffer3:=j+1;
            buffer1:=matrica^[i]^[j+1];
            end;
            matrica^[i]^[buffer3]:=buffer2;
            matrica^[i]^[razmer+1-i]:=buffer1;
          end;
     
   end;
      end;

begin

 clrscr;
 CreateMatr;
 otobrajenie;
 sortirovka;
 otobrajenie;
 destroymatrix;
 readln;
end.
   

   Отправлен: 10.06.2009, 10:57

   Вопрос задал: Alex12, Посетитель 

   Всего ответов: 1

   Страница вопроса >>
   

    Отвечает _Ayl_, 5-й класс :

    Здравствуйте, Alex12.

Код в приложении.
Имеет смысл вынести создание массива в отдельную подпрограмму, тогда в процедурах ручного ввода и считывания из файла останутся только вызовы этой подпрограммы.
Ну и до кучи прилагаю код процедуры записи матрицы в текстовый файл.    
     

     Приложение:

     procedure LoadMatr;
var
  fname : string;
  f : text;

begin
  write (\'file name: \'); readln (fname);
  Assign (f, fname); Reset (f);
  readln (f, razmer);  { размер матрицы задается в первой строке файла }
  getmem (matrica, razmer*SizeOf(PtrStr));
  for i:=1 to razmer do
    getmem (matrica^[i], razmer*SizeOf(integer));

  { считываем элементы из файла. Элементы располагаются в файле построчно }
  for i:=1 to razmer do
    for j:=1 to razmer do
      read (f, matrica^[i]^[j]);
end;

procedure SaveMatr;
var
  fname : string;
  f : text;

begin
  write (\'file name: \'); readln (fname);
  Assign (f, fname); Rewrite (f);
  writeln (f, razmer);  { размер матрицы задается в первой строке файла }

  { записываем элементы в файл. Элементы располагаются в файле построчно }
  for i:=1 to razmer do
  begin
    for j:=1 to razmer do
      write (f, \' \', matrica^[i]^[j]);
    writeln (f);
  end;
end;

    

    Ответ отправил: _Ayl_, 5-й класс 

    Ответ отправлен: 10.06.2009, 11:26

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

    

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

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

    
    
    
    
    
    

    
Отправить WebMoney:
    
    Неплохо (25 руб.)
    Хорошо (35 руб.)
    Отлично (50 руб.)
    БЛЕСТЯЩЕ! (75 руб.)
     
    
    
    
    
Вам помогли? Пожалуйста, поблагодарите эксперта за это!
    
    

 

 Нам очень важно Ваше мнение об этом выпуске рассылки. Вы можете оценить этот выпуск по пятибалльной шкале, пройдя по ссылке:

 оценить выпуск >>
 

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

 
Скажите "спасибо" эксперту, который помог Вам!

 
 Отправьте СМС-сообщение с тестом #thank НОМЕР_ОТВЕТА

 на короткий номер 1151 (Россия)

 Номер ответа и конкретный текст СМС указан внизу каждого ответа.
 

 Полный список номеров >>
 
 

 
 * Стоимость одного СМС-сообщения от 7.15 руб. и зависит от оператора сотовой связи.
 (полный список тарифов)

 ** При ошибочном вводе номера ответа или текста #thank услуга считается оказанной, денежные средства не возвращаются.

 *** Сумма выплаты эксперту-автору ответа расчитывается из суммы перечислений на портал от биллинговой компании.
 

 
 
 

 
© 2001-2009, Портал RFpro.ru, Россия
Авторское право: ООО "Мастер-Эксперт Про"
Автор: Калашников О.А. | Программирование: Гладенюк А.Г.
Хостинг: Компания "Московский хостер"
Версия системы: 2009.6.1 RC от 10.06.2009