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

Выпуск № 646
от 09.05.2008, 05:05

Вопрос № 133.935

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

Отправлен: 24.04.2008, 12:42 Вопрос задал: Иванов Владимир Борисович (статус: 1-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Иванов Владимир Борисович! Решение первой задачи в приложении. Понял, что есть матрица строкового типа и в ней нужно отсортировать слова в столбцах по убыванию их длин. Я делал в таблице 3х3, чтобы меньше слов набирать, если нужно больше измените const n=?, если нужно прямоугольную матрицу, введите еще константу для столбцов m=?, и везде, где идет J, исправmте n на m. Приложение: №1. uses crt; const n=3; var a:array[1..n,1..n]of string[10]; i,j,k:integer; x:string; begin clrscr; for i:=1 to n do for j:=1 to n do {заполняем массив словами} begin write('a[',i,',',j,']='); readln(a[i,j]); end; clrscr; writeln('Ishodnaia matrica:'); {выводим его в виде таблицы} for i:=1 to n do begin for j:=1 to n do write(a[i,j]:11); writeln; end; readln; {сортируем по убыванию длины в столбцах} for j:=1 to n do for i:=1 to n-1 do for k:=1 to n-1 do if length(a[k,j])<length(a[k+1,j])then begin x:=a[k,j]; a[k,j]:=a[k+1,j]; a[k+1,j]:=x; end; writeln('Otsortirovannaia matrica:'); {выводим на экран} for i:=1 to n do begin for j:=1 to n do write(a[i,j]:11); writeln; end; readln; end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 24.04.2008, 18:20 Оценка за ответ: 4 Комментарий оценки: Всё намного проще: таблица, в этой задаче,есть-каждое новое слово по-просту начинается с новой строки и всё. Нет надобности создавать матрицу. В принципе - это было уточнено здесь-"в смысле каждое новое слово начинается с новой строки"-но возможно вы не совсем это правильно поняли. Извините за не совсем понятную формулировку.

Вопрос № 133.945

Уважаемые эксперты!помогите пожалуйста с решением: Выполнить обработку элементов прямоугольной матрицы А,имеющей N строк и М столбцов.Исключить из матрицы строку с номером L.Сомкнуть ряды.При этом самому при запуске программы задавать размеры матрицы и вводить элементы.

Отправлен: 24.04.2008, 13:41 Вопрос задал: Igor lukashov (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Попов Владимир Иванович Здравствуйте, Igor lukashov! Решение вашей задачи в приложении. Программа протестирована. Работает. Использованы три подпрограммы-процедуры : Ввода матрицы, Модификации матрицы с изъятием строки с указанным номером, Вывода результата. Работа модулей подпрограмм сопровождается служебными сообщениями. Предусмотрена проверка входных данных на ОДЗ. Задействован цикл с запросом на повторный запуск программы. Успехов. Приложение: {---------------------------------------------------------------------------} program Obrabotka_Matric; uses crt; const Nmax = 10; Mmax = 10; type Tmatrix = array[1..Nmax, 1..Mmax] of real; var A, B : Tmatrix; N, M, L : byte; procedure InputMatrix(var pN : byte; var pM : byte; var pA : Tmatrix); label L; var i, j : byte; begin L:writeln; write(' Input the amount of the matrix"s rows : N = '); readln(pN); write(' Input the amount of the matrix"s kolumns : M = '); readln(pM); if (pN < 2) or (pN > Nmax) or (pM < 2) or (pM > Mmax) then begin writeln(' Error !!! N & M must be >= 2 and < ', Nmax, ' or ', Mmax); goto L; end else begin writeln(' Input your matrix"s elements :'); for i := 1 to pN do begin for j := 1 to pM do begin write(' A[', i, ',', j, '] = '); readln(pA[i,j]); end; writeln; end; end; writeln(' Your matrix was successfully inputed !'); end; procedure Modification(var pL : byte; pN, pM : byte; var pA : Tmatrix; var pB : Tmatrix); label L; var i, j : byte; begin L:writeln; write(' Input the number of deleted line : L = '); readln(pL); if (pL < 1) or (pL > pN) then begin writeln(' Error !!! L must be >= 1 and <= ', pN); goto L; end else begin if (pL = 1) then for i := 2 to pN do for j := 1 to pM do pB[i-1,j] := pA[i,j] else if (pL = pN) then for i := 1 to pN-1 do for j := 1 to pM do pB[i,j] := pA[i,j] else begin for i := 1 to pL-1 do for j := 1 to pM do pB[i,j] := pA[i,j]; for i:= pL+1 to pN do for j := 1 to pM do pB[i-1,j] := pA[i,j]; end; end; writeln(' Your matrix was successfully modified !'); end; procedure OutputResult(pN, pM, pL : byte; var pA : Tmatrix; var pB : Tmatrix); var i, j : byte; begin writeln; writeln(' The initial matrix is - A :'); for i := 1 to pN do begin for j := 1 to pM do write(' ', pA[i,j]:5:2); writeln; end; writeln; writeln(' After deleted the line number L = ', pL, ', the modified matrix has been - B :'); for i := 1 to pN-1 do begin for j := 1 to pM do write(' ', pB[i,j]:5:2); writeln; end; writeln(' The program was successfully completed !'); end; function Exit : boolean; label L; var ans : char; begin L:writeln; writeln; write(' Do you want to start the program again ? (y/n) ---> '); readln(ans); if (ans = 'y') or (ans = 'Y') then Exit := false else if (ans = 'n') or (ans = 'N') then Exit := true else begin writeln(' Error !!! answer must be only <y> or <n>'); goto L; end; end; {---------------------------------------------------------------------------} begin clrscr; repeat writeln; InputMatrix(N, M, A); Modification(L, N, M, A, B); OutputResult(N, M, L, A, B); until Exit; end. {---------------------------------------------------------------------------} --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 5-ый класс) Ответ отправлен: 24.04.2008, 16:52 Оценка за ответ: 5 Комментарий оценки: Спасибо!Все решено на твердую 6-ку!)))

Вопрос № 133.955

создать программу которая решает следущую задачу 1. Информация о товаре магазина хранится в следующем порядке: на- именование товара, количество, цена продажи, дата поступления. Вывести на экран те товары, цена которых превышает введённую с клавиатуры.

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

Отвечает: Попов Владимир Иванович Здравствуйте, товарищ заказчик! В реализации вашей задачи использовано 4 подпрограммы : процедура ввода данных о товарах и организации соответствующего массива записей; процедура анализа данных с ключом в виде контрольной цены и формированием списка отобранных товаров с ценой, превышающей контрольную; процедура вывода отчёта о содержании основного и отобранного списка товаров; функция организации запроса на повторный запуск программы. Исходный код программы - в приложении. Максимальное число записей - 15, может быть изменено значением константы Nmax. Программа успешно протестирована в среде TMT Pascal. --------------------------------------------------------------------------------------------- Хочешь изучить программирование - пиши программы (Никлаус Вирт) --------------------------------------------------------------------------------------------- Успехов ! Приложение: program PriceList; {---------------------------------------------------------------------} uses crt; const Nmax = 15; {---------------------------------------------------------------------} type Tdata = record day : byte; month : byte; year : word; end; Trec = record name : string[50]; amount : word; price : real; data : Tdata; end; Tgoods = array[1..Nmax] of Trec; {---------------------------------------------------------------------} procedure Create_BD(var xN : byte; var xgoods : Tgoods); label L; var i : byte; begin L:writeln; write(' Input the amount of your records : N = '); readln(xN); if (xN < 2) or (xN > Nmax) then begin writeln(' Error !!! N must be >= 2 and <= ', Nmax); goto L; end else begin writeln; writeln(' Input the goods information list : '); for i := 1 to xN do begin writeln; writeln(' Record number ', i); writeln(' -----------------'); write(' The name of the goods - '); readln(xgoods[i].name); write(' The amount of the goods - '); readln(xgoods[i].amount); write(' The price of the goods - '); readln(xgoods[i].price); write(' The registration"s day - '); readln(xgoods[i].data.day); write(' The registration"s month - '); readln(xgoods[i].data.month); write(' The registration"s year - '); readln(xgoods[i].data.year); end; writeln(' Your Base od goods was successfully created !'); end; end; {---------------------------------------------------------------------} procedure Analysis_BD(xN : byte; var xgoods : Tgoods; var xcp : real; var xselect_goods : Tgoods; var xk : byte); var i, j : byte; begin writeln; write(' Input the control_price : '); readln(xcp); j := 1; for i := 1 to xN do begin if xgoods[i].price > xcp then begin xselect_goods[j].name := xgoods[i].name; xselect_goods[j].amount := xgoods[i].amount; xselect_goods[j].price := xgoods[i].price; xselect_goods[j].data.day := xgoods[i].data.day; xselect_goods[j].data.month := xgoods[i].data.month; xselect_goods[j].data.year := xgoods[i].data.year; j := j + 1; end; end; xk := j - 1; writeln(' The analysis of your base was successfully completed !'); end; {---------------------------------------------------------------------} procedure Output_Report(xN, xk : byte; xcp : real; var xgoods : Tgoods; xselect_goods : Tgoods); var i, j : byte; begin writeln; writeln(' The inputed base is :'); writeln(' ======================='); for i := 1 to xN do begin writeln; write(' ', i, '. ', xgoods[i].name); write(' - ', xgoods[i].amount, ' pieces'); write(' in price of $', xgoods[i].price:5:2); write(', registrated on ', xgoods[i].data.day); write('.', xgoods[i].data.month); write('.', xgoods[i].data.year); end; writeln; writeln; writeln(' The list of goods with price, more than $', xcp:5:2, ' is :'); writeln(' ------------------------------------------------------'); for j := 1 to xk do begin writeln; write(' ', j, '. ', xselect_goods[j].name); write(' - ', xselect_goods[j].amount, ' pieces'); write(' in price of $', xselect_goods[j].price:5:2); write(', registrated on ', xselect_goods[j].data.day); write('.', xselect_goods[j].data.month); write('.', xselect_goods[j].data.year); end; writeln; writeln(' The program was successfully completed !'); end; {---------------------------------------------------------------------} function Exit : boolean; label L; var ans : char; begin L:writeln; writeln; write(' Do you want to start the program again ? (y/n) ---> '); readln(ans); if (ans = 'y') or (ans = 'Y') then Exit := false else if (ans = 'n') or (ans = 'N') then Exit := true else begin writeln(' Error !!! answer must be only <y> or <n> !'); goto L; end; end; {---------------------------------------------------------------------} var goods, select_goods : Tgoods; control_price : real; N, k : byte; {=========================================} begin repeat clrscr; Create_BD(N, goods); Analysis_BD(N, goods, control_price, select_goods, k); Output_Report(N, k, control_price, goods, select_goods); until Exit; end. {=========================================} --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 5-ый класс) Ответ отправлен: 25.04.2008, 11:08

Вопрос № 133.957

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

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

Отвечает: Попов Владимир Иванович Здравствуйте, всё так же уважаемый заказчик! Вторая задача решена в том же духе, что и первая. Исходник в приложении. Удачи ! Приложение: {======================================} program PupilList; {---------------------------------------------------------------------} uses crt; const Nmax=35; {---------------------------------------------------------------------} type Tmarks=record subj1:byte; subj2:byte; subj3:byte; subj4:byte; subj5:byte; end; Trec=record sirname:string[30]; name:string[20]; fathername:string[30]; birth:word; class:string[5]; mark:Tmarks; end; Tpupils=array[1..Nmax] of Trec; Tlist=array[1..Nmax] of longint; {---------------------------------------------------------------------} procedure Create_BD(var xN:byte;var xpupil:Tpupils); label L; var i:byte; begin L:writeln; write(' Input the amount of your records : N = '); readln(xN); if (xN<2) or (xN>Nmax) then begin writeln(' Error !!! N must be >= 2 and <= ',Nmax); goto L; end else begin writeln; writeln(' Input the pupils information list : '); for i:=1 to xN do begin writeln; writeln(' Record number ',i); writeln(' -----------------'); write(' sirname - '); readln(xpupil[i].sirname); write(' name - '); readln(xpupil[i].name); write(' fathername - ');readln(xpupil[i].fathername); write(' birth - '); readln(xpupil[i].birth); write(' class - '); readln(xpupil[i].class); write(' mark 1 - '); readln(xpupil[i].mark.subj1); write(' mark 2 - '); readln(xpupil[i].mark.subj2); write(' mark 3 - '); readln(xpupil[i].mark.subj3); write(' mark 4 - '); readln(xpupil[i].mark.subj4); write(' mark 5 - '); readln(xpupil[i].mark.subj5); end; end; end; {---------------------------------------------------------------------} procedure Analysis_BD(xN:byte;var xpupil:Tpupils;var xselect_pupil:Tpupils;var xk:byte); var i,j:byte; level_list:Tlist; begin for i:=1 to xN do with xpupil[i].mark do level_list[i]:=round((subj1+subj2+subj3+subj4+subj5)/5); j:=1; for i:=1 to xN do begin if xpupil[i].mark.subj1 >= level_list[i] then begin xselect_pupil[j].sirname := xpupil[i].sirname; xselect_pupil[j].name := xpupil[i].name; xselect_pupil[j].fathername := xpupil[i].fathername; xselect_pupil[j].birth := xpupil[i].birth; xselect_pupil[j].class := xpupil[i].class; xselect_pupil[j].mark.subj1 := xpupil[i].mark.subj1; xselect_pupil[j].mark.subj2 := xpupil[i].mark.subj2; xselect_pupil[j].mark.subj3 := xpupil[i].mark.subj3; xselect_pupil[j].mark.subj4 := xpupil[i].mark.subj4; xselect_pupil[j].mark.subj5 := xpupil[i].mark.subj5; j:=j+1; end; end; xk:=j-1; writeln(' The analysis of your base was successfully completed !'); end; {---------------------------------------------------------------------} procedure Output_Report(xN,xk:byte;var xpupil:Tpupils;var xselect_pupil:Tpupils); var i, j : byte; begin writeln; writeln(' The inputed base is :'); writeln(' ======================='); for i := 1 to xN do begin write(' ',i,'. ',xpupil[i].sirname); write(' ', xpupil[i].name); write(' ', xpupil[i].fathername); write(', ', xpupil[i].birth); writeln(', ', xpupil[i].class,' class.'); write(' marks : '); write( xpupil[i].mark.subj1,', '); write( xpupil[i].mark.subj2,', '); write( xpupil[i].mark.subj3,', '); write( xpupil[i].mark.subj4,', '); writeln(xpupil[i].mark.subj5,'. '); end; writeln; writeln; writeln(' The list of the pupils with subj1-mark, more than average is :'); writeln(' ----------------------------------------------------------------'); for j:=1 to xk do begin write(' ',j,'. ',xselect_pupil[j].sirname); write(' ', xselect_pupil[j].name); write(' ', xselect_pupil[j].fathername); write(', ', xselect_pupil[j].birth); writeln(', ', xselect_pupil[j].class,' class.'); write(' marks : '); write( xselect_pupil[j].mark.subj1,', '); write( xselect_pupil[j].mark.subj2,', '); write( xselect_pupil[j].mark.subj3,', '); write( xselect_pupil[j].mark.subj4,', '); writeln(xselect_pupil[j].mark.subj5,'. '); end; writeln; writeln(' The program was successfully completed !'); end; {---------------------------------------------------------------------} function Exit:boolean; label L; var ans:char; begin L:writeln; writeln; write(' Do you want to start the program again ? (y/n) ---> '); readln(ans); if (ans='y') or (ans='Y') then Exit:=false else if (ans='n') or (ans='N') then Exit:=true else begin writeln(' Error !!! answer must be only <y> or <n> !'); goto L; end; end; {---------------------------------------------------------------------} var pupil,select_pupil:Tpupils; N,k:byte; {============================} begin repeat clrscr; Create_BD(N,pupil); Analysis_BD(N,pupil,select_pupil,k); Output_Report(N,k,pupil,select_pupil); until Exit; end. {==============================} --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 5-ый класс) Ответ отправлен: 25.04.2008, 17:01

Вопрос № 133.958

составить программу которая решает поставленную задачу.выполнять с помощью подпрограмм В файле последовательного доступа хранится информация о рыбной продукции: наименование продукции, дата изготовления, единицы из- мерения, количество, срок годности. Вывести наименований рыбной продукции. Определить продукцию, количество котрой меньше задан- ной. Результат запроса хранится в другом текстовом файле. Рекомендация. Данные о пакетах хранить в текстовом файле на от- дельных строках.

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

