Question

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

Answer 1

Function PosBlank(s: string; cursor: integer): integer;
{Возвращает позицию первого пробельного символа в строке s,
 начиная с позиции, указанной cursor. Если такого символа нет,
 возвращает 0.}
var
  n: integer;
begin
  n := Length(s);
  while (s[cursor] <> ' ') and (cursor < n) do cursor := cursor + 1;
  if cursor = n then
    if s[cursor] = ' ' then PosBlank := n else PosBlank := 0
  else
    PosBlank := cursor
end;

function PosNonBlank(s: string; cursor: integer): integer;
{Возвращает позицию первого непробельного символа в строке s,
 начиная с позиции, указанной cursor. Если такого символа нет,
 возвращает 0.}
var
  n: integer;
begin
  n := Length(s);
  while (s[cursor] = ' ') and (cursor < n) do cursor := cursor + 1;
  if cursor = n then
    if s[cursor] = ' ' then PosNonBlank := 0 else PosNonBlank := n
  else
    PosNonBlank := cursor
end;

procedure GetWord(s: string; var cursor: integer; var wd: string);
{Процедура помещает в wd очередное слово из строки s
 Начало слова указано в cursor, после завершения процедуры
 cursor будет указывать на первый пробельный символ,
 следующий за найденным словом. Лидирующие и хвостовые
 пробельные символы усекаются. Если слово не найдено, то
 в wd помещается пустая строка}
var
  n, ibegin: integer;
begin
  n := length(s);
  if n>0 then
    begin
    cursor := PosNonBlank(s, cursor);
    if cursor > 0 then
    begin
      ibegin := cursor;
      cursor := PosBlank(s, cursor);
      if cursor > 0 then wd := Copy(s, ibegin, cursor - ibegin)
      else wd := Copy(s, ibegin, n - ibegin + 1)
    end
    else
      wd := ''
    end
  else
    begin
    wd:='';
    cursor:=0
    end
end;

var
  c, cc, w: string;
  ic: integer;
  fin, fout: Text;

begin
  Assign(fin, 'input.txt');
  Reset(fin);
  Assign(fout, 'output.txt');
  Rewrite(fout);
  while not Eof(fin) do
  begin
    ic := 1;
    cc := '';
    readln(fin, c);
    while ic > 0 do
    begin
      GetWord(c, ic, w);
      if w <> '' then cc := cc + ' ' + w
    end;
    cc := Copy(cc, 2, length(cc) - 1);
    writeln(fout, cc)
  end;
  Close(fin);
  Close(fout);
end.

Answer 2

Program gt;
var f,g:text;
s,b:string;
l,i:integer;
begin
assign(f,'c:\input.txt');reset(f);
assign(g,'c:\output.txt');rewrite(g);
while not eof(f)do
begin
readln(f,s);
l:=length(s);
b:='';
if (s[2]<>' ') then b:=s[1];
i:=1;
while i<l-1 do
begin
i:=i+1;
if (s[i-1]=' ') and (s[i]<>' ') and (s[i+1]=' ') then i:=i+1 else b:=b+s[i];
end;
if (s[l-1]<>' ') then b:=b+s[l];
writeln(g,b);
end;
close(f);
close(g);
end.