Хостинг Портала RusFAQ.ru:
MosHoster.ru - Профессиональный хостинг на Windows 2008

РАССЫЛКИ ПОРТАЛА RUSFAQ.RU

Чемпионы рейтинга экспертов в этой рассылке

Botsman Статус: Студент Рейтинг: 222 ∙ повысить рейтинг >>

Micren Статус: Практикант Рейтинг: 71 ∙ повысить рейтинг >>

Тимошенко Дмитрий Статус: 7-й класс Рейтинг: 49 ∙ повысить рейтинг >>

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

Выпуск № 865
от 28.04.2009, 02:35

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

Вопрос № 165.571

Здравствуйте уважаемые эксперты. Имеется следующая функция в программе (код приведен в приложении), вычисляющая произведение суммы двух длинных чисел, представленных в виде строк. Проблема в том, что чем числа больше, тем функция медленнее работает. Может быть можно как-то ее оптимизировать? Небольшое уточнение: программа пишется для вычисления наименьшего общего кратного двух длинных чисел (более 25 знаков) и сделать ее нужно именно с использованием строк. Вариант с массивом не подходит. Заранее благодарю за содействие. Приложение: program z_13_12_2; uses crt; var st1,st2: string; {-- Функция контроля входной строки -----------------------------------------} function check(x,y: byte): string; var ch: char; cx: byte; res: string; begin cx:=x; res:=''; {Пока не нажата клавиша Enter...} while ord(ch)<>13 do begin ch:=readkey; {Множество допустимых символов} if ch in ['0'..'9'] then begin gotoxy(x,y); write(ch); res:=res+ch; {Сдвиг вправо по строке} inc(x); end {Обработка нажатия клавиши [Backspace]} else if (ord(ch)=8) and (x>cx) then begin gotoxy(wherex-1,wherey); clreol; dec(x); delete(res,length(res),1); end; end; check:=res; writeln; end; {-- Процедура выравнивания длины двух строк ---------------------------------} procedure addzero(var x:string; var y: string); begin repeat if length(x)>length(y) then y:='0'+y; if length(x)<length(y) then x:='0'+x; until length(x)=length(y); end; {-- Функция вычисления суммы двух чисел -------------------------------------} function summa(x,y: string): string; var res,s: string; a,b,c,e,i: integer; begin addzero(x,y); c:=0; res:=''; for i:=length(x) downto 1 do begin val(x[i],a,e); val(y[i],b,e); str(a+b+c,s); if length(s)=2 then begin c:=1; if i<>1 then s:=copy(s,2,1); end else c:=0; res:=s+res; end; summa:=res; end; {-- Функция вычисления произведения -----------------------------------------} function mult(s1,s2: string): string; var i,res,x,y: string; begin res:='0'; i:='1'; {Меньшее число должно быть в X} addzero(s1,s2); if s1<=s2 then begin x:=s1; y:=s2; end else begin x:=s2; y:=s1; end; {Дополнение счетчика нулями} addzero(i,y); while i<=y do begin res:=summa(res,x); {Инкремент счетчика} i:=summa(i,'1'); end; mult:=res; end; {-- Начало основной программы -----------------------------------------------} begin repeat {Ввод первого числа} clrscr; write('Введите первое число: '); st1:=check(23,1); until st1<>''; repeat {Ввод второго числа} gotoxy(1,2); clreol; write('Введите второе число: '); st2:=check(23,2); until st2<>''; end.

Отправлен: 22.04.2009, 13:04 Вопрос задал: Quikk (статус: 5-й класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 7)