Отвечает: Попов Владимир Иванович Здравствуйте, ещё раз уважаемый заказчик! Опять-таки, исходный код в приложении. Протестирован в ТМТ Паскаль. Работает. Файлы создаются в директории нахождения исполняемого (ехе) файла. Удачи ! Приложение: {======================================} program FishProduction; {---------------------------------------------------------------------} uses crt; const Nmax=25; {---------------------------------------------------------------------} type Trec=record name:string[50]; data:string[15]; units:string[10]; amount:word; worklife:string[15]; end; Tproducts=array[1..Nmax] of Trec; {---------------------------------------------------------------------} procedure Create_BD(var xN:byte;var xproduct:Tproducts); label L; var i:byte; f:text; begin L:writeln; write(' Input the amount of your records : N = '); readln(xN); if (xN<2) or (xN>Nmax) then begin writeln(' Error !!! N must be >= 2 and <= ',Nmax); goto L; end else begin assign(f,'input.txt'); rewrite(f); writeln(f,xN); writeln; writeln(' Input the products information list : '); for i:=1 to xN do begin writeln; writeln(' Record number ',i); writeln(' -----------------'); write(' name - '); readln(xproduct[i].name); writeln(f,xproduct[i].name); write(' data - '); readln(xproduct[i].data); writeln(f,xproduct[i].data); write(' units - '); readln(xproduct[i].units); writeln(f,xproduct[i].units); write(' amount - '); readln(xproduct[i].amount); writeln(f,xproduct[i].amount); write(' worklife - '); readln(xproduct[i].worklife); writeln(f,xproduct[i].worklife); end; close(f); writeln(' Your Base was written to the file <input.txt> !'); end; end; {---------------------------------------------------------------------} procedure Read_BD(var xN:byte;var xproduct:Tproducts); var i:byte; f:text; sN:string; code_error:integer; begin assign(f,'input.txt'); {$I-} reset(f); if IOResult <> 0 then begin writeln(' Reset error ! File was not found !!! Press Enter for quit - '); readln; halt; end; {$I+} readln(f,sN); val(sN,xN,code_error); for i:=1 to xN do begin readln(f,xproduct[i].name); readln(f,xproduct[i].data); readln(f,xproduct[i].units); readln(f,xproduct[i].amount); readln(f,xproduct[i].worklife); end; close(f); end; {---------------------------------------------------------------------} procedure Analysis_BD(xN:byte;var xproduct:Tproducts;var xcontrol_amount:word;var xselect_product:Tproducts;var xk:byte); var i,j:byte; begin writeln; write(' Input the control_amount : '); readln(xcontrol_amount); j:=1; for i:=1 to xN do begin if xproduct[i].amount < xcontrol_amount then begin xselect_product[j].name := xproduct[i].name; xselect_product[j].data := xproduct[i].data; xselect_product[j].units := xproduct[i].units; xselect_product[j].amount := xproduct[i].amount; xselect_product[j].worklife := xproduct[i].worklife; j:=j+1; end; end; xk:=j-1; writeln(' The analysis of your base was successfully completed !'); end; {---------------------------------------------------------------------} procedure Output_Report(xN,xk:byte;xcontrol_amount:word;var xproduct:Tproducts;var xselect_product:Tproducts); var i,j:byte; f:text; begin assign(f,'output.txt'); rewrite(f); writeln(f,xk); writeln; writeln(' The inputed base is :'); writeln(' ======================='); for i := 1 to xN do begin write(' ',i,'. ',xproduct[i].name); write(' : ', xproduct[i].data); write(', ', xproduct[i].units); write(', ', xproduct[i].amount); writeln(', ', xproduct[i].worklife,'.'); end; writeln; writeln; writeln(' The list of the products with amount, less than ',xcontrol_amount,' is :'); writeln(f,' The list of the products with amount, less than ',xcontrol_amount,' is :'); writeln(' -------------------------------------------------------------'); writeln(f,' -------------------------------------------------------------'); for j:=1 to xk do begin write(' ',j,'. ',xselect_product[j].name); write(f,' ',j,'. ',xselect_product[j].name); write(' : ', xselect_product[j].data); write(f,' : ', xselect_product[j].data); write(', ', xselect_product[j].units); write(f,', ', xselect_product[j].units); write(', ', xselect_product[j].amount); write(f,', ', xselect_product[j].amount); writeln(', ', xselect_product[j].worklife,'.'); writeln(f,', ', xselect_product[j].worklife,'.'); end; close(f); writeln; writeln(' The report was saved in the file <output.txt>'); writeln(' So, the program was successfully completed !'); end; {---------------------------------------------------------------------} function Exit:boolean; label L; var ans:char; begin L:writeln; writeln; write(' Do you want to start the program again ? (y/n) ---> '); readln(ans); if (ans='y') or (ans='Y') then Exit:=false else if (ans='n') or (ans='N') then Exit:=true else begin writeln(' Error !!! answer must be only <y> or <n> !'); goto L; end; end; {---------------------------------------------------------------------} var product1,product2,select_product:Tproducts; control_amount:word; N1,N2,k:byte; {=======================================} begin repeat clrscr; Create_BD(N1,product1); Read_BD(N2,product2); Analysis_BD(N2,product2,control_amount,select_product,k); Output_Report(N2,k,control_amount,product2,select_product); until Exit; end. {=========================================} --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 5-ый класс) Ответ отправлен: 25.04.2008, 19:26

Вопрос № 134.136

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

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Боринов Святослав Николаевич! Решения задач с небольшими пояснениями в приложении. Пояснять практически нечего, одна писанина. Подправьте вывод, где неудачно получилось. Поскольку есть очень длинные строки, здесь они удвоились, соберите их обратно в одну строку. По первой задаче исходим из того, что суда не работают подряд более одного года. Приложение: Задача 1. program q134136_1; uses crt; const n=2; type sudno=record {тип запись с полями по условию} name:string; tonn:integer; dtvyh:record gv,mv,dv:integer; end; firm:string[20]; dtoth:record go,mo,dot:integer; end; ryba:record name:string[20]; sort:byte; kol:integer; end; end; var mass: array [1..n] of sudno; {массив записей, список судов и информации о них} i: byte; g,m,d:integer; {текущие год месяц день} Procedure Vvod; {ввод данных} begin write('Koli4estvo sudov=',n); readln; for i:=1 to n do begin writeln('Sudno # ',i); write ('Nazvanie: '); readln(mass[i].name); write('Tonnaz: '); readln(mass[i].tonn); writeln('Data vyhoda:'); write(' Den: '); readln(mass[i].dtvyh.dv); write(' Mesyac: '); readln(mass[i].dtvyh.mv); write(' god: '); readln(mass[i].dtvyh.gv); write('Firma: ');readln(mass[i].firm); writeln('Data otheta:'); write(' Den: '); readln(mass[i].dtoth.dot); write(' Mesyac: '); readln(mass[i].dtoth.mo); write(' god: '); readln(mass[i].dtoth.go); writeln('Ryba:'); write(' Naimenovanie: ');readln(mass[i].ryba.name); write(' Sort: ');readln(mass[i].ryba.sort); write(' Kolichestvo: ');readln(mass[i].ryba.kol); writeln; end; end; Procedure Vyvod; {вывод данных} begin writeln('Sudna rabotaut v more > 3 mesiacev:); for i:=1 to n do begin {если год один, разница в месяцах >3} if ((g=mass[i].dtvyh.gv)and(m-mass[i].dtvyh.mv>3)) {если год один, разница в месяцах=3, разница в днях>=0} or ((g=mass[i].dtvyh.gv)and(m-mass[i].dtvyh.mv=3) and(d-mass[i].dtvyh.dv>=0)) {для 1-3 месяцев если абс. Разница <9} or ((g-mass[i].dtvyh.gv=1)and(abs(m-mass[i].dtvyh.mv)<9)) {для 1-3 месяцев если абс. Разница =9 а разница в днях>=0} or ((g-mass[i].dtvyh.gv=1)and(m-mass[i].dtvyh.mv=9) and (d-mass[i].dtvyh.dv>=0)) then begin write(mass[i].name,' ',mass[i].tonn,' tn Vihod: ',mass[i].dtvyh.dv,'.',mass[i].dtvyh.mv,'.',mass[i].dtvyh.gv); write(' ',mass[i].firm,' Othet: ',mass[i].dtoth.dot,'.',mass[i].dtoth.mo,'.',mass[i].dtoth.go); write(' Ryba: ',mass[i].ryba.name,' sort',mass[i].ryba.sort,' ',mass[i].ryba.kol,' tn'); writeln; end else writeln(‘Takih sudov net.’); end; end; begin clrscr; {вводим текущую дату} write('god=');readln(g); write('mesiac=');readln(m); write('den=');readln(d); Vvod; Vyvod; readln end. Задача 2. uses crt; const n=3; {это для тестирования, а так надо побольше} type tovar=record {тип запись с полями по условию задачи} nam:string[20]; vyp:string[20]; post:string[20]; firma:string[20]; cnz:real; cnp:real; ed:string[20]; kps:real; kpr:real; end; var sp:array[1..50]of tovar; {массив записей, товары и их данные} i:integer; Procedure Vvod; {ввод данных} begin write('Kolichestvo vidov tovara=',n); readln; for i:=1 to n do begin writeln('Tovar # ',i); write('Naimenovanie: ');readln(sp[i].nam); write('Data vypuska: ');readln(sp[i].vyp); write('Data postuplenia: ');readln(sp[i].post); write('Firma: ');readln(sp[i].firma); write('Zakupochnaia cena: ');readln(sp[i].cnz); write('Cena prodagi: ');readln(sp[i].cnp); write('Edenica: ');readln(sp[i].ed); write('Kolichestvo postupilo: ');readln(sp[i].kps); write('Kolichestvo prodano: ');readln(sp[i].kpr); end; writeln; end; Procedure Vyvod; {вывод данных о полностью проданных товарах} begin writeln('Polnostju prodano:'); writeln; for i:=1 to n do if sp[i].kps=sp[i].kpr then begin write(sp[i].nam,' ',sp[i].vyp,' ',sp[i].post,' ',sp[i].firma,' '); writeln(sp[i].cnz:5:2,' ',sp[i].cnp:5:2,' ',sp[i].ed,' ',sp[i].kps:5:2,' ',sp[i].kpr:5:2); {эти две строки – в одну} writeln; end; readln; end; begin {начало программы} clrscr; Vvod; {вызов процедур} Vyvod; end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 25.04.2008, 20:46 Оценка за ответ: 5

Отвечает: Попов Владимир Иванович Здравствуйте, Боринов Святослав Николаевич! Решение вашей задачи требует организации массива записей, структура которых определена через две вложенные подструктуры : данных про корабль и данных про улов. При этом в них обеих использована еще одна вложенная струтура - даты (выхода на промысел и подачи отчёта, соответственно). Список модулей программы : 1.Вспомогательная процедура ввода даты; 2.Основная процедура ввода массива записей; 3.Вспомогательная функция вычисления даты в днях (от начала эры); 4.Вспомогательная процедура копирования записей; 5.Основная процедура анализа данных по заданной контрольной дате; 6.Вспомогательная процедура вывода отдельного массива записей; 7.Основная процедура вывода результатов анализа. 8.Функция организации запроса на повторный запуск программы. 9.Главный модуль. Ввод данных, естественно, сопровождается проверкой их соответствия области допустимых значений. Исходный код в приложении. Программа успешно протестирована в среде программирования ТМТ Паскаль. Консультации через минифорум. Удачи с зачётом. Приложение: program ShipList; uses crt; const Nmax=15; type Tdata=record day,month,year:integer; end; Tship=record name:string[100]; wt:longint; data:Tdata; firm:string[100]; end; Tfish=record data:Tdata; name:string[100]; sort,amount:integer; end; Trec=record ship:Tship; fish:Tfish; end; Tlist=array[1..Nmax] of Trec; var N,k:integer; cd:Tdata; list,report:Tlist; procedure InputData(var xdata:Tdata); label L1,L2,L3; begin with xdata do begin L1:write(' day - '); readln(day); if (day<1) or (day>31) then begin writeln(' Input error !!! Day must be > 0 and <= 31 !'); goto L1; end else L2:write(' month - '); readln(month); if (month<1) or (month>12) then begin writeln(' Input error !!! Month must be > 0 and <= 12 !'); goto L2; end else begin L3:write(' year - '); readln(year); if year<1000 then begin writeln(' Input error !!! Year must be > 1000 !'); goto L3; end; end; end; end; procedure InputList(var xN:integer;var xlist:Tlist); label L; var i:integer; begin L:write(' Input the amount of your records : N = '); readln(xN); if (xN<1) or (xN>Nmax) then begin writeln(' Input error !!! N must be >= 1 and <= ',Nmax,' !'); goto L; end else begin writeln(' Input your records one by one :'); for i:=1 to xN do begin writeln(' The record number ',i); writeln(' ---------------------'); with xlist[i] do begin write(' The name of the ship : '); readln(ship.name); write(' Water weight of the ship : '); readln(ship.wt); writeln(' The work begining data :'); InputData(ship.data); write(' The host firm of the ship : '); readln(ship.firm); writeln(' The report data : '); InputData(fish.data); write(' The name of the fish : '); readln(fish.name); write(' Sort of the fish : '); readln(fish.sort); write(' Amount of the fish : '); readln(fish.amount); end; end; end; end; function DataCalc( var xdata:Tdata):longint; var p,p1,p2:longint; begin with xdata do begin p1:=365*year+day; if (year mod 4)=0 then p2:=29 else p2:=28; case month of 0: p:=p1; 1: p:=p1+31; 2: p:=p1+p2+31; 3: p:=p1+p2+62; 4: p:=p1+p2+92; 5: p:=p1+p2+123; 6: p:=p1+p2+153; 7: p:=p1+p2+184; 8: p:=p1+p2+215; 9: p:=p1+p2+245; 10: p:=p1+p2+276; 11: p:=p1+p2+306; 12: p:=p1+p2+337; end; DataCalc:=p; end; end; procedure CopyRec(var xrec:Trec;var yrec:Trec); begin yrec.ship.name := xrec.ship.name; yrec.ship.wt := xrec.ship.wt; yrec.ship.data.day := xrec.ship.data.day; yrec.ship.data.month := xrec.ship.data.month; yrec.ship.data.year := xrec.ship.data.year; yrec.ship.firm := xrec.ship.firm; yrec.fish.data.day := xrec.fish.data.day; yrec.fish.data.month := xrec.fish.data.month; yrec.fish.data.year := xrec.fish.data.year; yrec.fish.name := xrec.fish.name; yrec.fish.sort := xrec.fish.sort; yrec.fish.amount := xrec.fish.amount; end; procedure Analysis(xN:integer;var xlist:Tlist;var xcd:Tdata;var xreport:Tlist;var xk:integer); var i,j:integer; s,cs:longint; begin writeln; writeln(' Input your control data value :'); InputData(xcd); cs:=DataCalc(xcd); j:=1; for i:=1 to xN do begin s:=DataCalc(xlist[i].ship.data); if (cs-s)>90 then begin CopyRec(xlist[i],xreport[j]); j:=j+1; end; end; xk:=j-1; end; procedure OutputList(xN:integer;var xlist:Tlist); var i:integer; begin for i:=1 to xN do begin with xlist[i].ship do writeln(' ',i,'. ',name,', wt-',wt,' tonn',', ',data.day,'.',data.month,'.',data.year,' - ',firm,';'); with xlist[i].fish do writeln(' report : ',data.day,'.',data.month,'.',data.year,' - ',name,', ',sort,' sort, ',amount,' tonn.'); end; end; procedure OutputResults(xN,xk:integer;var xlist:Tlist; var xreport:Tlist); var i,j:integer; begin writeln; writeln(' The general list of your records is :'); writeln(' ---------------------------------------'); OutputList(xN,xlist); writeln; writeln(' The report list of the ship, wich are working more, than 3 monthes, is : '); writeln(' --------------------------------------------------------------------------'); OutputList(xk,xreport); writeln; writeln(' The program was successfully completed !'); end; function Exit:boolean; label L; var ans:char; begin L:writeln; writeln; write(' Do you want to start the programm again ? (y/n) ---> '); readln(ans); if ans='y' then Exit:=false else if ans='n' then Exit:=true else begin writeln(' Input error !!! Answer must be only <y> or <n> !'); goto L; end; end; begin repeat clrscr; writeln; InputList(N,list); Analysis(N,list,cd,report,k); OutputResults(N,k,list,report); until Exit; writeln; writeln(' Long live the Pascal programming language !!!'); write(' Press <Enter> for quit : '); readln; end. --------- Physics forever !

Ответ отправил: Попов Владимир Иванович (статус: 5-ый класс) Ответ отправлен: 29.04.2008, 17:27 Оценка за ответ: 5

Вопрос № 134.143

Здраствуйте!! Очень срочно и очень нужно помочь с программами! по теме одномерные массивы! 1. В соревнованиях по бегу принимают участие 10 спортсменов. Вводя по очереди фамилии и результаты участников в ЭВМ, определить, сколько из них выполнило норму ГТО, и напечатать их фамилии. 2. Вводя по 4 оценки, полученные студентами в сессию, вывести на экран фамилии неуспевающих студентов (имеющих хотя бы одну оценку 2). 3. Дан массив целых чисел, содержащий 15 элементов. Записать в этом же массиве сначала все кратные трем числа, а затем все остальные, сохраняя порядок их следования. 4. Отсортировать массив вещественных чисел методом обмена. По- строить блок-схему сортировки. И бонусная: В файле прямого доступа хранится информация о судах, находящихся в районе промысла: название, тип судна, объект промысла, порт при- писки, количество членов экипажа на борту, судовые запасы: количе- ство груза, топливо, вода. Вывести список судов некоего порта при- писки. Определить суда, которым требуется бункеровка топливом. Ре- зультат запроса сохранить в другом текстовом файле. Заранее спасибо!!! Приложение: Все программы нужно писать с использованием подпрограмм. Бонусная программа по теме файлы.

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Шичкина, Анна, Сергеевна! Задача №1,2 с коментариями в приложении. На бонусную задачу я отвечал ранее: вопрос №131803 Удачи!!! Приложение: {1} const N=10; {Кол-во спортсменов} GTOnorm=50; {Норма ГТО(я не знаю что это и поставил 50)} var results : array [1..N] of real; {массив результатов, т.к. массив состоит из вещественных чисел, то можно вводить дробные рез-ты} names : array [1..N] of string; {массив имен} i : integer; {i-счетчик для циклов For} procedure AskInfo;{получает информацию} begin for i:=1 to N do {в цикле запрашиваем исходные данные} begin Write('Имя: '); readln(names[i]); write('Рез-тат: '); readln(results[i]); end; end; procedure OutInfo; {Вывод} var count : integer;{count-счетчик выполнивших норму, } begin count:=0; {обнуляем счетчик, если этого не сделать, то переменная будет содержать мусор, и программа выдаст не верный рез-ат} for i:=1 to n do {цикл для поиска выполнивших норму} if results[i] <= GTONorm then {если тек. рез-ат меньше или равен норме, то выводим имя и сам рез-тат} begin Writeln('Имя: ', names[i]); WriteLn('Рез-тат: ', results[i]: 0 : 2); inc(count); {увеличиваем счетчик на еденицу} end; Write('Спортсменов выполнивших норму: ',count); {выводим кол-во выолнивших норму} end; begin AskInfo; OutInfo; readln; end. {2} type {запись} TStudent = record stname : string; {имя} f, s, t, fr : byte; {оценки: 1,2,3 и 4 соответственно} end; const N=10; {кол-во студентов} var Students : array [1..N] of TStudent; {массив студентов} i : integer; {i - счетчик для циклов For} procedure ReadInfo; {получает данные} begin for i:=1 to N do {получаем данные} begin Write('Имя: '); ReadLn(Students[i].stname); ReadLn(Students[i].f,Students[i].s, Students[i].t, Students[i].fr); end; end; procedure WriteNeUsp; {выводит неуспевающих} begin WriteLn('Неуспевающие студенты: '); for i:=1 to N do {передираем весь массив, если одна йз оценок студента равнв 2 или меньше, то выводим} if (Students[i].f<=2) or (Students[i].s<=2) or (students[i].t<=2) or (students[i].fr<=2) then writeln(students[i].stname); end; begin ReadInfo; WriteLn; WriteNeUsp; readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 25.04.2008, 21:01

Отвечает: Пупорев Юрий Борисович Здравствуйте, Шичкина, Анна, Сергеевна! Решение 3 и 4 задач в приложении. Блок-схема к задаче №4 по этой ссылке http://rusfaq.ru/upload/537 Приложение: Задача 3. uses crt; const n=15; var a:array[1..n]of integer; i:integer; Procedure Vvod; begin randomize; writeln('ish mass:'); for i:=1 to n do begin a[i]:=random(10)+1; write(a[i],' '); end; writeln; end; Procedure Perest; var k,j,x:integer; begin k:=0; for i:=1 to n do if a[i] mod 3=0 then begin k:=k+1; x:=a[i]; for j:=i downto k+1 do begin a[j]:=a[j-1]; end; a[k]:=x; end; end; Procedure Vyvod; begin writeln('rez:'); for i:=1 to n do write(a[i],' '); readln end; begin clrscr; Vvod; Perest; Vyvod; end. Задача 4. uses crt; const n=10; var a:array[1..10]of real; i,j:integer; Procedure Vvod; begin randomize; writeln('Ishod massiv:'); for i:=1 to n do begin a[i]:=random(10)+random; write(a[i]:6:2); end; writeln; end; Procedure SortObm; var x:real; begin for i:=1 to n-1 do for j:=1 to n-1 do if a[j]>a[j+1] then begin x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x; end; end; Procedure Vyvod; begin writeln('Otsortirov massiv:'); for i:=1 to n do write(a[i]:6:2); readln end; begin clrscr; Vvod; SortObm; Vyvod; end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 26.04.2008, 10:21 Оценка за ответ: 5

Вопрос № 134.153

Известны марки машин, изготовляемых в данной стране и импортируемых зарубеж. Даны некоторые N стран. Определить для каждой из марок, какие из них были: - доставлены во все страны - доставлены в некоторые из стран - не доставлены ни в одну страну

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

Отвечает: Евчик Сергей Александрович Здравствуйте, Cobain! Могу предложить способ решения указанный в приложении! Т.к. я не знаю, какие марки автомобилей Вы брали, то я решил задачу на примере видов спорта! При желании Задачу можно переделать "на лету". P.S. пришлось импровизировать с Case Приложение: program sport; uses crt; Type s1=set of byte; vidy=set of 1..11; var a,b,c,k,n:s1; by,j:byte; s:string; i:integer; ch:char; function zamena (s:string):byte; var i:byte; begin case s[1] of 'ф','Ф': begin case s[2] of 'у','У': i:=1; 'е','Е': i:=6; 'и','И': i:=10; end; end; 'б','Б': begin case s[2] of 'а','А': i:=2; 'о','О': i:=5; 'е','Е': i:=8; end; if Length(s)>10 then i:=11; end; 'в','В': i:=3; 'т','Т': i:=4; 'к','К': i:=7; 'ш','Ш': i:=9; end; zamena:=i; end; procedure vivod (m:s1;p:byte); var i,t:byte; begin t:=0; for i:=1 to 11 do if i in m then begin GoToXY(p,i+1); inc(t); case i of 1: Writeln('Футбол'); 2: Writeln('Баскетбол'); 3: Writeln('Волейбол'); 4: Writeln('Теннис'); 5: Writeln('Бокс'); 6: Writeln('Фехтование'); 7: Writeln('Карате'); 8: Writeln('Бег'); 9: Writeln('Шахматы'); 10:Writeln('Фигурное катание'); 11:Writeln('Бег на лыжах'); end; end; end; procedure vivod1 (a,b,c:s1); begin GoToXY(1,1); Writeln('Во всех группах: '); k:=a*b*c; vivod(k,1); for i:=1 to 11 do k:=k+[i]; k:=k-a-b-c; GoToXY(20,1); Writeln('Ни в одной из групп: '); vivod(k,20); GoToXY(45,1); k:=a+b+c; Writeln('Хотя бы в одной группе: '); vivod(k,45); end; begin clrscr; writeln('Виды спорта которыми занимаются в группах:'); writeln('футбол, баскетбол, волейбол, теннис, бокс, фехтование'); writeln('карате, бег, шахматы, фигурное катание, бег на лыжах'); Writeln; a:=[]; b:=[]; c:=[]; j:=1; while (j<>4) do begin clrscr; vivod1(a,b,c); GoToXY(1,14); write('Вводить виды спорта для ',j,'-ой группы? '); case j of 1: begin readln(ch); if not(ch in ['y','Y','д','Д']) then inc(j) else begin; readln(s); a:=a+[zamena(s)]; end; end; 2: begin readln(ch); if not(ch in ['y','Y','д','Д']) then inc(j) else begin; readln(s); b:=b+[zamena(s)]; end; end; 3: begin readln(ch); if not (ch in ['y','Y','д','Д']) then inc(j) else begin; readln(s); c:=c+[zamena(s)]; end; end; end; end; readln end.

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 25.04.2008, 18:59 Оценка за ответ: 2

Вопрос № 134.220

Уважаемые эксперты!!! Помоготе пожалуйста решить задачу в Pascal!!!__ПРЯМ ЖИЗНЕННО НЕОБХОДИМО!!!!(((__ Задача: В файле прямого доступа хранится информация о судах,находящихся в районе промысла: название, тип судна, обьект промысла, порт приписки, количество членов экипажа на борту, судовые запасы: кол-во груза, топливо, вода. Вывести список судов некоего порта приписки. Определить суда,которым требуется бункировка топлива. Результат запроса сохранить в дркгом текстовом файле. ________Заранее БОЛЬШОЕ спасибо=)__________

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

Отвечает: Евчик Сергей Александрович Здравствуйте, LedyAG! Ваша задача решается с помощью записей. В программе я описал записи, но возможно в вашем файле хранятся записи, описанные не так как у меня (разберетесь сами: нужно будет поставить в соответствие полю записи переменные нужного вам типа). Удачи. Приложение: Program z1; uses crt; const min_fuel = 1000; {Минимальное количество топлива (Нужно для осуществления поиска)} {Тут описание полей нашей записи} Type sudno=record name:string[40]; tip:string[20]; obj:string[20]; port:string[40]; crew:word; gruz:word; fuel:word; water:word; end; var f,f1:file of sudno;{Файлы куда мы будем сохранять} key:string[40]; s:sudno; way:string; {Вывод считаной записи на экран} Procedure vivod(s:sudno); begin Writeln('Название судна - ',s.name); Writeln('Тип судна - ',s.tip); Writeln('Объект промысла - ',s.obj); Writeln('Порт приписки - ',s.port); Writeln('Количество членов экипажа - ',s.crew); Writeln(' СУДОВЫЕ ЗАПАСЫ:'); Writeln(' Количество груза - ',s.gruz); Writeln(' Топливо - ',s.fuel); Writeln(' Вода - ',s.water); end; begin clrscr; Write('Введиет путь к файлу: '); readln(way); Assign(f,way); {$I-} Reset(f); {$I+} if IoResult<>0 then {Проверяем на ошибку при открытии файла} begin Writeln('ERROR'); ReadKey; Halt; end else begin Writeln('Введите путь для сохранения информации: '); readln(way); Assign(f,way); {$I-} ReWrite(f); {$I+} if IoResult<>0 then begin Writeln('ERROR'); ReadKey; Halt; end else begin Write('Суда какого порта вывести? '); readln(key); While not EOF(f) do {Пока не конец файла то: } begin Read(f,s);{Считали запись} if s.port=key then {Проверили соответствует ли поле записи нашему условию} begin vivod(s); Write(f1,s); end end; seek(f,0);{Установили указатель на начало} Writeln('Суда которым нужно топливо:'); While not EOF(f) do {Пока не конец файла то: } begin Read(f,s);{Считали запись} if s.fuel>=min_fuel then {Проверили соответствует ли поле записи нашему условию} BEGIN vivod(s); Write(f1,s); END; end; end; end; end.

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 26.04.2008, 15:00

Вопрос № 134.235

Доброе время суток...уважаемые эксперты...Мопогите решить 2-е задачки на двухмерные массивы: 1)Заполнить матрицу случайными числами найти количество отрицательных на главной диагонали и максимальный элемент на побочной диагонали. 2)Дана квадратная матрица A[N,N]. Записать на место отрицательных элементов матрицы нули, а на место положительных - единицы.(далее особо интересно)Вывести на печать нижнюю треугольную матрицу в обепринятом виде. Ps вопрос забыл что такое odd Ps заранее благодарю за вашу помощь...

Отправлен: 26.04.2008, 13:29 Вопрос задал: Danilka (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 5)

Отвечает: Евчик Сергей Александрович Здравствуйте, Danilka! Начнем с конца :-) Функция odd проверяет на нечетность (я ее использовал в решении ваших задач). По поводу первой задачи я думаю все понятно! По поводу задачи №2: Я сначала заполняю элемент матрицы случайным образом, а затем проверяю его на нечетность! После заполнения всей матрицы я вырезаю и вывожу нижний треугольник. P.S. Размерность матрицы в обеих задачах задается в константе Приложение: {1}Program z1; uses crt; const n=10; var a:array[1..n,1..n] of integer; i,j,max,kol:integer; begin clrscr; randomize; Writeln('Матрица имеет вид: '); kol:=0; max:=-5; for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=random(10)-5; Write(a[i,j],' '); end; if odd(a[i,i]) = true then inc(kol); if a[i,n+1-i]>max then max:=a[i,n+1-i]; Writeln; end; Writeln('Количество отрицательных элементов на главной диогонали = ',kol); Writeln('Максимальный элемент побочной диогонали = ',max); readln {1}end. {2}Program z1; uses crt; const n=10; var a:array[1..n,1..n] of integer; i,j,m:integer; begin clrscr; randomize; Writeln('Матрица имеет вид: '); for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=random(10)-5; if odd(a[i,j]) = true then a[i,j]:=0 else a[i,j]:=1; Write(a[i,j],' '); end; Writeln; end; Writeln('Треугольная матрица имеет вид: '); for i:=n div 2 to n do begin for j:=1 to i do if j<n-i+1 then Write(' ') else Write(a[i,j],' '); Writeln; end; readln end.

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 26.04.2008, 14:27 Оценка за ответ: 5

