Сортировка слов в строке Опции

[сНежная]

Помогите решить задачку
Вводится произвольное кол-во слов в строку, программа выводит кол-во слов в строке и переставляет местами слова (1 со 2, 3 с 4 и т.д), если перед первым словом пробел, или между словами более одного пробела, то выдается сообщение о ошибке и предлагается начать сначала.

//в строке переставить местами рядом стоящие слова(1 со 2, 3 с 4, и т.д.) Дана
//дана строка, нач. не пробелом, между словами по 1 пробелу,
//и строка закан. буквой

program ctroca;
{$APPTYPE CONSOLE}
uses
SysUtils;
var s,s1,temp:string;
s2:array[1..25]of string;
p,k,n,i,t:integer;
begin
writeln('Vvedite text');
readln(s);
writeln;
k:=1;
n:=1;
p:=0;
s1:='';

for i:=1 to length(s) do
begin
if (s[i]<>' ')and(s[i+1]=' ')
then inc(k);
end;

for i:=1 to length(s) do
begin
if (s[i]<>' ')
then begin
insert(s[i],s1,n);
inc(n);
end;
if (s[i]=' ') or (i=length(s))
then begin
n:=1;
inc(p);
s2[p]:=s1;
s1:='';
end;
end;

if

for i:=1 to length(s) do
if (s[i]=' ') and (s[i+1]=' ')
then begin
writeln('Error!!!!');
s:='';
writeln('Mnogo probelov ');
writeln('Vvedite text :');
readln(s);
for i:=1 to Length(s) do
begin
if (s[i]<>' ')and(s[i+1]=' ')
then inc(k);
end;
end;
end;

if s[1]=' '
then begin
writeln('Error!!!!');
writeln('Nachalo probel ');
writeln('Vvedite text :');
readln(s);
for i:=1 to Length(s) do
begin
if (s[i]<>' ')and(s[i+1]=' ')
then inc(k);
end;
end;
writeln('Kol-vo slov: ',k);

readln;
end.

[мисс_граффити]

1. Пользуйся тэгами.
2. Приведи пример строки, которая на входе, и строки, которая на выходе.

[arhimag]

Код

var s : string;
var arr : array [1..256] of string;
var c : integer;
var slov : integer;
function make_words(s:string):boolean;
var i: integer;
begin
  slov:=1;
  c:=1;
  make_words:=false;
  i:=1;
  while (i<=length(s)) and (s[i]=' ') do
    inc(i);
  while i<=length(s)do begin
    if (s[i]=' ') and (i<length(s)) and (s[i+1]=' ') then exit;
    if (s[i] in ['A'..'z']) then arr[c]:=arr[c]+s[i];
    if (s[i]=' ') then begin inc©; inc(slov); end;
    inc(i);
  end;
  if s[length(s)]=' ' then begin dec©; dec(slov); end;
  make_words:=true;
end;
var flag : boolean;
i : integer;
tmp : string;
begin
  readln(s);
  flag:=make_words(s);
  if (flag) and (c>1) then begin
    for i:= 0 to (©div 2) do begin
      tmp:=arr[i*2+1];
      arr[i*2+1]:=arr[i*2+2];
      arr[i*2+2]:=tmp;
    end;
    for i:=1 to c do write(arr[i],' '); writeln; writeln('slov:',slov);
  end else
    if (c=1) and (flag) then begin
      writeln(s); writeln(1);
    end else
      writeln('Strashnij error!!!');
  readln;
end.

Сообщение отредактировано: arhimag - 3.01.2007 23:31

[сНежная]

У меня считает кол-во слов, а местами не меняет

[arhimag]

если будут вопросы, спрашивай

[Bokul]

Не работает:

a b c d e

Сообщение отредактировано: Bokul - 3.01.2007 23:32

[сНежная]

@-что означает?(dec©)

[arhimag]

извини багу нашел, ща правлю

Код

(с)

означает ( с )

в моей проге цифры - не есть буквы в словах

Сообщение отредактировано: arhimag - 3.01.2007 23:34

[Bokul]

@-что означает?(dec©)

Глюк форума - поставь dec и в дужках с
dec( с ) - так только без пробелов.

в моей проге цифры - не есть буквы в словах

Глянь еще раз, я изменил на буквы.

[arhimag]

Код

program Project2;


var s : string;
var arr : array [1..256] of string;
var c : integer;
var slov : integer;
function make_words(s:string):boolean;
var i: integer;
begin
  slov:=1;
  c:=1;
  make_words:=false;
  i:=1;
  while (i<=length(s)) and (s[i]=' ') do
    inc(i);
  while i<=length(s)do begin
    if (s[i]=' ') and (i<length(s)) and (s[i+1]=' ') then exit;
    if (s[i] in ['A'..'z']) then arr[c]:=arr[c]+s[i];
    if (s[i]=' ') then begin inc(c); inc(slov); end;
    inc(i);
  end;
  if s[length(s)]=' ' then begin dec(c); dec(slov); end;
  make_words:=true;