Отвечает: Тимошенко Дмитрий Здравствуйте, Quikk! Я тут набросал процедуру умножения через умножение. (приложение) Работает существенно быстрее :) Только в программе надо добавить определение константы nul='0000 ... 0000'; (строка в 254 нуля, или меньше если числа будут короче. А ваш код оптимизировать уже некуда. Могу только предложить изменить процедуру addzero на вот такую: procedure addzero(var x:string; var y: string); begin y:=copy(nul,1,length(x)-length(y))+y; x:=copy(nul,1,length(y)-length(x))+x; end; Опять же использует определение константы nul. А лучше эти строки вставить в код вместо вызова процедуры, хотя бы в функции summa, т.к. вызов процедуры - весч довольно накладная в смысле процессорного времени. Так должно быть побыстрее, хотя наверное и не на много. С уважением, Дмитрий Приложение: { Умножение умножением :) } function mult2(s1,s2: string): string; var res,pr,s: string; a,b,c,e,i,j: integer; begin res:='0'; for i:=length(s2) downto 1 do begin val(s2[i],a,e); c:=0; pr:=''; { Считаем произведение s1 на i-ю цифру s2 и заносим в pr} for j:=length(s1) downto 1 do begin val(s1[j],b,e); str(b*a+c,s); if length(s)=2 then begin val(s[1],c,e); if j<>1 then s:=copy(s,2,1); end else c:=0; pr:=s+pr; end; { Затем прибавляем pr сдвинутое влево на length(s2)-i разрядов к результату } pr:=pr+copy(nul,1,length(s2)-i); res:=summa(res,pr); end; Mult2:=res; end;

Ответ отправил: Тимошенко Дмитрий (статус: 7-й класс) Ответ отправлен: 22.04.2009, 23:05 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248065 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это! Оценка за ответ: 5 Комментарий оценки: Большое спасибо за помощь!

Вопрос № 165.582