Вопрос № 134.242

Уважаемые эксперты,помогите пожалуйста разобратся с готовой программой. В этой программе мне не понятна работа с динамическими данными. Что означает pt := @mas[1];и как заносятся данные в массив.Если можно, то хотя бы в кратце поясните программу (программый код). Я понимаю, что вначале необходимо создать новую динамическую переменную, выделив в памяти ЭВМ участок для размещения величины New(p1); адрес этого участка присваивается переменной p1,а как это сделано для массива не пойму. Код программы в приложении. Приложение: program Integral; uses Crt; function ex(x: real): real; var next, eps, sum: real; i: Integer; begin x := x * x; next := 1; i := 1; sum := 1; eps := 0.001; repeat next := next * x / i; sum := sum + next; i := i + 1; until abs(next) < eps; ex := sum; end; var n: Integer; a, b, step: real; x, int: real; mas: array [1..100] of real; pt: ^real; { указатель } f: text; i: Integer; Begin clrscr; write('Введите число дискретов: '); readln(n); write('Введите начало интервала (0.5): '); readln(a); write('Введите конец интервала (1.8): '); readln(b); x := a; step := (b - a) / n; pt := @mas[1]; assign(f, 'int.dat'); rewrite(f); for i := 1 to n do begin pt^ := abs(ex(x)); writeln(f, pt^); Inc(pt); x := x + step; end; close(f); int := 0; pt := @mas[1]; for i := 1 to n do begin int := int + pt^; Inc(pt); end; writeln('Интеграл = ', int * step); readkey; End.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Kulikov_Oleg_Viktorovich! Вся беда в том, что в этой программе нет динамических данных. Все переменные определены как статические. Программа нормально отработает, если в программе заменить строки на: ii:=1;{pt := @mas[1];} . . . mas[ ii ]:= abs(ex(x);{pt^ := abs(ex(x));} writeln(f, mas[ ii ]);{writeln(f, pt^);} Inc(ii);{Inc(pt);} Теперь о том, что Вам не понятно: pt: ^real; { указатель } - представляет собой адрес в памяти на переменную типа real, т.е. сегмент:смещение:длина переменной типа, - real(6-ть байт, см.типы данных); pt := @mas[1]; - получить адрес(сегмент:смещение) в памяти на первый элемент массива; pt^ := abs(ex(x)); - записать по этому адресу абсолютное значение результата возвращаемого функцией ЕХ(её тип real, т.е. 6 байт), аналогично для команды writeln(f, pt^); Inc(pt); - самое интересное, т.к. любая статически определенная переменная не может занимать в памяти больше чем 64кб (максимальный размер одного сегмента - особенности организации памяти для х86 процессоров), то сегмент остается без изменений, а к смещению в этом сегменте прибавляется число равное длине данного типа(т.е. 6-ть байт. При компиляции программы, массивы в памяти представляют собой цепочку последовательно расположенных байт, логически разделенные в соответствии с типом данных на элементы этого массива). Указатель после этой команды будет указывать на следующий элемент массива. В данном случае использование указателей ускоряет работу программы(во время её выполнения), т.к. все изменения смещений в массиве вычисляются во время компиляции, в случае если применен код замены, то все смещения вычисляются во время её работы(т.е. взять значение ii, вычесть 1, т.к. работа начинается с нулевого смещения относительно адреса массива в памяти, умножить на длину типа данных, добавить адрес начала массива и только после этого начинается работа с элементом массива) В приложении цитаты из помощи паскаля, которые Вам помогут понять принцип работы программы. ps:вопросы задавайте в мини-форум. Удачи! Приложение: Указательные типы Переменная указательного типа содержит адрес в памяти динамической переменной определенного типа. Вы можете присвоить значение указательной переменной с помощью: - процедур New или GetMem - оператора @ или функции Addr - функции Ptr Зарезервированное слово NIL обозначает указатель, который не указывает никуда. Пример: { Объявление указательных типов } Type BytePtr = ^Byte; WordPtr = ^Word; Оператор @ ("at"): Операция с указателем Вы можете создавать указатель на переменную с помощью оператора @. Оператор: @ Операция: Взятие адреса Тип операндов: Ссылка на переменную идентификатор функции или процедуры Тип результата: Pointer (как и NIL) "@" является унарным оператором. При использовании оператора "@" с процедурными переменными применяются специальные правила. Тип результата такой же, как и у NIL, так что этот оператор может применяться для любых типов указателей. с переменной: Использование @ с обычной переменной не сложно. Например, для следующих объявлений: Type TwoChar = Array [0..1] Of Char; Var Int : Integer; TwoCharPtr : ^TwoChar; следующий оператор заставляет указатель TwoCharPtr указывать на Int: TwoCharPtr := @Int; Указатель TwoCharPtr^ становится переобработкой значения Int, как будто это массив [0..1] типа Char. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 30.04.2008, 21:57

Вопрос № 134.261

Привет! помогите пожалуйсто! Задание №3 Напишите программу, обраба- тывающую данные по заказам со склада: магазин-заказчик, номер заказа, элемент заказа, объем заказа. Данные хранятся в типизиро- ванном файле. Предусмотреть поиск номеров заказов по названию магазина, поиск заказов по элементам. Отсортировать в файле зака- зы по магазинам, по номерам заказов. Использование модуля обяза- тельно.

Отправлен: 26.04.2008, 16:57 Вопрос задал: Appela Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Appela! Решение вашей длинной задачи в приложении. Отдельно текст модуля и основной программы. Программа очень длинная, но простая. Если везде писать комментарии, то это очень много. Если выборочно, то не знаю, что может быть Вам не понятно. Вы погоняйте программу, посмотрите, и что будет непонятно, напишите на форуме, я объясню. Когда наберете текст модуля (буквально как написано), сохраните его под тем же именем, что и название модуля. Нажмете Ctrl+F9, выйдет окно с сообщением «Cannot run a unit». Нажмете OK и у вас автоматически создастся файл с таким же именем, но с расширением *.TPU. Это и будет модуль. Затем набираете в новом окне текст программы и работаете. Модуль и программу я тестировал, все работает. Приложение: Модуль. unit Zakaz; interface type Tzak=record mz:string[20]; nz:integer; ez:string[20]; oz:integer; end; Tsklad=array[1..100]of Tzak; Tfile=file of Tzak; Procedure Vvod(var n:integer;var sp:Tsklad;var f:Tfile); Procedure NomZk(var f:Tfile); Procedure ZakEl(var f:Tfile); Procedure SortMag(n:integer;var sp:Tsklad;var f:Tfile); Procedure SortNom(n:integer;var sp:Tsklad;var f:Tfile); implementation Procedure Vvod(var n:integer;var sp:Tsklad;var f:Tfile); var i:integer; begin write('Vvedite kolichestvo zakazov:'); readln(n); rewrite(f); writeln('Vvedite dannye o zakazah:'); for i:=1 to n do begin with sp[i]do begin writeln(i,' zakaz:'); write('Magazin: ');readln(mz); write('Nomer zakaza: ');readln(nz); write('Element: ');readln(ez); write('Objem: ');readln(oz); end; write(f,sp[i]); end; writeln; close(f); end; Procedure NomZk(var f:Tfile); var i,k:integer; sp:Tsklad; s:string; begin reset(f); write('Vvedite nazvanie magazina:'); readln(s); writeln('Spisok zakazov dlja etogo magazina:'); i:=1;k:=0; while not eof(f) do begin read(f,sp[i]); if sp[i].mz=s then begin writeln(sp[i].nz); k:=k+1; end; i:=i+1; end; if k=0 then writeln('Takogo magazina net.'); readln; close(f); end; Procedure ZakEl(var f:Tfile); var i,k:integer; sp:Tsklad; s:string; begin reset(f); write('Vvedite element zakaza:'); readln(s); writeln('Spisok zakazov s etim elementom:'); i:=1;k:=0; while not eof(f) do begin read(f,sp[i]); if sp[i].ez=s then begin writeln(sp[i].mz,' ',sp[i].nz,' ',sp[i].oz); k:=k+1; end; i:=i+1; end; if k=0 then writeln('Takogo elementa net.'); readln; close(f); end; Procedure SortMag(n:integer;var sp:Tsklad;var f:Tfile); var i,j:integer; bf:Tzak; begin rewrite(f); i:=1; while not eof(f) do begin read(f,sp[i]); i:=i+1; end; for i:=1 to n-1 do for j:=1 to n-1 do if sp[j].mz>sp[j+1].mz then begin bf:=sp[j]; sp[j]:=sp[j+1]; sp[j+1]:=bf; end; for i:=1 to n do begin write(f,sp[i]); end; close(f); reset(f); writeln('Spisok, otsortirovanny po nazvaniu magazina:'); i:=1; while not eof(f) do begin read(f,sp[i]); writeln(sp[i].mz,' ',sp[i].nz,' ',sp[i].ez,' ',sp[i].oz); i:=i+1; end; readln; close(f); end; Procedure SortNom(n:integer;var sp:Tsklad;var f:Tfile); var i,j:integer; bf:Tzak; begin rewrite(f); i:=1; while not eof(f) do begin read(f,sp[i]); i:=i+1; end; for i:=1 to n-1 do for j:=1 to n-1 do if sp[j].nz>sp[j+1].nz then begin bf:=sp[j]; sp[j]:=sp[j+1]; sp[j+1]:=bf; end; for i:=1 to n do begin write(f,sp[i]); end; close(f); reset(f); writeln('Spisok, otsortirovanny po nomeru zakaza:'); i:=1; while not eof(f) do begin read(f,sp[i]); writeln(sp[i].nz,' ',sp[i].mz,' ',sp[i].ez,' ',sp[i].oz); i:=i+1; end; readln; close(f); end; end. Программа. uses crt,Zakaz; var f:Tfile; c:char; sp:Tsklad; n:integer; begin clrscr; assign(f,'sklad.dat'); Vvod(n,sp,f); repeat Writeln('Zadacha:'); writeln('1-poisk nomera zakaza po nazvaniu magazina'); writeln('2-poisk zakazov po elementu zakaza'); writeln('3-sortirovka po nazvaniu magazina'); writeln('4-sortirovka po nomeru zakaza'); writeln('5-Vyhod'); readln(c); case c of '1': NomZk(f); '2': ZakEl(f); '3': SortMag(n,sp,f); '4': SortNom(n,sp,f); '5':exit; end; until c='5'; end.

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

Вопрос № 134.298

Увадаемые эксперты! Помогите пожалуста с решением этой задачи на Паскале. Даны числа Р и Н (P<H). Определить сумму чисел меньше Р, произведение чисел больше Н и количества чисел в диапазоне значений Р и Н.

Отправлен: 26.04.2008, 22:03 Вопрос задала: Хрусталева A.A (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 3)

Отвечает: SHERRY Здравствуйте, Хрусталева A.A! Решение Вашей задачи с пояснениями в приложении (прошу прощения за транслит) Приложение: const P = 10; H = 20; { t.k. 4isla dany, to zadaem ih kak konstanti} var a,b,sum,pr,i: integer; c,c1: boolean; begin readln(a,b); { schitivaem 4isla, opredelyajushie diapazon } sum := 0; pr := 1; { inicializaciya peremennih } c:= false; c1:= false; { budem ispol`zovat` logi4eskie peremennie, 4toby proveryat` nali4ie iskomih 4isel } if a>b then { proveryaem uslovie a<b (dlya pravil`nosti prohogdeniya cikla)} begin { obmen mestami zna4enij peremennih, esli predidushee uslovie neverno } a := a + b; b := a - b; a := a - b; end; for i:=a to b do {proverka 4isel diapazona v cikle} begin if i<P then begin sum := sum + i; c:=true; end; if i>H then begin pr := pr * i; c1 := true; end; end; if c then writeln('Sum = ', sum) { vivod rezultatov na ekran } else writeln('Net 4isel < P'); if c1 then writeln('Pr = ', pr) else writeln('Net 4isel > H'); readln; end. --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 8-ой класс) Ответ отправлен: 28.04.2008, 23:04

