Mail

Уголок начинающего программиста

В данном разделе приводятся программы, написанные посетителями данного сайта. Идея данного раздела принадлежит Валерию из города Новотроицк Оренбургской области, который прислал мне письмо, в котором предложил публиковать его программы, мотивировав это тем, что на сайте не хватает простых, элементарных программ. А поскольку он все-равно будет "мучаться", то чтоб труд не пропадал зря, он предложил размещать его примеры на сайте. Мне эта идея понравилась и вот первая партия программ размещена в данном новом разделе. Я постараюсь снабжать программы комментариями, если что-то можно сделать в программах лучше. Я не обещаю проверять данные программы на работоспособность, компилируя их, но просматривать на предмет ошибок обязательно буду.

Модератор.

Задач в выбранных темах: 66

Страница 8

Условие задачи

Условие: Дан текстовый файл. Найти в файле слова, начинающиеся и заканчивающиеся на "а".

Решение
Автор: strike

uses crt;
var f,f1: text;
    s,s1: string;
procedure KILLPROBEL(var s:string);
var k: byte absolute s;
begin
while s[1]=' ' do delete(s,1,1);
while s[k]=' ' do dec(k);
while pos('  ',s)<>0 do delete (s,pos('  ',s),1);
end;
procedure alg(s: string; var s1:string);
var i,j:integer;
      w:string;
begin
for i:=1 to length(s) do
if s[i]<>' ' then w:=w+s[i]
else begin  if (w[1]='a') and (w[length(s)]='a') then  begin
                                                       s1:=s1+w+' ';
                                                       w:='';s1:='';
                                                       end;
      end;
end;
begin
clrscr;
assign(f,'input.txt');reset(f);
assign(f1,'output.txt');rewrite(f1);
while not eof(f) do begin
                    readln(f,s);
                    killprobel(s);
                    alg(s,s1);
                    write(f1,s1);
                    end;
close(f);
close(f1);
end.

Комментарии

1. Форматирование и лишние операторные скобки begin end:

...
procedure alg(s: string; var s1:string);
var i,j:integer;
      w:string;
begin
for i:=1 to length(s) do if s[i]<>' '
  then w:=w+s[i]
  else if (w[1]='a') and (w[length(s)]='a')
    then
      begin
      s1:=s1+w+' ';
      w:='';s1:='';
      end;
end;
begin
clrscr;
assign(f,'input.txt');reset(f);
assign(f1,'output.txt');rewrite(f1);
while not eof(f) do
  begin
  readln(f,s);
  killprobel(s);
  alg(s,s1);
  write(f1,s1);
  end;
close(f);
close(f1);
end.

2. В процедуре alg должно быть изначально присвоение w:='';s1='';
3. В операторе
if (w[1]='a') and (w[length(s)]='a')
должно быть:
if (w[1]='a') and (w[length(w)]='a')
4. Улучшения:
alg я бы переименовал в getWordsStartAndEndWithCh, в список параметров
ввел бы ch:char; поскольку данная процедура возвращает строку, то на
самом деле это функция и тогда можно написать:
function getWordsStartAndEndWithCh(s: string; ch:char):string;
...
if (w[1]=ch) and (w[length(w)]=ch)
...
и в конце функции надо присвоить возвращаемое значение:
getWordsStartAndEndWithCh:=s1;

Далее KILLPROBEL тоже функция, можно написать:
function KILLPROBEL(s:string):string;
опять же в конце функции:
KILLPROBEL := s;

тогда в основной программе:
...
  readln(f,s);
  writeln(f1,getWordsStartAndEndWithCh(killprobel(s),'a'));
...

to top

Условие задачи

Дан текстовый файл. Найти в файле все слова-палиндромы.

Решение
Автор: strike

uses crt;
var f,f1: text;
    s,sn: string;
procedure KILLPROBEL(var s:string);
var k: byte absolute s;
begin
while s[1]=' ' do delete(s,1,1);
while s[k]=' ' do dec(k);
while pos('  ',s)<>0 do delete (s,pos('  ',s),1);
end;

procedure PALENDROM(s:string; var sn:string);
var s1,s2:string;
    i:integer;
begin
for i:=1 to length(s) do
if s[i]<>' ' then begin
                   s1:=s1+s[i];
                   s2:=s[i]+s2;
                   end
  else begin
       if s1=s2 then sn:=sn+s1+' ';
       s1:='';s2:='';
       end;