Зравствуйте уважаемые эксперты! Очень нужна ваша помощь.Необходимо разобраться в небольшой программе, а именно дописать коментарии. Задача принадлежит к классу комбинаторики. Вот задание "Задача о трех станках. Даны N деталей, каждая из которых должна быть обработана на станке A, затем на станке B, затем на станке C. Каждый станок может в данный момент времени обрабатывать только одну деталь. Если нужный станок занят, то другие детали могут ожидать его освобождения. Для каждой детали известны длительности ее обработки на каждом станке: TAi, TBi, TCi. Требуется найти такой порядок запуска деталей на обработку (т.е. найти такую перестановку номеров деталей), при котором длительность обработки всего комплекта деталей минимальна." В ниже приведенной программе задача рашается двумя алгоритмами 1)метод перебора-соответсвенно в программе она называется процедурой "perebor" 2) методом последовательного выбора(эвристический алгоритм) в программе называется пр оцедурой "evristika" Очень прошу вашей помощи. Особенно нужны коментарии в начале где основные переменные описаны и в процедурах "calc" и "evristika" по этой ссылке http://slil.ru/27474819 я залил текстовый файл in.txt нужный для программы - в нем записана сама матрица. В этой матрице 1000 строк -соответсвенно 1000 деталей, и 3 столбца соответсвенно для 1-го для 2-го и для 3-го станка. На пересечение строки и столбца стоит время обработки детали на данном станке. Приложение: program p; uses crt,dos; var fin,fout:text; Mt:array [1..1001,1..3] of integer; X:array [1..1000] of integer; N,min1,i:integer; time:real; min2:word; function GetSeconds: Real; {Возвращает системное время как вещественное число секунд} var h, m, s, hund : Word; begin GetTime(h,m,s,hund); GetSeconds := h*3600.0 + m*60 + s + hund/100; end; {GetSeconds} function max2(a,b:integer):integer; { Возвращает максимум из двух целых чисел } begin if a>b then max2:=a else max2:=b end; function max3(a,b,c:integer):integer; { Возвращает максимум из трех целых чисел } begin max3:=max2(a,max2(b,c)); end; procedure calc(var time:integer); {процедура подсчета длительности обработки всего комплекта деталей} var i:integer; begin time:=0; time:=Mt[X[1],1]; time:=time+max2(Mt[X[1],2],Mt[X[2],1]); i:=1; while i<(N-1) do begin time:=time+max3(Mt[X[i],3],Mt[X[i+1],2],Mt[X[i+2],1]); inc(i); end; time:=time+max2(Mt[X[N-1],3],Mt[X[N],2]); time:=time+Mt[X[N],3]; end; procedure perebor(k :Integer); {k – количество уже найденных номеров деталей в последовательности} var ip:integer; ok:boolean; begin if k = N then begin calc(ip); if ip<min1 then min1:=ip; end else begin {k < n} inc(k); X[k]:=1; while X[k]<= N do begin ok:=true; ip:=1; while ip < k do begin if (X[k]=X[ip]) then ok:=false; inc(ip); end; if (ok) then perebor(k); inc(X[k]); end; end; end; {procedure perebor} function fact(n:integer):longint; { Функция возвращает факториал от n } var i:integer; s:longint; begin s:=1; i:=1; while i<=n do begin s:=s*i; inc(i); end; fact:=s; end; {EBPucTu4eckuu AJIrOPuTM} Procedure evristika(N1:integer; var time1: word); var i,j,k:integer; min:integer; ok:boolean; begin {поиск первой лучшей детали } min:=32000; for i:=1 to N1 do begin if Mt[i,1]<min then begin min:=Mt[i,1]; X[1]:=i; end; end; time1:=min; {поиск второй лучшей детали} min:=32000; for i:=1 to N1 do begin if i<>X[1] then begin if max2(Mt[X[1],2],Mt[i,1])<min then begin min:=max2(Mt[X[1],2],Mt[i,1]); X[2]:=i; end; end; end; time1:=time1+min; {поиск остальных деталей } i:=1; while i<=(N1-2) do begin min:=32000; for j:=1 to N1 do begin ok:=true; for k:=1 to (i+1) do begin if j=X[k] then ok:=false; end; if ok then begin if max3(Mt[X[i],3],Mt[X[i+1],2],Mt[X[j],1])<min then begin X[i+2]:=j; min:=max3(Mt[X[i],3],Mt[X[i+1],2],Mt[X[j],1]); end; end; end; time1:=time1+min; inc(i); end; time1:=time1+max2(Mt[X[N-1],3],Mt[X[N],2]); time1:=time1+Mt[X[N],3]; end; begin { Открытие и считывание данных с входного файла } assign(fin,'c: empin.txt'); assign(fout,'c: empout.txt'); rewrite(fout); for i:=1 to 5 do begin N:=0; min1:=32000; min2:=32000; reset(fin); while (not(eof(fin))and(N<i+4))do begin inc(N); readln(fin,Mt[N,1],Mt[N,2],Mt[N,3]); end; Time:=GetSeconds; perebor(0); {вывод таблицы результатов} write('N: ',N:2,'.Time: ',(GetSeconds-Time):5:2,'cek. MIN1: ',min1:3,' KoJI-BO ',fact(N):7); Time:=Getseconds; evristika(N,min2); writeln(' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); write(fout,'N: ',N:2,'.Time: ',(GetSeconds-Time):5:2,'cek. MINIMUM: ',min1:3,' KoJI-BO ',fact(N):7); writeln(fout,' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); end; for i:=1 to 5 do begin N:=0; min2:=32000; reset(fin); while (not(eof(fin))and(N<i*200))do begin inc(N); readln(fin,Mt[N,1],Mt[N,2],Mt[N,3]); end; Time:=Getseconds; evristika(N,min2); writeln('N: ',N:3,' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); writeln(fout,' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); end; readln; {закрытие файлов} close(fin); close(fout); end.

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