Вопрос № 134.306

МногоуваЖаемые эксперты!Вечер добрый!помогите пожалуйста со следующим: Выполнить обработку элементов прямоугольной матрицы А, имеющий N строк и M столбцов. Перемножить элементы каждого столбца матрицы с соответствующими элементами К-го столбца. Спасибо большое!

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Igor lukashov! Решение задачи в приложении. По условию элементы ккаждого столбца нужно умножить на элементы к-того столбца, значит и столбец тоже нужно умножить на себя. Так я и решал задачу. Если столбец сам на себя не умножать, то из кода нужно выкинуть две строчки, где идет это умножение. Приложение: program matrica; uses crt; const n=5; m=6; var k,i,j:integer; a:array[1..n,1..m]of integer; begin clrscr; write('Vvedite 0<K<7');readln(k); randomize; writeln('Ishodnaia matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=random(10)+1; write(a[i,j]:3); end; writeln; end; readln; for j:=1 to m do for i:=1 to n do if j<>k then begin a[i,j]:=a[i,j]*a[i,k]; end; for i:=1 to n do a[i,k]:=a[i,k]*a[i,k]; writeln('Rezultat:') for i:=1 to n do begin for j:=1 to m do write(a[i,j]:5); writeln; end; readln; end.

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

Вопрос № 134.321

Здравствуйте уважаемые эксперты, меня интересует как я могу завершить работу программы при условии, в смысле например "if a>b then" закончить, тоесть если условие выполяняется программа закрывается, кода нет, так как это общий вопрос, заранее спасибо.

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

Отвечает: Шемет Станислав Васильевич Здравствуйте, Пашков Дмитрий Владимирович! Для того чтоб закончить программу нужно после условия выхода записать Halt(0); тоесть на вашем примере єто так будет выглядеть If a>b then halt(0); --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 7-ой класс) Ответ отправлен: 27.04.2008, 11:34 Оценка за ответ: 5

Вопрос № 134.325

Здравствуйте! Помогите, пожалуйста, решить задачу: Написать программу, которая находит разность средних арифметических значений двух вещественных массивов с использованием модуля Average. Вся сложность в том, что я не умею обращаться с модулями. Я бы мог решить ее обычным способом, но здесь нужно использовать модуль. Если не сложно, объясните, пожалуйста, поподробнее, как обращаться с модулем. БОЛЬШОЕ СПАСИБО!

Отправлен: 27.04.2008, 09:55 Вопрос задал: BOOM (статус: 10-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, BOOM! Решение задачи в приложении. А поподробнее о модулях это в учебники. Их в интернете немало, учитесь пользоваться литературой, всю жизнь за Вас решать не будут. Просто пересказать своими словами учебник не каждому дано. А вообще, если Вы писали программы с использованием подпрограмм. То модуль это вынесенные подпрограммы в другую, несколько специфическую программу, которая подключается к основной программе. Когда наберете текст модуля (буквально как написано), сохраните его под тем же именем, что и название модуля. Нажмете Ctrl+F9, выйдет окно с сообщением «Cannot run a unit». Нажмете OK и у вас автоматически создастся файл с таким же именем, но с расширением *.TPU. Это и будет модуль. Затем набираете в новом окне текст программы и работаете. Модуль и программу я тестировал, все работает. Приложение: Модуль. unit Average; interface type Tmas=array[1..100]of real; procedure Vvod(n:integer; var a:Tmas;var sr:real); implementation procedure Vvod(n:integer; var a:Tmas;var sr:real); var i:integer; begin randomize; writeln('Ishodnaia matrica:'); sr:=0; for i:=1 to n do begin a[i]:=random(10)+random; write(a[i]:5:2); sr:=sr+a[i]; end; sr:=sr/n; writeln; writeln('srar=',sr:5:2); end; end. Программа. uses crt,average; var a,b:Tmas; na,nb,i:integer; sra,srb,raz:real; begin clrscr; write('Vvedite razmernost massiva A, na='); readln(na); Vvod(na,a,sra); write('Vvedite razmernost massiva B, nb='); readln(nb); Vvod(nb,b,srb); raz:=sra-srb; writeln; writeln('raznost=',raz:5:2); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 27.04.2008, 22:30 Оценка за ответ: 5 Комментарий оценки: СПАСИБО ОГРОМНОЕ!!!

Вопрос № 134.354

Здравствуйте. Помогите решить задачу в Паскале: одномерный массив P(N) заполнить случайным образом в динамической памяти. Найти максимальный и минимальный элементы, поменять их местами. Вывести исходный и изменённый массив. Отсортировать массив по возростанию методом "пузырька".

Отправлен: 27.04.2008, 13:21 Вопрос задал: Ковязин Антон Андреевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Командин Константин Евгениевич Здравствуйте, Ковязин Антон Андреевич! Хотелось бы кое что уточнить в вашей задачи. Дело в том что насколько я знаю обычный Borland Pascal не умеет работать с динамическими массивами. Можно ли для решения задачи использовать например Delphi (где есть поддержка динамических массивов)?

Ответ отправил: Командин Константин Евгениевич (статус: 2-ой класс) Ответ отправлен: 28.04.2008, 06:41

Вопрос № 134.361

Уважаемые эксперты, я снова прошу вас о помощи. Я не уверен в своем способе ввода печатающего текста, смотрите я делаю так delay(65000); write(a); delay(65000); write(b); ну и типо того. Когда же следует вводить длинный текст это стает чуть нудно... Возможно ли в этом случае поступить иначе? Ой. еще чуть не забыл, возможно ли прикреплятькартинки к программе, например после какой то функции появляется картинка.... или можно воспроизводить ноты не через внутренний динамик а через колонки.. Заранее благодарен.

Отправлен: 27.04.2008, 14:15 Вопрос задал: Пашков Дмитрий Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Евчик Сергей Александрович Здравствуйте, Пашков Дмитрий Владимирович! Можно поступить следующим образом: s:='Ваш текст'; for i:=1 to length(s) do begin Write(s[i]); Delay(65000); end; Насчет картинки: Возможно все но есть несколько НО: в паскале 16 цветов а для картинок этого явно недостаточно (хотя не мне судить). Теоретически можно попробовать вывести картинку но тогда придется использовать Assembler и программа может приобретать несколько большие размеры. Или рисовать картинку самому используя модуль graph. Насчет колонок не знаю не интересовался. Но когда-то я слышал про плейеры написанные на паскале.

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 27.04.2008, 19:50 Оценка за ответ: 5 Комментарий оценки: Замечательный ответ. Большое вам спасибо. Я еще буду обращаться. Пожалуйста просмотрите мой следующий вопрос. Я сейчас напишу его. Буду очень блогодарен.

Вопрос № 134.433

У короля три хода: вверх, вправо и по диагонали. нужно сказать сколько путей из левого нижнего угла в верхний правый, если на клетке 4;4 стоит пешка, и туда королю нельзя Зараннее благодарен

Отправлен: 27.04.2008, 20:45 Вопрос задал: Andrew Shtamburg (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 3)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Andrew Shtamburg! Программа в приложении. В программе использованна работа с динамической памятью, из-за этого её можно легко переделать для поля с любым размером. Во время работы программы перебираются все возможные варианты, для контроля создается файл (около 1,5Мб) в который записывается информация о всех координатах найденого пути(от конца до начала), если в процессе поиска король попадает на клетку с пешкой в файл записывается символ "*" и весь пройденный до этого путь. ps:вопросы по программе задавайте в мини-форум. Удачи! Приложение: { 8.8 8.7 8.6 8.5 8.4 8.3 8.2 8.1 7.1 6.1 5.1 4.1 3.1 2.1 1.1 8.8 8.7 8.6 8.5 8.4 8.3 8.2 7.1 6.1 5.1 4.1 3.1 2.1 1.1 8.8 8.7 8.6 8.5 8.4 8.3 8.2 7.2 7.1 6.1 5.1 4.1 3.1 2.1 1.1 } const c=8; type TList=^TBase; TBase=record x,y,z:integer; w:Tlist; end; var a,b:TList; n,m:integer; k:longint; f:text; begin {вводим значения } write('Enter X:');readln(n); write('Enter Y:');readln(m); assign(f,'q134433.txt'); rewrite(f); {левый нижний угол} new(a); a^.x:=1;{координата по горозонтали} a^.y:=1;{координата по вертикали} a^.z:=3;{число ходов для данной точки} a^.w:=nil;{метка конца цикла} {количество путей} k:=0; repeat {проверяем по ходам для текущего положения} case a^.z of {ход:вправо} 3:begin new(b); b^.w:=a; b^.x:=a^.x+1; b^.y:=a^.y; end; {ход:вправо и вверх} 2:begin new(b); b^.w:=a; b^.x:=a^.x+1; b^.y:=a^.y+1; end; {ход:вверх} 1:begin new(b); b^.w:=a; b^.x:=a^.x; b^.y:=a^.y+1; end; {хода нет, возращаемся назад} 0:begin b:=a; a:=a^.w; dispose(b);{освобождаем память от текущего положения} b:=a; end; end; {если указатели не равны, это значит есть новый ход} if a<>b then begin dec(a^.z);{уменьшаем количество ходов текущего положения} b^.z:=3;{для нового полжения ставим количество ходов} a:=b;{следующее положение} end; {проверяем достигли ли правого верхнего угла} if (a^.x=c)and(a^.y=c)then begin inc(k);{увеличиваем счетчик путей} b:=a; a^.z:=0;{заканчиваем ход} {вывод в файл только для контроля} write(f,' '); while b<>nil do begin write(f,b^.x:2,'.',b^.y); b:=b^.w; end; writeln(f); {конец вывода} end; {вывод в файл только для контроля} if (a^.x=n)and(a^.y=m)then begin write(f,'*'); while b<>nil do begin write(f,b^.x:2,'.',b^.y); b:=b^.w; end; writeln(f); end; {конец вывода} {если вышли за пределы квадрата заканчиваем ход} if (a^.x>c)or(a^.y>c)or((a^.x=n)and(a^.y=m))then a^.z:=0; until a=nil;{повторяем в цикле пока не обойдем все возможные комбинации} close(f); writeln('Path:',k);{выводим результат} end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 30.04.2008, 17:53 Оценка за ответ: 4

Вопрос № 134.434

Не могу решить задачу: Сбербанк начисляет 2% годовых. Выведите на экран, какой станет сумма вклада S, положенная в сбербанк на N лет.Значения S и N вводятся с клавиатуры. Внесены поправки (из удаленного вопроса №134437) ----- ∙ Отредактировал: Denisss (Профессионал) ∙ Дата редактирования: 28.04.2008, 22:46

Отправлен: 27.04.2008, 20:48 Вопрос задала: Синькова Наталья Валентиновна (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Шемет Станислав Васильевич Здравствуйте, Синькова Наталья Валентиновна! Программа в приложении Приложение: Var R:real; N:word; Begin Write('Начальная сумма'); Readln(r); Write('Количество лет'); Readln(n); For n:=n Downto 1 do r:=r+r*0.02; Writeln(r); REadln; end. --------- Любовь это прекрасно!!!

Ответ отправил: Шемет Станислав Васильевич (статус: 7-ой класс) Ответ отправлен: 28.04.2008, 00:25 Оценка за ответ: 5 Комментарий оценки: Cпасибо, я получила 5=)

Вопрос № 134.441

Уважаемые эксперты, и вновь нужна ваша помощ, меня интересует как ставить метки, ну например чтобы при выполнении условия if b>c then перемещалось в любую часть программы, указаную программистом, ну например если в конце программы запрашивало начать заново и еесли написать да то перемещало в самое начало, и вновь выполнялся алгоритм. Заранее благодарен. Извините что так много вопросов, просто решил текстовую игру написать... Пожалуйста помогите. Хоть совмесными усилиями... :)

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