end;
var flag : boolean;
i : integer;
tmp : string;
begin
  readln(s);
  flag:=make_words(s);
  if (flag) and (c>1) then begin
    for i:= 1 to ((c)div 2) do begin
      tmp:=arr[i*2-1];
      arr[i*2-1]:=arr[i*2];
      arr[i*2]:=tmp;
    end;
    for i:=1 to c do write(arr[i],' '); writeln; writeln('slov:',slov);
  end else
    if (c=1) and (flag) then begin
      writeln(s); writeln(1);
    end else
      writeln('Strashnij error!!!');
  readln;
end.

вот теперь все ок

[Bokul]

Ты еще одно условие забыл:

если перед первым словом пробел , или между словами более одного пробела, то выдается сообщение о ошибке и предлагается начать сначала

[сНежная]

Работает, но частично!Строка считывается, кол-во слов считается. Но мне нужно, чтобы после вывода на экран кол-ка слов была выведена строка, в которой были бы поменены местами слова из исходной строки. К примеру:

МАМА ПАПА Я
слов:3
ПАПА МАМА Я

Если слов больше, он меняет 1 со 2, 3 с 4, 5 с 6, и тд.

[Bokul]

сНежная, а ты внимательно смотрела? Все работает, как ты описала.


Сообщение отредактировано: Bokul - 3.01.2007 23:47

[arhimag]

черт

Код

program Videlenieslovzamenachetnogonanechetnoe;

var s : string;
var arr : array [1..256] of string;
var c : integer;
var slov : integer;
function make_words(s:string):boolean;
var i: integer;
begin
  slov:=1;
  c:=1;
  make_words:=false;
  i:=1;
  while (i<=length(s)) and (s[i]=' ') do
    inc(i);
  while i<=length(s)do begin
    if (s[i]=' ') and (i<length(s)) and (s[i+1]=' ') then exit;
    if (s[i] in ['A'..'z']) then arr[c]:=arr[c]+s[i];
    if (s[i]=' ') then begin inc(c); inc(slov); end;
    inc(i);
  end;
  if s[length(s)]=' ' then begin dec(c); dec(slov); end;
  make_words:=true;
end;
function doit : boolean;
var flag : boolean;
i : integer;
tmp : string;
begin
  doit:=false;
  readln(s);
  flag:=make_words(s);
  if (flag) and (c>1) then begin
    for i:= 1 to ((c)div 2) do begin
      tmp:=arr[i*2-1];
      arr[i*2-1]:=arr[i*2];
      arr[i*2]:=tmp;
    end;
    doit:=true;
    for i:=1 to c do write(arr[i],' '); writeln; writeln('slov:',slov);
  end else
    if (c=1) and (flag) then begin
      writeln(s); writeln(1); doit:=true;
    end else  begin
      writeln('Strashnij error!!!');
      exit;
    end;
  readln;
end;
var ch : char;
i:integer;
begin
  ch:=' ';
  repeat
    if not(doit) then begin
      writeln('Chtobi povtorit nazmi R i enter, chobi vijti nezmi E i enter');
      readln(ch);
      for i:= 1 to 256 do
        arr[i]:='';
    end else
      ch:='E';
  until ch='E';
end.

сНежная я сделал только для английских букв

[сНежная]

Работает! Огромное спасибо! Сейчас буду пытаться понять, как это сделано!

[klem4]

const max_words = 128;
type
  TWords = array [1..max_words] of String;

function GetWords(s: String; var w: TWords): Integer;
var
  n, i: Integer;
begin
  n := 0;
  while Length(s) > 0 do begin
    inc(n);
    i := 1;
    while (i <= Length(s)) and (s[i] <> ' ') do inc(i);
    w[n] := Copy(s, 1, pred(i));
    delete(s, 1, i);
  end;
  GetWords := n;
end;

procedure Exchange(var w: TWords; const n: Integer);
var
  i: Integer;
  T: String;
begin
  i := 2;
  while (i <= n) do begin
    T := w[i]; w[i] := w[pred(i)]; w[pred(i)] := T;
    inc(i, 2);
  end;
end;

var
  s: String;
  w: TWords;
  n, i: Integer;

begin
  repeat
    clrscr;
    write('s = '); readln(s);
  until (s[1] <> ' ') and (Pos('  ', s) = 0);

  n := GetWords(s, w);
  Exchange(w, n);
  for i := 1 to n do write(w[i], ' ');
end.

[arhimag]

klem4 , я не уверен что автор темы знает функции Copy, Delete, Pos и т.д.

[volvo]

Опять за флейм? А насчет Length ты что, уверен? А насчет While? Мало ли, кто чего не знает? Если ты не знаешь, что такое Thread, давай, Windows+Linux + все остальные многозадачные ОСи отменим? Ты ведь этого не знаешь, это же ужасно, как в MS ТЕБЯ не спросили, знаком ли ты с этим понятием, или не очень?