Отвечает: Тимошенко Дмитрий Здравствуйте, Иванов Руслан Иванович! Добавил комментарии. Надеюсь понятные. Одно замечание - ваша программа не правильно выводит время работы процедур в файл в первом цикле обработок. Правильно будет эту строку write(fout,'N: ',N:2,'.Time: ',(GetSeconds-Time):5:2,'cek. MINIMUM: ',min1:3,' KoJI-BO ',fact(N):7); перенести на 3 строки выше перед Time:=Getseconds; С уважением, Дмитрий Приложение: program p; uses crt,dos; var fin,fout:text; { Входной и выходной файлы } { Массив для хранения информации о вермени обработки деталей } Mt:array [1..1001,1..3] of integer; { Массив для хранения последовательности обработки деталей } X:array [1..1000] of integer; N,min1,i:integer; {N - количество обрабатываемых деталей,} { min1 - минимальное время обработки найденное перебором, i - счетчик } time:real; { Время работы каждой процедуры } min2:word; { минимальное время обработки найденное методом эвристики } function GetSeconds: Real; {Возвращает системное время как вещественное число секунд} var h, m, s, hund : Word; begin GetTime(h,m,s,hund); GetSeconds := h*3600.0 + m*60 + s + hund/100; end; {GetSeconds} function max2(a,b:integer):integer; { Возвращает максимум из двух целых чисел } begin if a>b then max2:=a else max2:=b end; function max3(a,b,c:integer):integer; { Возвращает максимум из трех целых чисел } begin max3:=max2(a,max2(b,c)); end; procedure calc(var time:integer); {процедура подсчета длительности обработки всего комплекта деталей} var i:integer; begin time:=0; time:=Mt[X[1],1]; { Выбираем и суммируем, большую из величин: время обработки 1-й детали на втором станке, или время обработки второй детали на первом, т.к. в первом случае вторая деталь будет ждать своей очереди, а во втором второй станок уже будет свободен } time:=time+max2(Mt[X[1],2],Mt[X[2],1]); i:=1; while i<(N-1) do begin { Тоже самое что и выше, но уже из трех времен, т.к. деталь которая медленне всего обрабатывается будет "тормозить" весь дальнейший процесс } time:=time+max3(Mt[X[i],3],Mt[X[i+1],2],Mt[X[i+2],1]); inc(i); end; { Ну и для последних двух деталей выбираем время последнего шага для второго и третьего станков } time:=time+max2(Mt[X[N-1],3],Mt[X[N],2]); { И последним добавляем время последней детали на третьем станке } time:=time+Mt[X[N],3]; end; { Полный перебор } procedure perebor(k :Integer); {k - количество уже найденных номеров деталей в последовательности} var ip:integer; ok:boolean; begin if k = N then begin { Если сформирован весь набор - высчитываем время его обработки } calc(ip); if ip<min1 then min1:=ip; { Если время получается меньше прошлого - запоминаем его } end else begin {k < n} { Последовательность обработки сформирована не до конца } inc(k); X[k]:=1; { Добавляем первую деталь в последовательность } while X[k]<= N do begin { В цикле проверяем не была ли эта деталь добавлена ранее } ok:=true; ip:=1; while ip < k do begin if (X[k]=X[ip]) then ok:=false; inc(ip); end; if (ok) then perebor(k); { Если детали еще не было - то переходим на следующий шаг } inc(X[k]); { Иначе, или после возврата из рекурсии переходим к след. детали } end; end; end; {procedure perebor} function fact(n:integer):longint; { Функция возвращает факториал от n } var i:integer; s:longint; begin s:=1; i:=1; while i<=n do begin s:=s*i; inc(i); end; fact:=s; end; {EBPucTu4eckuu AJIrOPuTM} { N1- число обрабатываемых деталей time1 - минимально возможное время обработки } Procedure evristika(N1:integer; var time1: word); var i,j,k:integer; { Счетчики циклов } min:integer; { Минимальное время обработки на каждом шаге } ok:boolean; { флаг для проверки "была ли уже деталь занесена ранее в последовательность" } begin {поиск первой лучшей детали } {просматриваем весь список деталей и находим деталь с наименьшим временем обработки на первом станке } min:=32000; for i:=1 to N1 do begin if Mt[i,1]<min then begin min:=Mt[i,1]; X[1]:=i; { Заносим ее в последовательность первой } end; end; time1:=min; {поиск второй лучшей детали} { Воторую деталь ищем так, чтобы время обработки обоих деталей (той которую выбрали на предыдущем шаге и текущей) было минимальным } min:=32000; for i:=1 to N1 do begin if i<>X[1] then begin { Проверяем чтобы это была не одна и таже деталь } if max2(Mt[X[1],2],Mt[i,1])<min then begin min:=max2(Mt[X[1],2],Mt[i,1]); X[2]:=i; { Заносим ее в последовательность второй } end; end; end; time1:=time1+min; {поиск остальных деталей } i:=1; while i<=(N1-2) do begin { Цикл делаем до N-2 деталей } min:=32000; for j:=1 to N1 do begin { Проверяем все детали } ok:=true; for k:=1 to (i+1) do begin { Проверяем нет ли текущей детали уже в последовательности } if j=X[k] then ok:=false; end; if ok then begin { Если детали еще не было, то проверяем не получится ли минимальным время обработки с этой деталью в последовательности } if max3(Mt[X[i],3],Mt[X[i+1],2],Mt[X[j],1])<min then begin { Если время обработки оказалось меньше минимума то занесем деталь в последовательность } X[i+2]:=j; min:=max3(Mt[X[i],3],Mt[X[i+1],2],Mt[X[j],1]); end; end; end; time1:=time1+min; inc(i); end; { На каждом из предыдущих шагов мы считали время обработки. Теперь к нему еще добавим последние два шага - время обработки последних двух деталей на втором и третьем станках } time1:=time1+max2(Mt[X[N-1],3],Mt[X[N],2]); time1:=time1+Mt[X[N],3]; end; begin { Открытие и считывание данных с входного файла } assign(fin,'c: empin.txt'); assign(fout,'c: empout.txt'); rewrite(fout); { В цикле обрабатываем обоими алгоритмами 5 наборов состоящих из первых 5,6,7,8 и 9 деталей. Для каждого набора и процедуры выводи найденное время и время работы процедур } for i:=1 to 5 do begin N:=0; min1:=32000; min2:=32000; reset(fin); while (not(eof(fin))and(N<i+4))do begin inc(N); readln(fin,Mt[N,1],Mt[N,2],Mt[N,3]); end; Time:=GetSeconds; perebor(0); {вывод таблицы результатов} write('N: ',N:2,'.Time: ',(GetSeconds-Time):5:2,'cek. MIN1: ',min1:3,' KoJI-BO ',fact(N):7); Time:=Getseconds; evristika(N,min2); writeln(' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); write(fout,'N: ',N:2,'.Time: ',(GetSeconds-Time):5:2,'cek. MINIMUM: ',min1:3,' KoJI-BO ',fact(N):7); writeln(fout,' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); end; { Обрабатываем эвристическим алгоритмом 5 наборов и 200,400,600,800 и 1000 деталей. Для каждого выводим найденное время и время работы процедуры } for i:=1 to 5 do begin N:=0; min2:=32000; reset(fin); while (not(eof(fin))and(N<i*200))do begin inc(N); readln(fin,Mt[N,1],Mt[N,2],Mt[N,3]); end; Time:=Getseconds; evristika(N,min2); writeln('N: ',N:3,' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); writeln(fout,' Time2: ',(GetSeconds-Time):5:2,'cek. Min2: ',min2:3); end; readln; {закрытие файлов} close(fin); close(fout); end.

Ответ отправил: Тимошенко Дмитрий (статус: 7-й класс) Ответ отправлен: 22.04.2009, 21:52 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248058 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это! Оценка за ответ: 5 Комментарий оценки: Огромное спасибо Тимошенко Дмитрий !!! Вы отлично разъяснили программу, Очень благодарен за то что откликнулись и помогли :)