Отвечает: Евчик Сергей Александрович Здравствуйте, Пашков Дмитрий Владимирович! Пример перехода в приложении. P.S. Переходы это конечно замечательно, но тут есть свои подводные камни :-)) GoTo рекомендуется использовать в самом крайнем случае. Например если вам нужно выполнить переход в начало кода или в любую его часть то лучше загнать все это дело в цикл: var ch:char; begin repeat <Тут код вашей программы> Write('Повторить еще раз? '); readln(ch); until ch in ['Y','y','Д','д']; end; Приложение: var <описание переменных>; label metka;{Тут через запятую описываются все ваши метки} begin <Тут код вашей программы> metka:<Место на которое нужно выполнить переход> <Тут снова продолжение программы (если нужно)> GoTo metka; {Непосредственно сам переход} end;

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 28.04.2008, 00:22 Оценка за ответ: 5 Комментарий оценки: Отлично, именно это я и хотел. Спасибо огромное.

Вопрос № 134.443

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

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

Отвечает: Евчик Сергей Александрович Здравствуйте, Пашков Дмитрий Владимирович! К сожалению в паскале существует лишь одна переменная строкового типа (string). Вывод нескольких строк можно осуществить лишь последовательно (выводя текст по 255 символов) :-(( Как решение проблеммы можно: 1. Использовать строковый массив. 2. Писать на Delphi (WideString-память выделяется динамически) но это уже разговор не этого вопроса.

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 28.04.2008, 00:05 Оценка за ответ: 4 Комментарий оценки: Спасибо, к сожалению жалко.

Вопрос № 134.456

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

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Heartdrive! Раз Вы знаете как вывести треугольник Паскаля прямоугольником, значит эта часть Вам понятна. Вывести его на экран в виде равнобедренного можно простым форматированием. Нужно в начале каждой строки ввести определенное число пробелов, которое вычисляется по алгоритму, который приведен в приложении. Кроме того нужно правильно форматировать вывод самих чисел. Под каждое число нужно отвести четное количество позиций, для n<=12 это к=4. Если покажется тесно, возьмите к=6. Короче поэкспериментируйте, как Вам больше понравится. Кстати массив взят от ноля не по ошибке. Если брать от 1 то получается несоответствие между количеством строк треугольника и порядком треугольника, это из-за первой "нулевой единицы." Приложение: uses crt; var a:array[0..20,0..20]of integer; n,i,j,k:integer; begin clrscr; write('n=');readln(n); {Заполнение треугольника данными} a[0,0]:=1;a[1,0]:=1;a[1,1]:=1; for i:=2 to n do begin a[i,0]:=1; for j:=0 to i+1 do begin if j=i then a[i,j]:=1 else a[i,j]:=a[i-1,j-1]+a[i-1,j]; end; end; {вывод треугольника} k:=4;{количество позиций под числа} for i:=0 to n do begin {вводим пробелы в начале каждой строки} write(' ':(n-i+1+((k div 2)-1)*(n-i))); for j:=0 to i do write(a[i,j]:k); {выводим треугольник} writeln; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 28.04.2008, 20:58

Вопрос № 134.522

Уважаемые эксперты! Помогите, пожалуйста, решить 4 задачи: 1. Дана фраза, вывести её слова в перевёрнутом виде. 2. Дана фраза, удалить из неё слова с буквой «о» 3. Дана фраза, проверить, является ли она палиндромом 4. Дана фраза, удалить из неё пробелы перед знаками препинания и вставить после знаков препинания, если там пробелов нет. Заранее огромное спасибо! Swallow.

Отправлен: 28.04.2008, 15:11 Вопрос задала: Ласточка (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Ласточка! Решение задач в приложении. Может не идеально, но все работает. С выводом перевернутых слов как понял, так и сделал. Приложение: Задача 1. uses crt; var s:string; d:array[1..100] of string; i,k,j:integer; begin clrscr; writeln('Fraza:');readln(s); {считаем слова и собираем их в массив} k:=1; for i:=1 to length(s) do begin if s[i]=' ' then k:=k+1 else d[k]:=d[k]+s[i]; end; {выводим их задом наперед} for i:=1 to k do begin for j:=length(d[i])downto 1 do write(d[i][j]); writeln; end; readln end. Задача 2. uses crt; var s,s2:string; s1:array[1..50]of string; i,j,k,p:integer; begin clrscr; write('s: ');readln(s); {считаем слова и собираем их в массив} j:=1; for i:=1 to length(s) do begin if s[i]=' 'then j:=j+1 else s1[j]:=s1[j]+s[i]; end; {считаем в словах все буквы О, маленькие, большие, русские и английские} for i:=1 to j do begin p:=0; for k:=1 to length(s1[i]) do if s1[i][k] in ['o','O','о','О'] then begin p:=p+1; end; {если р=0, то буквы О нет и мы оставляем слово в сnроке} if p=0 then s2:=s2+s1[i]+' ' end; writeln('s2=',s2); readln; end. Задача 3. uses crt; var s:string; i,k:byte; begin clrscr; write('s: ');readln(s); {от начала до середины строки проверяем, совпадают ли равноудаленные от концов строки символы и считаем совпадения. Если их количество равно половине строки, то палиндром (если строка нечетная, то средняя буква равна сама себе).} k:=0; for i:=1 to length(s) div 2 do if (length(s)>1)and(s[i]=s[length(s)-i+1]) then begin k:=k+1; end; if k=length(s)div 2 then writeln('Palindrom!') else writeln('No Palindrom.'); readln; end. Задача 4. uses crt; const zp=['.',',',';',':','?','!']; {добавить все знаки еще раз в русской раскладке} var s:string; i:integer; begin clrscr; write('Stroka: ');readln(s); for i:=length(s) downto 1 do begin {далее условие задачи, написанное на Паскале} if (s[i] in zp)and(s[i-1]=' ')then begin delete(s,i-1,1); end else if (s[i]<>' ')and(s[i-1] in zp)then begin insert(' ',s,i); end; end; writeln(s); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 30.04.2008, 15:54 Оценка за ответ: 5 Комментарий оценки: Огромное спасибо, Юрий Борисович!!!!!!!! Вы мне очень помогли!!!!!

Вопрос № 134.527

Здраствуйте,помогите решить пример по циклам Q=arctg(2*z)*ln(sqr(z)+1), где a=0.35;при x<3 z=(a*x)/sqr(x)+2*x+3 при x>=3 z=a/sqr(x)-2*x+1; -5<=x<=5;h=2 h-шаг Решала сама,но у меня она зацикливается.Заранее благодарна.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Evela! Решение задачи в приложении. Вроде не зацикливает. Решение проверял в Exel, сходится. Приложение: uses crt; var a,x,z,h,Q:real; begin clrscr; a:=0.35;h:=2; x:=-5; while x<=5 do begin if x<3 then z:=a*x/sqr(x)+2*x+3 else if x>=3 then z:=a/sqr(x)-2*x+1; Q:=arctan(2*z)*ln(sqr(z)+1); writeln('x=',x:2:0,' Q=',Q:6:3); x:=x+h; end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 28.04.2008, 18:24 Оценка за ответ: 5

Вопрос № 134.538

Дорогие,эксперты! Помогите мне решить задачи,буду очень благодарна. Дана целочисленная матрица К(n,m).Отсортировать элементы матрицы по строкам,используя сортировки: -сортировка Шелла; -бинарным включением; а) Разработать программу, которая формирует целочисленную матрицу. В каждой строке определить сумму элементов и разместить их на главной диагонали. Отсортировать элементы главной диагонали по возростанию. Алгоритм построения матрицы оформить в виде подпрограммы. б) Даны две целочисленные матрицы А(k,l) и D(l,c). Найти значения выражений: C=A*D+A*D Y=C+C

Отправлен: 28.04.2008, 16:31 Вопрос задала: Юлия правда (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Юлия правда! Решение задач под литерами а) и б) в приложении. Даны необходимые пояснения. Алгоритмы сложения и умножения матриц не объясняю, есть учебники. Приложение: а) uses crt; const n=5; type matr=array[1..50,1..50]of integer; var x,y:integer; a:matr; Procedure NewMatr(var m:matr); var sum,i,bf:integer; begin for x:=1 to n do begin sum:=0; for y:=1 to n do begin sum:=sum+m[x,y]; {считаем сумму в строке} end; {присваиваем ее значение елементу главной диагонали } m[x,x]:=sum; end; {сортируем элементы главной диагонали методом пузырька} for x:=1 to n-1 do for i:=1 to n-1 do if m[i,i]>m[i+1,i+1]then begin bf:=m[i,i]; m[i,i]:=m[i+1,i+1]; m[i+1,i+1]:=bf; end; end; begin {начало программы} clrscr; randomize; writeln('Ishodnaja matrica:'); for x:=1 to n do begin for y:=1 to n do begin a[x,y]:=random(10); write(a[x,y]:4); end; writeln; end; NewMatr(a); {вызов процедуры} writeln('Rezultat:'); for x:=1 to n do begin for y:=1 to n do write(a[x,y]:4); writeln; end; readln; end. б) В условии дана матрица С и параметр размерности с. Так нельзя, получается дублирование переменных, т.к. Паскаль на регистр букв не реагирует. Заменил С на В. uses crt; var A,D,B,Y:array[1..10,1..10]of integer; k,l,c,i,j,r:integer; begin clrscr; randomize; write('k=');readln(k); write('l=');readln(l); write('c=');readln(c); writeln('Matrica A:'); for i:=1 to k do begin for j:=1 to l do begin A[i,j]:=random(9)+1; write(A[i,j]:3); end; writeln; end; readln; writeln('Matrica D:'); for i:=1 to l do begin for j:=1 to c do begin D[i,j]:=random(9)+1; write(D[i,j]:3); end; writeln; end; readln; {Умножение матриц} for r:=1 to k do for j:=1 to c do begin B[r,j]:=0; for i:=1 to l do begin B[r,j]:=(B[r,j]+A[r,i]*D[i,j]); end; end; writeln('Matrica B:'); {Сложение матрицы В с собой, можно просто умножить на 2} for i:=1 to k do begin for j:=1 to c do begin B[i,j]:=B[i,j]+B[i,j]; write(B[i,j]:5); end; writeln; end; readln; writeln('Matrica Y:'); {И еще раз тоже самое} for i:=1 to k do begin for j:=1 to c do begin Y[i,j]:=B[i,j]+B[i,j]; write(Y[i,j]:5); end; writeln; end; readln; end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 30.04.2008, 09:39 Оценка за ответ: 5 Комментарий оценки: Спасибо :)

Вопрос № 134.550

Уважаемые эксперты помогите решить задачу. Составить модуль работы с простыми дробями (+ - * : ) Приложение: По теме модуль.

Отправлен: 28.04.2008, 18:31 Вопрос задал: Кузнецов Алексей Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Кузнецов Алексей Владимирович! Модуль и пример использования его в программе в приложении. Кроме процедур арифмнтических действий, предусмотрена рекурсивная функция NOD, необходимая для сокращения дробей. Более известная процедура NOD с вычитанием здесь не подходит, т.к. для знаменателя выбран тип чисел, не содержащий ноля и отрицательных чисел. Все остальное должно быть понятно, т.к. процедуры есть запись того, как производят действия с обыкновенными дробями на бумаге. Приложение: Модуль. unit DROBI_M; interface type frac=record {тип запись с полями числитель и знаменатель дроби} p:integer; q:1..maxint; {ряд натуральных чисел от 1 до максимального integer} end; function nod(m,n:integer):integer; procedure slog(a,b:frac;var e:frac); procedure vich(a,b:frac;var e:frac); procedure umn(a,b:frac;var e:frac); procedure del(a,b:frac; var e:frac); implementation function nod(m,n:integer):integer; begin if m<>0 then nod:=nod(n mod m,m) else nod:=n; end; procedure slog(a,b:frac;var e:frac); var g:integer; begin e.p:=a.p*b.q+a.q*b.p; e.q:=a.q*b.q; e.p:= e.p div nod(e.p,e.q); e.q:=e.q div nod(e.p,e.q); end; procedure vich(a,b:frac;var e:frac); var g:integer; begin e.p:=a.p*b.q-a.q*b.p; e.q:=a.q*b.q; e.p:=e.p div nod(e.p,e.q); e.q:=e.q div nod(e.p,e.q); end; procedure umn(a,b:frac; var e:frac); var g:integer; begin e.p:=a.p*b.p; e.q:=a.q*b.q; e.p:=e.p div nod(e.p,e.q); e.q:=e.q div nod(e.p,e.q); end; procedure del(a,b:frac; var e:frac); var g:integer; begin e.p:=a.p*b.q; e.q:=a.q*b.p; e.p:=e.p div nod(e.p,e.q); e.q:=e.q div nod(e.p,e.q); end; end. Программа. uses crt,drobi_m; var a,b,c:frac; begin clrscr; write('Vvedite chislitel drobi A:'); readln(a.p); write('Vvedite znamenatel drobi A:'); readln(a.q); write('Vvedite chislitel drobi B:'); readln(b.p); write('Vvedite znamenatel drobi B:'); readln(b.q); slog(a,b,c); writeln('Summa=',c.p,'/',c.q); vich(a,b,c); writeln('Raznost=',c.p,'/',c.q); umn(a,b,c); writeln('Proizvedenie=',c.p,'/',c.q); del(a,b,c); writeln('Chastnoe=',c.p,'/',c.q); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 29.04.2008, 21:43

Вопрос № 134.551

Уважаемые эксперты помогите решить задачу. Дан текст прочитать сколько в нем слов.Вывести каждое слово отдельно и подсчитать кол-во слов. Приложение: По теме строки.

Отправлен: 28.04.2008, 18:34 Вопрос задал: Кузнецов Алексей Владимирович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Евчик Сергей Александрович Здравствуйте, Кузнецов Алексей Владимирович! Функция с помощью которой можно осуществить такой поиск в приложении. a - константа в которой собержатся символы разделители: const a=[' ',',','!','?','.']; Функция выводит каждое слово на новой строке а как результат возвращает число слов. Удачи. Приложение: function poisk (s:string):byte; var k,i,j:byte; q:boolean; s1:string; begin k:=0; i:=0; j:=1; q:=false; repeat inc(i); if (s[i] in a) then j:=i+1 else begin repeat inc(i); if s[i] in a then q:=false else q:=true; until (q=false) or (i=ord(s[0])+1); s1:=copy(s,j,i-j); dec(i); Writeln(s1); inc(k); end; until i=ord(s[0]); poisk:=k; end;

Ответ отправил: Евчик Сергей Александрович (статус: 3-ий класс) Ответ отправлен: 28.04.2008, 18:47

Вопрос № 134.553

Помогите решить 3 задачки: 1.Если n=3,то какое значение будет иметь переменная f после выполнения следуещего составного оператора?Запишите в тетрадь begin f:=1;i:=2; 1:if i>n goto 9; f:=f*i,i:=i+1;goto 1; 9:end. 2.Запишите правильную структуру последовательности операторов a:=1;b:=1;while a+b<8 do begin a:=a+1;b:=b+2 end;s:=a+b.Сколько раз будет повторен цикл т какими будут a,b,s после его завершения? 3.Чему будет равно значение переменной K после исполнения фрагмента программы K:=1;while (a[k]<>X)end(K<=10)do K:=K+1; (Здесь K=7,а в каестве элементов массива числа 2,3,5,9,12,0,7,6,7)

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Spartak2008! По задаче 1. Нужно поправмть begin f:=1;i:=2; 1:if i>n then goto 9; f:=f*i,i:=i+1;goto 1; 9:end. Переменная f будет иметь значение 6. 1-й шаг f=1; i=2; => f=1*2=2; 2-й шаг f=2; i=3; => f=2*3=6; Т.к i=n, цикл заканчивается. По задаче 2. Правильная структура: a:=1;b:=1; while a+b<8 do begin s:=a+b; a:=a+1; b:=b+2; end; Цикл будет повторен 3 раза, а=3, b=5, s=5; 1-й шаг a=1; b=1; a+b=2; s=2; 2-й шаг a=2; b=3; a+b=5; s=2+3=5; 3-й шаг a=3; b=5; a+b=8 s не будет считать, т.к. условие a+b<8 нарушено. По задаче 3. Тоже неточности. Есть переменная Х, но непонятно чему она равна, видимо вместо «Здесь K=7» нужно Здесь Х=7. Чисел в массиве 9, а условие аnd(K<=10). Переделал задание так: K:=1; while (a[k]<>X)and(K<=9)do K:=K+1; Здесь X=7,а в качестве элементов массива числа 2,3,5,9,12,0,7,6,7) Тогда К будет равно 7, т.к. первое число 7 стоит на седьмом месте. Если у Вас пропущено число раньше чем стоит 7, то будет так K:=1; while (a[k]<>X)and(K<=10)do K:=K+1; а К будет равно 8.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 30.04.2008, 11:47

Вопрос № 134.562

1.двумерный массив 10 на 10 заполнить случайными натуральными числами;найдите все простые числа и вывести на экран. 2.верно ли что (b+a) div b=a тогда и только тогда,когда a кратно b?