end;

begin
assign(f,'input.txt');reset(f);
assign(f1,'output.txt');rewrite(f1);
while not eof(f) do begin
                    readln(f,s);
                    KILLPROBEL(s);
                    PALENDROM(s,sn);
                    write(f1,sn);
                    end;
close(f);
close(f1);
readln
end.

Комментарии

Strike: Задачка классическая. Полезным будет алгоритм нахождения палиндрома. Это один из способов, есть и другие, возможно более рациональные, но я решил выбрать этот. В процессе решения я не очень извращался, т.к можно было бы сделать запрос на имя исходного файла, имя того файла, в который будет идти запись конечного результата, проверку на существование обоих этих файлов, и.т.д.
Модератор:
1. Такое ощущение что автор предвидел мои замечания и посему "постелил солому" своим комментарием. Ну что ж, будем считать, что по поводу проверок на имена файлов я присоединяюсь к его мнению, что это "можно было бы сделать".
2. Аглоритм не только нерациональный, но и не совсем верный. Начнем с определения палиндрома. Таковым является слово читаемое одинаково с обеих сторон "латал", например. Алгоритм вроде как правильный. Беберм предложение, удаляем лишние пробелы, затем проходим по символам предложения и организуем два новых слова - прямое и обратное. Как только найден пробел, сравниваем слова и если они равны, добавляем их в переменную-строку sn. Теперь по существу.
3. Строке-переменной sn не присвоено начальное значениев основной программе.
4. Длина строки в Паскале не может превышать 255 символов. Это значит, что если слов в файле достаточно много (что вполне может статься), то они не смогут быть сохранены в одной строковой переменной.
5. Гораздо "прозрачней" выглядел бы алгоритм, разбивающий сначала предожение на слова, а потом проверяющий каждое слово.
6. Более эффективная проверка на палиндромичность:

function isWordPalindrom(s:string):boolean;
var q:true;
    ib,ik:byte;
  begin
  q:=true;ib:=1;ik:=length(s);
  while (q and (ib>ik)) do
    begin
    q:=(s[ib]=s[ik]);
    dec(ik);inc(ib);
    end;
  isWordPalindrom:=q;
  end;

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

to top

Условие задачи

Cоздать текстовый фаqл. Заполнить его введенным с клавиатуры числом строк, и
дописать файл самы длинной строкой, вывести на экран измененный файл.

Решение
Автор: Валерий

Uses crt;
var
f: text;
A,X:string;i,k:integer;
begin
Clrscr;
writeln('введите ко-во строк');
readln(k);
assign(f, 'ghj.txt');
rewrite(f);
for i := 1 to k do
  begin
  writeln('введите строку');
  readln(a);
  writeln(f,a);
  end;
close(f);
x:=a;
reset(f);
while not eof(f)do
  begin
  readln(f,a);
  if length(a)>length(x)
    then x:=a;
end;
close(f);
append(f);
writeln(f,x);
close(f);
writeln('измененный файл');
reset(f);
while not eof (f) do
  begin
  readln(f,a);
  writeln(a);
  end;
readkey;
end.

Комментарии

OK

to top

Условие задачи

Формульный счет. Найти и напечатать числа.

Решение
Автор: Валерий

program proba;
{ author Valeriy }
uses crt;
var x,y,z,k,a:real;
  begin
  clrscr;
  writeln('введите число');
  read(x);
  y:=(sqr(x)-4*x+1)/(abs(x)+1);
  z:=(100*exp(5*ln(x))-40*exp(3*ln(x))-1)/(sqr(sin(x))+cos(sqr(x))+1);
  a:=sin(x)/cos(x)+sqr(cos(x)/sin(x))+exp(9*ln(1.1));
  k:=exp(1/5*ln(a));
  writeln;
  writeln('y=',y:5:5, 'z=', z:5:5, 'k=', k:5:5);
  end.

Комментарии

Модератор. Кто мешает мне ввести в качестве х число 0? Или Пи/2?
Или отрицательное число? В любом из этих случаев программа будет
завершена по ошибке (соответсвенно, деление на ноль, то же, корень
и логарифм отрицательных чисел не определены). Надо проверки ставить.

to top

Страницы: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17

Задач в выбранных темах: 66

Золотые обручальные кольца