Вопрос № 165.595

Помогите решить задачу!!Вычислить сумму кодов всех символов, которые в цикле вводятся с клавиатуры до нажатия на клавишу ESC!блок схему тоже не могу сделать!

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

Отвечает: Botsman Здравствуйте, Dimasic59! Помогаю. Код программы - в приложении, комментарии - внутри. Уверен, на основе данного кода вы без труда нарисуете блок-схему. Рад был помочь! Приложение: uses crt; var symbol:char; sum:longint; BEGIN repeat writeln('введите символ (или намите Esc для выхода)'); symbol:=readkey; writeln('код введенного символа:',ord(symbol)); if symbol<>#27 then inc(sum,ord(symbol)); until symbol=#27;{код клавиши Esc} writeln ('сумма кодов введенных символов равна ',sum); readkey; END. --------- Хочешь победить Excel? Спроси меня как! ;)

Ответ отправил: Botsman (статус: Студент) Ответ отправлен: 22.04.2009, 18:14 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248042 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Вопрос № 165.604

Многоуважаемые эксперты пожалуйсто помогите кто чем может!!!!! Заранее спасибо!!!!! 1.В массиве А(12, 15) найти произведение столбцов: второго на десятый, третьего на девятый. Вычисление произведения двух столбцов матрицы оформить в виде функции. 2.Напишите программу поиска большего из четырех чисел с использованием подпрограммы поиска большего из двух чисел. 3.Составьте программу вывода на экран всех натуральных чисел, не превосходящих N и делящихся на каждую из своих цифр. 4.Оформить процедурой преобразование натурального многоразрядного числа так, чтобы его цифры располагались в убывающем порядке.

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