Отправлен: 28.04.2008, 19:33 Вопрос задал: Papan (статус: 1-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Denisss Здравствуйте, Papan! В приложении пример решения первой задачи. При заполнении массива случайными натуральными числами взято за основу определение, что натуральные числа - это числа, используемые в перечислении (нумировании) предметов (первый, второй, третий, ...). Т.е. целые числа, больше нуля. Успехов! Приложение: program q134562_1; uses Crt; {Функция возвращает True, если N простое число и False в ином случае} function isSimple(const N: Integer): Boolean; var i, k: Integer; p: Boolean; begin {Инициализация} isSimple:= False; p:= True; i:= 2; k:= N; {Если число меньше двух, оно не простое} if (N < 2) then Exit {Двойка - простое число} else if (N = 2) then begin isSimple:= True; Exit; end else while ((i < k) and p) do begin {Проверяем остаток деления} p:= not (N mod i = 0); k:= N div i + 1; Inc(i); end; {Результат} isSimple:= p; end; const N = 10; var i, j: Integer; Mass: array[1..N, 1..N] of Integer; begin {Очистка экрана} ClrScr; {Готовимся к случайному заполнению} Randomize; {Заполняем массив случайными натуральными числами} for i:= 1 to N do begin for j:= 1 to N do begin {Числа взяты из диапазона 1..5000} {0 - не натуральное число} Mass[i, j]:= Random(5000) + 1; {Выводим элемент массива} write(Mass[i, j]:4, ' '); end; writeln; end; writeln; writeln('Prostye chisla:'); {Выводим простые числа} for i:= 1 to N do for j:= 1 to N do if isSimple(Mass[i, j]) then writeln('[', i:2, ', ', j:2, '] = ', Mass[i, j]:4); {Даем пользователю возможность насладиться результатом} writeln; write('Press any key...'); readln; end. --------- Будь осторожен, когда молишься ради чего-то, потому что можешь это получить...

Ответ отправил: Denisss (статус: Профессионал) Россия, Москва ICQ: 281599577 ---- Ответ отправлен: 28.04.2008, 21:05

Вопрос № 134.575

Доброе время суток, уважаемые эксперты! Помогите пожалуйста справиться со следующей задачей! Мне необходимо сделать программу по опросу всей клавиатуры! Использую ASCII и Skan коды! Можно только 1 клавишу(но скан кодом) Заранее благодарен!

Отправлен: 28.04.2008, 19:54 Вопрос задал: Калёнов Дмитрий Алексеевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Зенченко Константин Николаевич Здравствуйте, Калёнов Дмитрий Алексеевич! Программа в приложении. Правильно обрабатывается только основная клавиатура и функциональные клавиши, т.к. чтение значений производится из области данных Bios до их обработки, а сама обработка скен-кодов возложена на её(Bios) функции, в том числе и обработка разширенного набора клавиш клавиатуры. Удачи! Приложение: uses crt; var a:word; c:byte; e:^word; f:string; begin f:='0123456789ABCDEF';{для вывода в 16-ой системе} repeat write('enter:');{приглашаем к вводу} repeat e:=ptr($40,$1A);{указатель на адрес начала буфера клавиатуры} a:=e^;{читаем значение адреса началя буфера клавиятуры} e:=ptr($40,a);{указатель на значение нажатой клавиши} a:=e^;{читаем это значение} until keyPressed;{если клавиша не нажата продолжаем в цикле} a:=(a div $FF)mod $FF;{получаем значение скен-кода клавиши} asm{код ассемблера только для проверки} xor ax,ax int 16h mov c,ah end; {выводим значение скен-кода клавиши} writeln(f[(a div 16)+1]:4,f[(a mod 16)+1], f[(c div 16)+1]:4,f[(c mod 16)+1]); {продолжаем пока на нажата клавиша основной клавиатуры} until a=$1c; end. --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 05.05.2008, 21:51 Оценка за ответ: 5 Комментарий оценки: Большое Спасибо!

Вопрос № 134.582

Уважаемые эксперты! помогите, пожалуйста, решить следующую задачу: Дан одномерный массив числовых значений, насчитывающий n элементов. Сумму элементов целочисленного массива вставить на место, указанное первым элементом массива. Заранее спасибо!)

Отправлен: 28.04.2008, 21:17 Вопрос задал: Igor lukashov (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Igor lukashov! Решение задачи с пояснениями в приложении. Приложение: uses crt; var a:array[1..50]of integer; n,i,sum,k:integer; begin clrscr; randomize; write('Vvedite razmernost massiva= '); readln(n); writeln('Ishodny massiv:'); sum:=0; for i:=1 to n do begin a[i]:=random(n)+1; {заполняем массив} sum:=sum+a[i]; {считаем сумму} write(a[i],' '); end; writeln; k:=a[1]; {присваиваем к значение первого элемента} for i:=n downto k do {сдвигаем от к до конца все элементы на 1 вправо} a[i+1]:=a[i]; a[k]:=sum; {на к-товое место ставим сумму} writeln('Rezultat:'); for i:=1 to n+1 do {выводим массив на 1 длиннее} write(a[i],' '); readln end.

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

Вопрос № 134.600

Дан файл f, компоненты которого являются целыми числами. Записать в файл g среднеарифметическое значение первых k компонент, затем – среднеарифметическое значение следующих 2k компонент, затем – среднеарифметическое значение следующих 3k компонент, и так далее. Последняя компонента файла g должна быть равна среднеарифметическому из компонент файла f, образующих последнюю (возможно неполную) группу. Полученный файл отсортировать указанным преподавателем способом в порядке возрастания. Использовать прямое слияние

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, KATERINKA! Если еще актуально, предложу свой, укороченный вариант решения. Проблема с сортировкой слиянием, не знаю, как ее применить. Эта сортировка применяется либо для сортировки при объединении двух упорядоченных массивов, либо при сортировке одного массива, размерность которого есть степень числа 2, т.к. при этой сортировке массив разбивантся на массивы по одному элементу, потом они объединяются в массивы по 2 элемента, потом по 4 и т.д. Считайте, что с этой залачей я не справился, сделал обычную сортировку обменом(метод "пузырька"). Еще, при чтении элементов файла я использовал массив, т.к. алгоритм обработки исходных данных и так довольно сложный, а без массива он еще сложнее. На всякий случай, создайте файл целых чисел, которые запишите в строчку через пробел. Дайте ему имя и сохраните, лучше в одном каталоге с программой, чтобы не указывать путь. Чисел возьмите побольше, а то второй файл будет куцый. Вот пожалуй и все. Код с пояснениями в приложении. Приложение: uses crt; var f,g:text; k,j,n,sum,i,p,t,q:integer; bf:real; {буфер при сортировке} cs:array[1..1000]of integer; {массив целых чисел} sr:array[1..100]of real; {массив средн.арифм.} begin clrscr; assign(f,'SrAr.txt'); {исходный файл} reset(f); {открываем его для чтения} assign(g,'SrAr1.txt'); {создаем новый файл} rewrite(g); {открываем его для записи} write('k=');readln(k); {Ввводим к, лучше не очень большое} j:=0; while not eof(f) do begin j:=j+1; read(f,cs[j]); {считываем числа в массив} end; close(f); writeln('Ishodny massiv:'); for i:=1 to j do write(cs[i],' '); {выводим на экран для контроля} readln; writeln; {считаем среднее арифметическое по условию} n:=1;q:=0; while k*n*(n+1)div 2<=j do begin sum:=0;t:=k*n*(n-1)div 2;p:=k*n*(n+1)div 2; for i:=t+1 to p do begin sum:=sum+cs[i]; end; sr[n]:=sum/(p-t); q:=q+k*n; n:=n+1; end; if q<>j then {если граница интервала не совпадает с концом массива} begin sum:=0; for i:=q+1 to j do begin sum:=sum+cs[i]; end; sr[n]:=sum/(j-q); {то считаем сред. арифм. последнего фрагмента} end else n:=n-1; {иначе уменьшаем количество элементов второго массива} writeln('Massiv sredn. arifm.:'); for i:=1 to n do begin write(g,sr[i]:6:2);{записываем массив в новый файл} write(sr[i]:6:2); {выводим для контроля на экран} end; readln; writeln(g,''); close(g); {закрываем файл} reset(g); {открываем для чтения} n:=0; while not eof(g) do begin n:=n+1; read(g,sr[n]); {считываем массив из файла } end; writeln; {сортируем его по возрастанию} for i:=1 to n-1 do for j:=1 to n-1 do if sr[j]>sr[j+1] then begin bf:=sr[j]; sr[j]:=sr[j+1]; sr[j+1]:=bf; end; close(g); {закрываем файл} append(g); {открываем для добавления данных} writeln('Otsort. massiv:'); write(g,'Otsort. massiv:'); writeln(g,''); for i:=2 to n do begin write(g,sr[i]:6:2); {записываем отсорт. массив в файл} write(sr[i]:6:2); {выводим его для контроля на экран} end; readln; close(g); {закрываем файл} end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 01.05.2008, 23:22

Вопрос № 134.640

Добрый день, уважаемые эксперты. Не увлекаюсь паскалем, но столкнулся с необходимостью написать несложную программу. С алгоритмом проблем нет, но вот встретилась одна неприятность. Задача такова - протабулировать функцию на заданном промежутке. Промежуток - [-1,1]. На нём нужно взять 20 точек. Делаю цикл. Код в приложении. Неприятность в том, что когда x должен стать равен 0, он становится равен непонятно чему. Например "-1,3878Е-16". Выглядит так. step получается равным 0.1. x изначально равено -1. Ну и в цикле к нему каждый раз прибавляется 0.1 - -0.9, -0.8, -0.7. И вот после прибавления 0.1 к -0.1 происходит что-то непонятное. Я так понимаю что это какая-то особенность паскаля. Каким образом это можно решить/обойти? Заранее спасибо. Приложение: var a, b: integer; x, step: real; begin a := -1; b := 1; step := (b-a)/20; x := a; while x <= b do begin /*Здесь выполнение функции*/ x := x+step; end; end.

Отправлен: 29.04.2008, 10:08 Вопрос задал: Драк Георгий (статус: 3-ий класс) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Драк Георгий! Это не есть особенность Паскаля, а особенность вещественных чисел. Попробуйте протабулировать эту функцию или например sinx в Excel и вы ни в одной ячейке не уводите 0, а именно числа типа "-1,3878Е-16", т.е. близкие к нулю. При операциях с ними никогда не получится ноль, т. к. в памяти процессора будет хранится число весьма близкое к нулю, но не ноль. Когда Вы делите вещественное число 2,0 на вещественное число 20,0 Вы никогда не получите ровно 0,1. Чтобы избежать таких чисел, нужно применять форматированный вывод чисел, например write(x:5:2) и Вам выведет число 0,00. Еще маленькое замечание. Если условие написано правильно и на интервале [-1,1] нужно получить 20 точек, то интервал нужно делить не на двадцать, а на 19, т.к. две точки у Вас определены и нужно еще 18, т.е. шаг табуляции будет (b-a)/19, тогда после 19-го шага Вы придете в 20-ую точку.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 29.04.2008, 11:45 Оценка за ответ: 5 Комментарий оценки: О, а про шаги я и правда не подумал. Ведь на самом деле лишний шаг получался. Спасибо за то что указали на эту неточность.

Отвечает: Santa Здравствуйте, Драк Георгий! Если копать глубоко, то считай что это особенность паскаля("В отличие от порядковых типов, значения которых всегда сопоставляются с рядом целых чисел и, следовательно, представляются в ПК абсолютно точно, значения вещественных типов определяют произвольное число лишь с некоторой конечной точностью, зависящей от внутреннего формата вещественного числа" "...в этом случае получаются простым усечением результатов до нужных размеров и применяются в основном для экономии памяти." Не знаю твоего точного алгоритма, но если тебе надо взять несколько точек на заданном промежутке, то Приложение: var i,s : integer; b,a,x, step: real; begin a :=-1; // граница слева b := 1; // граница справа s:=20; // колличество биений for i:=0 to s do begin x:=a+((b-a)/s)*i; //твоя процедура end; end;

Ответ отправил: Santa (статус: 1-ый класс) Ответ отправлен: 29.04.2008, 11:45 Оценка за ответ: 5 Комментарий оценки: Спасибо, тоже весьма неплохой вариант решения задачи.

Отвечает: Delph Здравствуйте, Драк Георгий! Сразу уточню одну деталь. Запись "-1,3878Е-16" означает -1,3878, умноженное на 10 в степени -16. Иными словами имеем число, очень близкое к нулю. Близкое, но не равное - из-за ошибок округления. Ошибки округления можно уменьшить, используя типы Double и Extended, но для этого в среде Turbo Pascal должны быть выставлены опции эмуляции и использования математического сопроцессора (Options ==> Compiler, установить обе галочки под Numeric Processing). Есть и обходной манёвр, повышающий точность, но его придётся подстраивать под каждую конкретную задачу. Добавьте в программе целую переменную i, и напишите такой цикл вместо While: for i := -10 to 10 do begin x := i / 10; {нужные вам действия} end; Такой подход заведомо не универсален, но зато переменная x на каждом шаге будет получать нужное значение с максимально возможной точностью. Для вывода вещественных чисел можно использовать форматированный вывод. Например оператор WriteLn(3.12159265:6:3); выведет на экран 3.121. Число после первого двоеточия означает общее число позиций на экране, которые отводятся под выводимое значение, второе - число цифр после десятичной точки. Второе число должно быть меньше первого. Аналогично можно выводить и значение переменных: WriteLn(x:6:3);. Если есть необходимость красиво оформить вывод целых чисел, то указывается лишь общее количество позиций для каждого числа: WriteLn(i:4);. --------- Сомневайся во всём! Реальность часто бывает не такой, как мы о ней думаем.

Ответ отправил: Delph (статус: Практикант) Ответ отправлен: 29.04.2008, 12:15 Оценка за ответ: 5 Комментарий оценки: Больше спасибо. Ответ очень помог.

Вопрос № 134.675

Мог бы кто нибудь нарисовать фигуру Номер 10 (рисунок в приложении) там есть небольшой дифект c треугольником но он должэн быть ровным.зарание спасибо http://yy.lv/download.php?f=126691 Приложение: http://yy.lv/download.php?f=126691

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Stingi! Ваша фигура представляет мз себя комбинацию сектора с радиусом R, углом разворота 0 – 270 градусов и прямоугольного треугольника с катетами = R. Заполненный сектор – стандартная фигура, а треугольник задаем как массив точек. Рисуем их, потом рисуем оси и делаем подписи. Все. Код с пояснениями в приложении. Приложение: uses crt,graph; const n=3; type Tpoint=record {тип точка с полями координатами} x,y:integer; end; var x0,y0,R:integer; {центр сектора} p:array[1..n]of Tpoint; {массив вершин треугольника} gd,gm:integer; {константы графического режима} begin clrscr; Write('R=');readln(R); InitGraph(gd,gm,'d p7gi'); {указываем путь к папке BGI} x0:=getmaxX div 2; y0:=getmaxY div 2; {центр экрана} SetfillStyle(1,7); {стиль заполнения} Sector(x0,y0,0,270,R,R); {сектор} p[1].x:=x0;p[1].y:=y0;p[2].x:=x0+R;p[2].y:=y0;p[3].x:=x0;p[3].y:=y0+R; {координаты вершин треугольника} setcolor(7); {цвет линии} setlinestyle(0,0,1); {стиль заполнения} FillPoly(3,p); {треугольник} Setcolor(4); {цвет линий осей и линии осей} line(100,y0,540,y0);line(x0,50,x0,470); OutTextXY(x0-R-20,y0+15,'-2'); {подписи} OutTextXY(x0+R,y0+15,'2'); readln; RestoreCrtMode; {выход в текстовый режим, если нужен выход из графического режима полный, то CloseGraph;} end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 30.04.2008, 07:45 Оценка за ответ: 5 Комментарий оценки: ogromnoe sposibo

Вопрос № 134.746

приветик)подскажите как решить задачку:Дан одномерный массив числовых значений,насчитывающий Т элементов.Вставить новый элемент С в массив на место С № K.Количество элементов при этом увеличивать на единицу.

Отправлен: 29.04.2008, 22:01 Вопрос задала: Сысоева Евгения Сергеевна (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Santa Здравствуйте, Сысоева Евгения Сергеевна! mas - исходный массив buf - дублируемый массив x - количество елементов в исходном массиве i - "Движок цикла" k - позиция нового элемента a - новый элемент Приложение: var x,i,k,a:integer ; mas:array[1..100] of integer; buf:array[1..100] of integer; begin writeln('Vvedite kolichestvo elementom massiva') ; readln(x); for i:=1 to x do begin writeln('vvedite ',i,' elementy massiva'); readln(mas[i]); buf[i]:=mas[i]; end; writeln('vvedite poziciu novogo elementa'); readln(k); writeln('vvedite novyi element'); readln(a); mas[k]:=a; for i:=k+1 to x+1 do mas[i]:=buf[i-1]; inc(x); writeln('elementy novogo massiva'); for i:=1 to x do writeln('Element#',i,'=',mas[i],''); readln; end.

Ответ отправил: Santa (статус: 1-ый класс) Ответ отправлен: 30.04.2008, 09:03 Оценка за ответ: 5 Комментарий оценки: спасибо большое)А к этой задаче вы не можете составить тест и алгоритм)

Вопрос № 134.764

Доброй ночи уважаемые эксперты, нужна ваша помощь. Пытался написать програму в паскале и в С++ которая переводила бы дробное число из одной СС в другу. Так ничего и неполучилось. Вот такое задание: Ввод: дробное число в 10-й СС, конечная СС(в которую надо перевести), число знаков в дробной части конечного представления(округление) Вывод: получившеесе округленное число. Надеюсь на вашу помощь.

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