Отвечает: Proce Здравствуйте, Sancheznew1! Вот решение первой задачи. Приложение: program z_165604; type TArray = array [1..12, 1..15] of Integer; var A: TArray; i, j: Integer; function proizv(var A: TArray; n1, n2: Integer): Integer; var i, s: Integer; begin s := 0; for i := 1 to 12 do s := s + A[i, n1]*A[i, n2]; result := s end; begin for i := 1 to 12 do begin for j := 1 to 15 do begin A[i, j] := random(10); write(A[i, j]:3); end; writeln end; writeln; writeln('Proizvedenie 2 na 10 = ', Proizv(A, 2, 10)); writeln('Proizvedenie 3 na 9 = ', Proizv(A, 3, 9)); readln end.

Ответ отправил: Proce (статус: 4-й класс) Ответ отправлен: 22.04.2009, 22:44 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248062 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это! Оценка за ответ: 5 Комментарий оценки: Огроооомнейшее спасибо!!!!!

Отвечает: Тимошенко Дмитрий Здравствуйте, Sancheznew1! Вот остальные три задания. Комментарии в тексте. С уважением, Дмитрий Приложение: {2.Максимум 4-х чисел } program max4; uses crt; var a1,a2,a3,a4: integer; { Возвращает максимум 2-х чисел } function Max(a,b: integer): integer; begin if a>b then Max:=a else Max:=b; end; begin clrscr; write('Введите 1-е число: '); readln(a1); write('Введите 2-е число: '); readln(a2); write('Введите 3-е число: '); readln(a3); write('Введите 4-е число: '); readln(a4); writeln('Максимум: ',Max(a1,Max(a2,Max(a3,a4)))); readln; end. {3.Вывод чисел удовлетворяющих условиям } program chisla; uses crt; var N,i: word; { Функция проверки условия задания } function CheckNum(i: word): boolean; var fl: boolean; delitel: LongInt; { Текущий делитель и цифра } cifra: byte; begin fl:=true; delitel:=1; repeat delitel:=delitel*10; { Переходим к следующему делителю } cifra:=(i mod delitel) div round(delitel/10); { Очередная цифра } if cifra=0 then { Если очередная цифра 0 - то не делится } fl:=false else { И если остаток от деления не 0 - то не делится } if i mod cifra<>0 then fl:=false; until (delitel>i) or not(fl); CheckNum:=fl; end; begin clrscr; write('Введите N: '); readln(N); for i:=1 to N do if CheckNum(i) then writeln(i); readln; end. {4.Преобразование числа } program preobr; uses crt; var chislo: word; procedure Change(var i: word); var cifry: array [1..5] of byte; delitel: LongInt; j,k,num: word; tmp: byte; begin delitel:=1; num:=1; { Заносим все цифры в массив } repeat delitel:=delitel*10; cifry[num]:=(i mod delitel) div (delitel div 10); inc(num); until delitel>i; dec(num); { Сортируем по возрастанию, т.к. число "перевернуто" } for j:=1 to num-1 do for k:=j+1 to num do if cifry[j]>cifry[k] then begin tmp:=cifry[j]; cifry[j]:=cifry[k]; cifry[k]:=tmp; end; { Заносим результат } i:=0; delitel:=1; for j:=1 to num do begin i:=i+cifry[j]*delitel; delitel:=delitel*10; end; end; begin clrscr; write('Введите число: '); readln(chislo); Change(chislo); writeln('Преобразовали: ',chislo); readln; end.

Ответ отправил: Тимошенко Дмитрий (статус: 7-й класс) Ответ отправлен: 23.04.2009, 10:11 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248084 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Отвечает: Botsman Здравствуйте, Sancheznew1! Еще один - более математический - вариант решения третьей задачи. Код и комментарии - в приложении. Приложение: var i,nj,n:integer;{счетчик цифр, счетчик чисел и число N} qty:integer;{для запоминания количества цифр числа} cifra_i:byte;{для запоминания цифры i-го разряда} flag:boolean;{флаг делимости числа на все свои цифры} {возвращает цифру из разряда nomer числа chislo} BEGIN write('Введите n='); readln(n); writeln('Искомые числа:'); for nj:=1 to n do begin {кол-во цифр в числе n равно [lg(n)]+1, т.е. целая часть десятичного логарифма числа, увеличенная на 1 } qty:=trunc(ln(nj)/ln(10))+1; flag:=true;{по умолчанию} i:=1; repeat {запоминаем цифру i-го разряда, к-я равна остатку от деления на 10 результата целочисленного деления модуля числа на 10 в степени (i-1)} cifra_i:=(abs(nj) div trunc(exp((i-1)*ln(10)))) mod 10; if cifra_i=0 then flag:=false{на ноль делить нельзя} else flag:=flag and ((nj mod cifra_i)=0); {writeln(i,' ',cifra_i,' ',flag);} inc(i,1); {пока не переберем все цифры или не выявим факт неделения на цифру} until (i>qty) or not flag; if flag then write(nj,' '); end; readln; END. --------- Хочешь победить Excel? Спроси меня как! ;)

Ответ отправил: Botsman (статус: Студент) Ответ отправлен: 23.04.2009, 11:48 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248097 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

Вопрос № 165.632

Здраствуйте эксперты!! Нужна срочно помошь!!! Нужно решить задачу с помощью рекурсии и без помощи рекурсии. Просто я не пойму что должно выйти на экран и как это должно работать. А рекурсия какая-то не понятная тема. Найти сумму и произведение значений функции f(х) на интервале [-1;1] с шагом 0.1. {cosx+ln|x|, x<-0,5 } f(x)={f(x-0,2)+1, -0,5<=x<=0} {ln|f(x-0,1)|,x>0. }

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

Отвечает: Proce Здравствуйте, Infant1212! Вот рекурсивный способ решения. Приложение: program z_165632; var x, s, p: Real; function f(x: Real): Real; {рекурсивная функция вычисления f(x)} begin if x < - 0.5 then f := cos(x) + Ln(abs(x)) else if x > 0 then f := ln(abs(f(x - 0.1))) else f := f(x - 0.2) + 1 end; begin x := -1; s := 0; p := 1; while x <= 1 do begin s := s + f(x); p := p*f(x); x := x + 0.1 end; WriteLn('Summa = ',s:0:5, ' ; Proizvedenie = ', p:0:5); readln end.

Ответ отправил: Proce (статус: 4-й класс) Ответ отправлен: 23.04.2009, 06:11 Как сказать этому эксперту "спасибо"? Отправить SMS #thank 248075 на номер 1151 (Россия) | Еще номера >> Отправить WebMoney: Неплохо (10 руб.) Хорошо (15 руб.) Отлично (20 руб.) БЛЕСТЯЩЕ! (30 руб.) Вам помогли? Пожалуйста, поблагодарите эксперта за это!

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