Отвечает: Denisss Здравствуйте, Neznaika! Пример находится в приложении. Перевод дробных десятичных чисел в другие системы счисления осуществляется в два этапа: сначала переводится целая часть, затем дробная. В примере производится перевод из 10СС в произвольную СС: от 2СС до 36СС (10 цифр + 26 латинских символов). Удачи! Приложение: program Q134764; {$N+} uses Crt; const AX: array [0..35] of Char = ( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'); {Перевод целой части из 10СС в произвольную} function dIntToXSystem(const aDec: Integer; const X: Byte): String; var iDec, iTmp, i: Integer; sOut: String; bMinus: Boolean; begin dIntToXSystem:= ''; if (X > 36) or (X < 2) then begin Exit; end; iDec:= aDec; sOut:= ''; bMinus:= (iDec < 0); if bMinus then iDec:= -iDec; iTmp:= iDec; if (iTmp = 0) then sOut:= '0' else while (iTmp > 0) do begin iTmp:= iTmp div X; sOut:= AX[iDec - (iTmp * X)] + sOut; iDec:= iTmp; end; if bMinus then sOut:= '-' + sOut; dIntToXSystem:= sOut; end; {Перевод дробной части числа из 10СС в произвольную} function dFractToXSystem(const aFrac: Double; const X, prec: Byte):String; var dFrac: Double; sOut: String; i: Byte; begin sOut:= '.'; dFrac:= aFrac; if (dFrac < 0.0) then dFrac:= -dFrac; if (dFrac = 0.0) then sOut:= '.0' else begin i:= 0; while ((dFrac > 0.0) and (i < prec)) do begin dFrac:= dFrac * X; sOut:= sOut + AX[Trunc(dFrac)]; dFrac:= Frac(dFrac); Inc(i); end; while (sOut[Length(sOut)] = '0') do Delete(sOut, Length(sOut), 1); if (Length(sOut) = 1) then sOut:= '.0'; end; dFractToXSystem:= sOut; end; {Перевод числа из 10СС в произвольную} function DecToXSystem(const aDec: Double; const X, prec: Byte): String; begin DecToXSystem:= dIntToXSystem(Trunc(aDec), X) + dFractToXSystem(Frac(aDec), X, prec); end; var aDec: Double; X, prec: Byte; begin {Очистка экрана} ClrScr; {Ввод данных} write('Chislo: '); readln(aDec); write('Sistema schislenija: '); readln(X); write('Okruglenie: '); readln(prec); {Вывод результата} writeln('Resultat: ', DecToXSystem(aDec, X, prec)); {Ожидание нажатия пользователем любой кнопки} WriteLn; WriteLn('Press any key...'); ReadLn; end. --------- Будь осторожен, когда молишься ради чего-то, потому что можешь это получить...

Ответ отправил: Denisss (статус: Профессионал) Россия, Москва ICQ: 281599577 ---- Ответ отправлен: 03.05.2008, 12:52

Вопрос № 134.832

Доброе время суток. У меня такой вопрос. Дано задание, в графическом режиме нарисовать круг (диаметры выбрать произвольно), далее с клавиатуры ввести координаты точки, и программа должна вывести на экран сообщение, находится эта точка вне круга, на линии, или внутри круга. Уважаемые эксперты, помогите пожалуйста.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Dark Wanderer! Решение задачи в приложении. Сначала рисуем окружность, выходим в текстовый режим, задаем параметры точки. Снова рисуем окружность, добавляем точку и выводим текст, согласно условию задачи. Если расстояние точки от центра окружности больше R, то за пределами, если меньше – внутри, если рано – на линии. Для определения расстояния используем формулу окружности: x^2+y^2=R^2. Цвет, размеры, положение, толщина линий, шрифт и прочее на ваше усмотрение. Приложение: uses crt,graph; var x0,y0,R,x1,y1:integer; gd,gm:integer; begin clrscr; {задаем координаты центра окружности и радиус} write('x0=');readln(x0); write('y0=');readln(y0); Write('R=');readln(R); {инициализация графического режима} InitGraph(gd,gm,'d p7gi'); {Рисуем окружность красным цветом} Setcolor(4); Circle(x0,y0,R); readln; RestoreCrtMode;{выходим в текстовый режим, вводим коорд. точки} write('x1=');readln(x1); write('y1=');readln(y1); {снова инициализация графического режима} InitGraph(gd,gm,'d p7gi'); {рисуем окружность и точку} setcolor(5); circle(x0,y0,R); PutPixel(x1,y1,15); {Выводим соответствующую надпись} TextColor(10); if sqr(x0-x1)+sqr(y0-y1)=sqr(R) then OutTextXY(300,460,'Na linii') else if sqr(x0-x1)+sqr(y0-y1)<sqr(R) then OutTextXY(300,460,'Vnutri kruga') else OutTextXY(300,460,'Snaruzi kruga'); readln; RestoreCrtMode; end.

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

Вопрос № 134.918

Подскажите как можно округлить дробное число Х с точностью У.

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

Отвечает: SHERRY Здравствуйте, Neznaika! Ну, можно, к примеру, так: x:=round(x*y)/y; где у = 10^N (N -> знак, до которого нужно округлить) для этого "x" лучше делать не real'ом, а extended'ом. Других способов не знаю, не нужно было пока. --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 8-ой класс) Ответ отправлен: 01.05.2008, 13:48 Оценка за ответ: 5

Вопрос № 134.999

Доброго времени суток. Написал такую программу: в целочисленном массиве из 30 элементов удалить все повторяющиеся элементы, а оставшиеся вывести в порядке возрастания. Все бы хорошо, да без дополнительного условия b[i]<>0 (4 строчка снизу) выводится лишний ноль. Помогите разобраться. Приложение: program sdglksdg; uses crt; var i,j,k,m,temp:integer; a,b:array[1..30] of integer; setofint:set of byte; begin k:=0; m:=1; setofint:=[]; readln; randomize; writeln('old '); for i:=1 to 30 do begin a[i]:=random(15); write(a[i]:3); end; for i:=1 to 30 do begin k:=0; for j:=1 to 30 do if a[i]<>a[j] then inc(k); if k=29 then include(setofint,a[i]); end; for i:=1 to 30 do if a[i] in setofint then begin b[m]:=a[i]; inc(m); end; writeln; writeln('new '); for i:=1 to m do for j:=m downto i do if b[i]>b[j] then begin temp:=b[i]; b[i]:=b[j]; b[j]:=temp; end; for i:=1 to m do {if b[i]<>0 then} write(b[i]:3); readln; clrscr; end.

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

Отвечает: Зенченко Константин Николаевич Здравствуйте, Vitaliy! Ваша ошибка в строчках: k:=0; m:=1;{тут поставьте равно 0} . . b[m]:=a[i];{Вы записали первый элемент массива} inc(m);{и увеличили счетчик, теперь в масииве уже 2-а элемента, а записан только один} Поставьте М:=0; и указанные строчки цикла поменяйте местами. Удачи! --------- И только наступив на грабли мы приобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Профессионал) Украина, Киев Тел.: +380958380164 Адрес: Украина г.Киев ---- Ответ отправлен: 02.05.2008, 11:29 Оценка за ответ: 5 Комментарий оценки: Спасибо.

Вопрос № 135.070

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

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Chistiak81! Задачи 1, 3, 5 в приложении Удачи!!! Приложение: {№1} const N=10; {Длина массива} var A: array [1..N] of integer; {сам массив} Count, i: integer; {count-кол-во изменений знака, i-счетчик для циклов For} procedure Randoming; {Заполняет массив случаными числами из промежутка [-50; 0) U (0; 49]} begin randomize; {включаем генератор случайных чисел} for i:=1 to N do {перебираем массив} begin A[i]:=random(100)-50; {присваиваем тек-му эл. массива случайное число} if A[i]=0 then {если число равно 0, то увеличиваем его на 1, т.о. мы избаляемся от нулевых элементов} inc(A[i]); Write(A[i], ' '); {выводим через пробел} end; end; begin WriteLn('Исходный массив: '); Randoming; {вызываем нашу процедуру} Count:=0; {обнуляем счетчик} for i:=2 to N do {перебираем массив} if A[i]*A[i-1] < 0 then {проверяем, изменился ли знак в A[i] по сравнению с A[i-1]} inc(count); {если изменился то увеличиваем счетчик на 1} WriteLn('Кол-во изменений знака: ', count); {вывод рез-тов} readln; end. {№3} var Str, ResStr: string; {Str-строка, ResStr-рез-тат} i: integer; {счетчик для For} begin Write('Введите строку: '); ReadLn(Str); {Получаем строку} For i:=Length(Str) downto 1 do {Перебираем с конца к началу всю строку} ResStr:=ResStr+Str[i]; {Добавляем текущий символ к рез-ту} WriteLn('Рез-тат: ', ResStr); {Вывод} ReadLn; end. {№5} Uses Graph; var Mode, Driver: integer; begin Driver:=Detect; InitGraph(Driver, Mode, ''); If GraphResult<>0 then Writeln('Ошибка!') else begin SetColor(red); Circle(50, 50, 50); readln; CloseGraph; end; ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 02.05.2008, 21:35 Оценка за ответ: 5

Отвечает: Пупорев Юрий Борисович Здравствуйте, Chistiak81! Решение задач 2 и 4 в приложении. По задаче 4 отмечу, что кодировка символов русских букв в Блокноте и Паскале не совпадают, поэтому в программе пишем не символ'в', который при переносе из блокнота в Паскаль превращается в 'т', а символ с кодом 226. Все остальное стандартно и должно быть понятно. Если не знаете какие-то процедуры и функции, посмотрите а справке. Приложение: Задача 2. uses crt; const n=6; var a:array[1..n,1..n]of integer; i,j,sum:integer; begin clrscr; sum:=0; for i:=1 to n do begin for j:=1 to n do begin a[i,j]:=random(20); write(a[i,j]:4); if j=i then {главная диагональ} sum:=sum+a[i,j]; end; writeln; end; writeln('sum=',sum); readln end. Задача 4. uses crt; var f,g:text; s:string; i:integer; begin clrscr; assign(f,'BukvaB.txt'); reset(f); assign(g,'BukvaBB.txt'); rewrite(g); while not eof(f) do begin readln(f,s); for i:=length(s)downto 1 do begin if s[i]=chr(226)then begin insert(s[i],s,i+1); end; end; writeln(g,s); end; writeln('FAIL BUKVA BB ZAPISAN!!!'); readln; close(f); close(g); end.

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

Вопрос № 135.072

Уважаемые эксперты!помогите пожалуйста решить задачу!: Выполнить обработку элементов прямоугольной матрицы А, имеющей N строк и М столбцов. Перемножить элементы каждого столбца матрицы с соответствующими элементами К-го столбца. Спасибо!)

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

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Igor lukashov! Задача с комментариями в приложении Удачи!!! Приложение: const N=5; {кол-во строк} M=10; {кол-во столбцов} var A, Res: array [1..N, 1..M] of Integer; {A-исходная матрица, Res-рез-тат обработки} i, j, K:integer; {i,j-счетчики для For, k-номер столбца} begin randomize; {Включаем генератор случайных чисел} WriteLn('Исходная матрица: '); for i:=1 to N do {Заполняем матрицу А случайными числами и заодно выводим её на экран} begin for j:=1 to M do begin A[i, j]:=random(50)-25; Write(a[i,j], ' '); end; WriteLn; end; repeat {получаем K, если оно больше кол-ва столбцов, то повторяем ввод} Write('Введите K: '); ReadLn(K); until k<=M; WriteLn('Результат: '); for i:=1 to N do {Выводим рез-тат} begin for j:=1 to M do begin Res[i, j]:=A[i, j]*A[i, k]; Write(Res[i,j], ' '); end; WriteLn; end; ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 02.05.2008, 22:47 Оценка за ответ: 5

Вопрос № 135.154

Помогите, пожалуйста! Как написать программу, выполняющу деление чисел восьмиичной системы?

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

Отвечает: SHERRY Здравствуйте, Byzly! В приложении 2 функции по переводу целого числа в восьмеричную систему из десятиричной и обратно. Функции нашёл гуглом - поэтому не разбирался и не писал комментарии за отсутствием на данный момент времени. Разбирайтесь. Приложение: function OctToInt(Value: string): Longint; var i: Integer; int: Integer; begin int := 0; for i := 1 to Length(Value) do begin int := int * 8 + StrToInt(Copy(Value, i, 1)); end; Result := int; end; function IntToOct(Value: Longint; digits: Integer): string; var rest: Longint; oct: string; i: Integer; begin oct := ''; while Value <> 0 do begin rest := Value mod 8; Value := Value div 8; oct := IntToStr(rest) + oct; end; for i := Length(oct) + 1 to digits do oct := '0' + oct; Result := oct; end; --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 8-ой класс) Ответ отправлен: 03.05.2008, 18:52 Оценка за ответ: 4 Комментарий оценки: Спасибо! Правда, функции как-то неособо работают, выбрасывает 202 ошибку...

Вопрос № 135.166

Доброго времени суток и с праздником. У меня возникли проблемы с решениями задач: 1) Дана целочисленная матрица. Определить сумму элементов в тех строках, которые содержат хотя бы один отрицательный элемент. Оформить ввиде функции. Проблема: Задачу решил, но оформить процедуру не получилось 2) Оформить массив записей, который содержит справочную информацию о сотрудниках фирмы. Определить и вывести сотрудника с наибольшим окладом. Проблема: не получается вывести строку, где есть содержится наибольший оклад. 3) В типизированом файле записаны название городов и их численность. Увеличить численность города на 5%. Проблема: не могу понять как произвести считываниезапись построчно или посимвольно. Пожалуйста помогите. Если не трудно то с комментариями, буду благодарен. Внизу привел тексты программ 1 и 2 задачи Приложение: 1) var a:array[1..6,1..7] of integer; b,c:array[1..7] of integer; k,i,j:byte; begin clrscr; randomize; for i:=1 to 6 do for j:=1 to 7 do a[i,j]:=-5+random(21); writeln('Целочисленная матрица сформированная случайным образом'); for i:=1 to 6 do begin for j:=1 to 7 do write(a[i,j]:3); writeln; end; for i:=1 to 6 do for j:=1 to 7 do if a[i,j]<0 then inc(b[i]); writeln('Количество отрицательных элементов'); for i:=1 to 6 do writeln('строка ',i,' ',b[i]); for i:=1 to 6 do if b[i]>=1 then begin for i:=1 to 6 do for j:=1 to 7 do if b[i]<>0 then c[i]:=c[i]+a[i,j]; end; writeln('Сумма строк в которых содержится хотя бы один отрицательный элемент'); for i:=1 to 6 do writeln('сумма ',i,' строки=',c[i]); readln; end. 2) uses crt; const n=3;m=4; var a:array[1..n,1..m] of string; i,j:byte; max:string; begin clrscr; for i:=1 to n do for j:=1 to m do begin writeln(i,' ',j,' '); readln(a[i,j]);end; {вывод матрицы} writeln('Фамилия':10,'Таб.Номер':10,'Должность':10,'Зарплата':10); for i:=1 to n do begin for j:=1 to m do write(a[i,j]:10); writeln; end; {поиск максимального} begin max:=a[1,4]; for i:=2 to 4 do if a[i,4]>max then max:=a[i,4]; end; writeln(max); readln; end.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, DaImeR! По первой задаче. Вы сделали программу явно не оптимально. Ввод матрицы можно делать одним циклом, а не двумя, как у Вас. У Вас совершенно лишние два массива, Вы зачем-то выводите сколько отрицательных элементов в какой строке, что не требуется по условию. Вам нужно оформить все это в виде подпрограммы. Здесь Вы начинаете путаться, сначала у Вас это функция, потом процедура. Для того, чтобы передать основную нагрузку в подпрограмму, лучше сделать процедуру, т.к. в функцию мы можем передать только собственно нахождение суммы, а это всего две строчки программы. Переделал Вашу программу, вставил процедуру, по возможности старался сохранить Ваш стиль. Можно и Вашу программу сделать с процедурой, только это будет некрасивая программа. В приложении код с пояснениями. По второй задаче. Прежде чем создавать массив записей, нужно создать сами записи, а точнее определить их как тип Record с полями по условию. Как это делается, нужно почитать в учебниках, ну а как пример код вашей задачи в приложении. По третьей задаче. Также создаем тип запись, с указанными полями. Создаем типизированный файл того же типа, что и запись. Вводим данные в файл. Затем считываем данные из файла и делаем с этими данными то, что указано в условии. Считывание из типизированного файла призводится только процедурой Read. Считывание идет не по строчкам или символам, а по типу данных. Если у нас сначала идет название строкового типа, то считываться будет первая переменная строкового типа. Затем будет считываться число. Потом все повторяется. Если данные будут внесены неправильно, то числа как строки будут считываться, а строки как числа нет, т.к. не соответствует тип. Вообще скачайте себе какой-нибудь учебник и прочитайте. Здесь цитировать главы из учебника как-то неудобно. Приложение: Задача 1. uses crt; const n=6; m=7; type Tmatr=array[1..n,1..m] of integer; var a:Tmatr; i,j:byte; sum:integer; Procedure Summ(b:Tmatr;var x:integer); var k,t:byte; begin for i:=1 to n do begin k:=0;x:=0; {k-количество отрицательных в строке x- сумма} for j:=1 to m do begin if a[i,j]<0 then inc(k); { считаем отрицательные} end; if k>0 then { если есть } begin for t:=1 to m do begin x:=x+a[i,t]; {считаем сумму} end; writeln('Summa v stroke ',i,'=',x); end; end; readln; end; begin clrscr; randomize; writeln('Ishodnaja matrica:'); for i:=1 to n do begin for j:=1 to m do begin a[i,j]:=-5+random(21); {присваиваем значения} write(a[i,j]:3); {выводим в строку} end; writeln; {новая строка} end; Summ(a,sum); {вызов процедуры} end. Задача 2. uses crt; type Tsotr=record fam:string[20]; tab:word; dolz:string[20]; zarp:integer; end; var sp:array[1..50] of Tsotr; {массив записей} max:integer; n,i:byte; begin clrscr; write('Vvedite kolichestvo sotrudnikov:'); readln(n); for i:=1 to n do begin writeln('Sotrudnik ',i); write('Familia:');readln(sp[i].fam); write('Tabelny nomer: ');readln(sp[i].tab); write('Dolznost: ');readln(sp[i].dolz); write('Zarplata: ');readln(sp[i].zarp); end; max:=sp[1].zarp; for i:=1 to n do if sp[i].zarp>max then begin max:=sp[i].zarp; {находим максимальную зарплату} end; writeln; writeln('Sotrudnik s samym bolshim okladom:'); for i:=1 to n do if sp[i].zarp=max then {находим сотрудника с макс. зарплатой и выводим сведения о нем} begin writeln(sp[i].fam,' tab # ',sp[i].tab,' dolznost ',sp[i].dolz,' zarplata ',sp[i].zarp); {это надо в одну строку} end; readln end. Задача 3. uses crt; type Tgorod=record {запись город с полями название и численность} name:string[20]; chis:longint; end; var f:file of Tgorod; {типизированный файл} sp:Tgorod; n,i:integer; ch:char; {символ для остановки записи в файл} begin clrscr; assign(f,'Gorod.dat'); {создаем файл и присваиваем ему имя} rewrite(f); {открываем файл для записи} repeat {в цикле вводим данные в файл} write('Gorod: ');readln(sp.name); write('Chislennost: ');readln(sp.chis); write(f,sp); {собственно ввод в файл} ch:=readkey; until ch=#27; {для остановки записи нажимаем Esc} close(f); {закрываем файл} reset(f); {открываем его для чтения} writeln; writeln('Chislennost + 5%:'); while not eof(f )do begin read(f,sp); {считываем данные из файла, преобразуем их и выводим на экран} writeln('Cislennost v gorode ',sp.name,' ', round(sp.chis*1.05)); end; readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 04.05.2008, 09:29 Оценка за ответ: 5

Вопрос № 135.174

Помогите пожалуйста кто может решить в Pascale несколько задач пожалуйста(для зачета):1. Дан массив P(N) из N чисел. Найти максимальный элемент массива и его порядковый номер. 2. Дан массив X(N). Получить новый массив Y(N) такой, что в нем сначала идут положительные числа, затем нулевые, и затем отрицательные из X. 3. В заданном массиве A(N) определить количество элементов, которые меньше заданного значения. 4. В заданном массиве A(N) вычислить среднее геометрическое и среднее арифметическое значения для положительных элементов. Четыре задачки нужно решить пожалуйста помогите решить кто может!

Отправлен: 03.05.2008, 17:27 Вопрос задал: Черепанов Алексей Витальевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Черепанов Алексей Витальевич! Задачи 1 и 3 настолько простые, что Вы обязаны их решить сами. Это, извините, просто лень. Такие задачки рассматриваются в главах про массивы практически в любом учебнике, стоит только скачать его и прочитать. Для того Вы и учитесь. Задачи 2 и 4 тоже из разряда простых, но там хоть немного подумать надо, поэтому я их Вам решил. Если Вы их разберете и поймете, то задачи на массивы сможете решать сами. В первой задаче нужно создать массив, присвоить значение max первому элементу массива x[1], номеру его imax:=1; Затем в цикле сравнить все элементы массива с этим числом и каждый раз, если число больше предыдущего большого, присваивать его значение max, а его индекс imax. В третьей задаче тоже создать массив, ввести число, такое чтобы в массиве были числа меньше его, Также в цикле проверять все числа. Если число меньше (if a[i] меньше K) то считаем +1. Потом сколько насчитали, выводим на экран. В приложени и коды задач 2 и 4. Приложение: Задача 2. uses crt; var x,y:array[1..50]of integer; n,i,k:integer; begin clrscr; randomize; write('n=');readln(n); writeln('Ishodny massiv:'); for i:=1 to n do {создаем и выводим на экран массив} begin x[i]:=random(6)-2; {диапазон [-2,3]} write(x[i],' '); end; writeln; writeln('Rezultat:'); k:=0; {сначала ищем в массиве положительные числа} for i:=1 to n do if x[i]>0 then begin k:=k+1; {считаем их} y[k]:=x[i]; {заносим в новый массив} write(y[k],' '); {выводим на экран} end; {ищем нули} for i:=1 to n do if x[i]=0 then begin k:=k+1; {наращиваем к – длину нового массива} y[k]:=x[i]; write(y[k],' '); end; {ищем отрицательные} for i:=1 to n do if x[i]<0 then begin k:=k+1; y[k]:=x[i]; write(y[k],' '); end; readln end. Задача 4. uses crt; var x:array[1..50]of integer; n,i,k:integer; srar,srgm:real; begin clrscr; randomize; write('n=');readln(n); writeln('Ishodny massiv:'); for i:=1 to n do begin x[i]:=random(10)-2; write(x[i],' '); end; srar:=0;srgm:=1;k:=0; for i:=1 to n do if x[i]>0 then begin k:=k+1; srar:=srar+x[i]; srgm:=srgm*x[i]; end; srar:=srar/k; srgm:=sqrt(srgm); writeln; writeln('Srednee arifmeticheskoe=',srar:5:2); writeln('Srednee geometricheskoe=',srgm:5:2); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 04.05.2008, 11:00 Оценка за ответ: 5

Вопрос № 135.190

Дана строка.Подсчитать, сколько раз символ "f" встречается в данной строке.

Отправлен: 03.05.2008, 18:59 Вопрос задал: Гноць,Руслан,Валериевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 3)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Гноць,Руслан,Валериевич! Очень простая задача, такие задачи надо решать самостоятельно! Код с комментариями в приложении. Удачи!!! Приложение: var {count-кол-во f, i-счетчик для For} Count, I: integer; {Строка} Str: string; begin {получаем строку} Write('Введите строку: '); ReadLn(Str); {обнуляем счетчик, иначе переменная будет содержать мусор и программа выдаст не верный рез-тат} Count:=0; {Перебираем всю строку} for i:=1 to Length(str) do if Str[i]='f' then {если тек. символ == 'f' тогда увеличиваем на 1 счетчик} inc(Count); {вывод} Write('Кол-во F: ', count); ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 03.05.2008, 21:21 Оценка за ответ: 2

Вопрос № 135.193

Дан текстовой файл,содержащий целые чила.Найти среднее арифметическое.

Отправлен: 03.05.2008, 19:04 Вопрос задал: Гноць,Руслан,Валериевич (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Гноць,Руслан,Валериевич! Код с комментариями в приложении. Числа хранятся в файле data.txt в папке с программй, записаны через пробел. Удачи!!! Приложение: var {Файл с данными} f: text; {count-кол-во чисел, sum-сумма всех чисел, buf-временная переменная} count, Sum, Buf: integer; {среднее арифмитическое} Arifm: real; begin {все обнуляем} sum:=0; Arifm:=0; Count:=0; {связываем ф.п. с файлом} Assign(f, 'data.txt'); {открываем для чтения} reset(f); {обрабатываем файл} Write('Содержимое файла :'); While not EOF(f) do begin read(f, buf); Sum:=Sum+buf; inc(count); Write(buf, ' '); end; {Вывод рез-тов} writeln; WriteLn('Сумма = ', Sum, ' , кол-во = ', count); Arifm:=Sum/Count; WriteLn('Среднее арифметическое = ', Arifm:0:3); readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 03.05.2008, 21:35

Отвечает: SHERRY Здравствуйте, Гноць,Руслан,Валериевич! Вот код Вашей задачи. Подразумевается, что текстовый файл уже создан, находится в одной директории с программой и именуется 'myfile.txt'. Числа в нём должны быть записаны в строчку, разделяясь пробелом. Разбирайтесь. var f: text; { задаём файловую переменную, которая будет отвечать за текстовый файл } a,count,sum: integer; { вспомогательные переменные: а - читаемое число, count - счётчик чисел, sum - сумма } begin sum := 0; count := 0; { инициализация переменных } Assign(f, 'myfile.txt'); { сопоставляем файловой переменной файл на диске } Reset(f); { открываем файл для чтения } While not EOF(f) do { пока не достигнут конец файла } begin read(f, a); { считываем число из файла } sum := sum + a; { прибавляем его к сумме } inc(count); { увеличиваем счётчик чисел на единицу } end; writeln(sum / count :3:3); { выводим результат на экран } readln; end. --------- Самурай без меча подобен самураю с мечём, только без меча..

Ответ отправил: SHERRY (статус: 8-ой класс) Ответ отправлен: 03.05.2008, 21:38

Вопрос № 135.197

Даны два двумерных массива одинаковой размерности.Создать третий массив той же размерности,каждый элемент которого равен 1,если соответствующие элементы массивов имеют одинаковый знак,иначе элемент равен 0.

Отправлен: 03.05.2008, 19:14 Вопрос задал: Гноць,Руслан,Валериевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Гноць,Руслан,Валериевич! Задача с комментариями п приложении. Думаю, для Вас было проблемой определения одинаковы ли знаки у элементов. Вспомним математику: отрицательное*отрицательное > 0 положительное*положительное > 0 положительное*отрицательное < 0 Исходя из этого, если произведение двух чисел больше нуля, то у них одинаковые знаки, иначе разные. Удачи!!! Приложение: const N=5; {Кол-во строк в массивах} M=10; {Кол-во столбцов} Type {Объявляем тип наших массивов} OurArray = array [1..N, 1..M] of Integer; Var {Сами массивы, a,b-исходные массивы, c-рез-тат работы} a, b, c: OurArray; {счетчики для For} i, j: integer; {Выводит массив на экран, параметр-реременная-массив} procedure PrintArray(const Arr: OurArray); begin for i:=1 to N do begin for j:=1 to M do begin write(Arr[i, j]:5); end; writeln; end; end; {Главная подпрограмма} begin {Заполняем массив случайными числани} for i:=1 to N do for j:=1 to M do begin a[i, j]:=random(100)-50; b[i, j]:=random(100)-50; {Если только что созданные элементы одного знака, то соответствующий элемен массива C=1, иначе 0} if a[i, j]*b[i, j] > 0 then c[i, j]:=1 else c[i, j]:=0; end; {Выводим на экран исходные данные и результат с помощью нашей процедуры} WriteLn('Массив А: '); PrintArray(a); WriteLn('Массив B: '); PrintArray(b); WriteLn('Массив C: '); PrintArray(c); readln; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 03.05.2008, 21:20 Оценка за ответ: 5

Вопрос № 135.211

Здравствуйте Пожалуйста помогите решить несколько задач кто может помогите пожалуйста нужно для зачета:1. Дан массив P(N) из N чисел. Найти максимальный элемент массива и его порядковый номер. 2. Дан массив X(N). Получить новый массив Y(N) такой, что в нем сначала идут положительные числа, затем нулевые, и затем отрицательные из X. 3. В заданном массиве A(N) определить количество элементов, которые меньше заданного значения. 4. В заданном массиве A(N) вычислить среднее геометрическое и среднее арифметическое значения для положительных элементов. Помогите кто может пожалуйста эти задачки на одномерные массивы

Отправлен: 03.05.2008, 21:25 Вопрос задал: Черепанов Алексей Витальевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 10)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Черепанов Алексей Витальевич! Задачи 1 и 2 в приложении. Удачи на зачете!!! Приложение: {№1} const {Размер массива} N=10; var {Сам массив} P: array [1..N] of Integer; {MaxIndex-индекс(порядковый номер) мксимального элемента, Max-максимальное число, i-для For} MaxIndex, Max, i: integer; begin {Включаем генератор случайных чисел} randomize; {Заполняем массив случайными числами из диапозона [-50; 49] и заодно выводим его элементы через пробел} WriteLn('Исходный массив: '); for i:=1 to N do begin P[i]:=random(100)-50; Write(P[i], ' '); end; {Инициируем значения индекса и максимального числа} max:=P[1]; MaxIndex:=1; {перебираем массив} for i:=2 to N do {Если тек. эл. больше максимального, то запоминаем его и его индекс} if P[i] > max then begin max:=p[i]; MaxIndex:=i; end; {Начинаем новую строку} WriteLn; {Выводим рез-таты} Write('Максимальное число = ', max, ' , порядковый номер = ', MaxIndex); ReadLn; end. {№2} const {Размер массива} N=10; var {массивы X and Y} X, Y: array [1..N] of Integer; {i-счетчик для For, j-номер последнего заполненого элемента массива Y} i, j: integer; begin {включаем генератор случайных чисел} randomize; WriteLn('Исходный массив: '); {Перебираем весь массив, чтобы заполнить его случайными числами, и заодно вывести его на экран} for i:=1 to N do begin X[i]:=random(100)-50; Write(X[i], ' '); end; {Инициируем счетчик для массива Y} j:=1; {Перебираем весь массивЮ если число > 0, то добавляем его в новый массив и увеличиваем j на 1} For i:=1 to N do if X[i]>0 then begin Y[j]:=X[i]; inc(j); end; {Анологично действуем с нулевыми и отрицательными элементами} For i:=1 to N do if X[i]=0 then begin Y[j]:=X[i]; inc(j); end; For i:=1 to N do if X[i]<0 then begin Y[j]:=X[i]; inc(j); end; WriteLn; {Выводим рез-тат} Writeln('Рез-тат: '); For i:=1 to N do Write(Y[i], ' '); ReadLn; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 03.05.2008, 22:16 Оценка за ответ: 5

Вопрос № 135.219

Нарисовать на экране прямоугольник из линий красного цвета.

Отправлен: 03.05.2008, 21:54 Вопрос задал: Гноць,Руслан,Валериевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Абельхарисов Руслан / Marked One Здравствуйте, Гноць,Руслан,Валериевич! Код в приложении. Удачи!!! Приложение: Uses {Чтобы пожно было рисовать, подключаем модуль Graph} Graph; var {Driver-имя драивера, Mode-режим гр. адаптера} Driver, Mode: integer; {Здесь сохраняем код ошибки} ErrorCode: Integer; begin {Драйвер-vga} Driver:=VGA; {Самы лучший режим, поддерживаемый VGA} Mode:=VGAHi; {Инициируем графический режим} InitGraph(Driver, Mode, ''); {Получаем результат последнего действия} ErrorCode:=GraphResult; {Если он <> 0, значит случиласи ошибка, и выводим сообщение об ошибке} If ErrorCode <> 0 Then WriteLn(GraphErrorMsg(ErrorCode)) else begin {Иначе-устанавливаем цвет на красный} SetColor(red); {Рисуем многоугольник с координатами 0,0,ширина экрана / 2, высота / 2} Rectangle(0,0, GetMaxX div 2, GetMaxY div 2); {ждем нажатия на любую клавишу} readln; {Выходим из графического режима} CloseGraph; end; end.

Ответ отправил: Абельхарисов Руслан / Marked One (статус: 10-ый класс) Ответ отправлен: 03.05.2008, 22:29

Вопрос № 135.220

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

Отправлен: 03.05.2008, 21:58 Вопрос задал: Лобанов Александр (статус: 1-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Пупорев Юрий Борисович Здравствуйте, Лобанов Александр! Решение задач в приложении. По первой задаче. Это задача не на записи, а на строки. Записи, это когда используется тип Record. По второй задаче. Поскольку у Вас указаны допустимые значения n и m, то я предусмотрел проверку на допустимость вводимых значений, с использованием меток (Label 1,2). Приложение: Задача 1. uses crt; var s,s1:string; i:integer; begin clrscr; write('Text: ');readln(s); for i:=1 to length(s)do if i=pos('.',s)then {находим первую точку} s1:=copy(s,1,pos('.',s)); {копируем первое предложение в S1} delete(s,1,pos('.',s)+1); {удаляем его вместе с пробелом} s:=s+' '+s1;{ко второму педложению добавляем через пробел первое} writeln(s); readln end. Задача 2. uses crt; var T:array[1..12,1..15]of integer; n,m,i,j,max,min,imax,imin,sum:integer; label 1,2; begin clrscr; randomize; 1: write('Kolichestvo strok ot 2 do 12 = ');readln(n); if (n<2)or(n>12)then begin writeln('Povtorite vvod!'); goto 1; end; 2: write('Kolichestvo stolbcov ot 2 do 15 = ');readln(m); if (m<2)or(m>15)then begin writeln('Povtorite vvod!'); goto 2; end; for i:=1 to n do begin for j:=1 to m do begin T[i,j]:=random(10); write(T[i,j]:4); end; writeln; end; max:=0; for j:=1 to m do max:=max+T[1,j]; min:=max;imax:=1;imin:=1; for i:=2 to n do begin sum:=0; for j:=1 to m do sum:=sum+T[i,j]; if sum>max then begin max:=sum; imax:=i; end else if sum<min then begin min:=sum; imin:=i; end; end; writeln; Writeln('Maximalnaja summa v str ',imax,'=',max); Writeln('Minimalnaja summa v str ',imin,'=',min); readln end.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 04.05.2008, 16:25 Оценка за ответ: 5

Вопрос № 135.229

Здравствуйте уважаемые эксперты! Помогите пожалуйста я в отчаянье!!! Как мне запустить вот эту программу в Borland Pascal for Windows? Что мне нужно исправить в программе? Заранее Огромное Спасибо! Приложение: program bubbles; uses graph, winCrt; var gd, gm, ec, uf : Integer; begin gd := Detect; gm := 0; InitGraph(gd, gm, ''); Randomize; for gm := 1 to 500 do begin ec := ec + 1; if ec = 16 then ec := 1; SetColor(ec); Circle(Random(GetMaxX), Random(GetMaxY), Random(gd + 10)); end; SetColor(Random(White)); SetTextStyle(0,HorizDir, 5); OutTextXY(50, 20, 'Bubbles'); readKey; CloseGraph; end.

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

Отвечает: Пупорев Юрий Борисович Здравствуйте, Батурин Александр Викторович! Проверил Вашу программу в Турбо Паскале, нормально работает. Значит дело не в программе. В ТП есть файл EGAVGA.BGI. Он должен находиться в одной папке с программой или к нему должен быть указан путь, например InitGraph(gd, gm, 'd p7gi'); Вероятно в Вашем Паскале есть что-то подобное. Я просто никогда не работал в Borland Pascal for Windows.

Ответ отправил: Пупорев Юрий Борисович (статус: Практикант) Ответ отправлен: 04.05.2008, 15:05

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