помогите доделать задачу, очень нужно!!! пожалуйста!!!

70K

15 февраля 2012 года

9 / / 08.12.2011

Дано предложение состоящее из N слов разделенные пробелами, надо вывести всевозможные перестановки слов в этом предложении, исключая повторения т.е. перестановки не должны повторяться

вот что я смог сделать:

Свернуть исходник

Код:

uses 

SysUtils; 

type Combination=array [1..100] of integer; 
var N: byte;S:string;p:integer; 

j,i:integer; 

x: combination; 
var a:array[0..100] of string; 

// Перевод из строки 
procedure Print; 
begin 

for i:=1 to n do 
write(' ',a[x]); 
writeln; 
end; 

procedure swap(var d,j:integer); 
var x:integer; 
begin 

x:=d; 

d:=j; 

j:=x; 
end; 

procedure generate(k:byte); 
var j:integer; 
begin 
if k=N then 

print 
else 
for j:=k+1 to n do begin 
swap (x[k+1],x[j]); 

generate(k+1); 
swap (x[k+1],x[j]); 
end; 
end; 
begin 

write('vvedite predlogenie: ');readln(s); 

s:=s+' '; j:=0; 
while copy (s,1,1)=' ' do delete(s,1,1); 
while s<>'' do begin 

j:=j+1; 
while copy (s,1,1)<>' ' do begin 

a[j]:=a[j]+copy (s,1,1); 
delete (s,1,1); 
end; 
while copy (s,1,1)=' ' do delete(s,1,1); 
end; 


N:=j; 
for i:=1 to N do x:=i; 

generate(0); 
readln; 

end.

доделайте пожалуйста!!!

Подписаться на вопросНеобходима регистрация

По порядку

Сначала полезные

Сначала решения

2 ответа

1 спам

14K

16 февраля 2012 года

dsoft

36 / / 08.06.2006

Как вариант:

Свернуть исходник

Код:

program words;

{$APPTYPE CONSOLE}

uses

  SysUtils;

type

  TCharSet  = TSysCharSet;

var

  Count     : Integer;

  St        : String;

  BufWords  : array[1..100] of String;

function WordCount(const S : String; const WordDelims : TCharSet) : Integer;
var

  SLen, K : Cardinal;
begin

  Result := 0;

  K := 1;

  SLen := Length(S);

  while K <= SLen do

  begin

    while (K <= SLen) and (S[K] in WordDelims) do

      Inc(K);

    if K <= SLen then

      Inc(Result);

    while (K <= SLen) and not(S[K] in WordDelims) do

      Inc(K);

  end;
end;

function WordPosition(const Index : Integer; const S : String; const WordDelims : TCharSet) : Integer;
var

  Count, K : Integer;
begin

  Count := 0;

  K := 1;

  Result := 0;

  while (K <= Length(S)) and (Count <> Index) do

  begin

    while (K <= Length(S)) and (S[K] in WordDelims) do

      Inc(K);

    if K <= Length(S) then

      Inc(Count);

    if Count <> Index then

      while (K <= Length(S)) and not (S[K] in WordDelims) do

        Inc(K)

    else

      Result := K;

  end;
end;

function ExtractWord(Index : Integer; const S : String; const WordDelims : TCharSet) : String;
var

  K, Len : Integer;
begin

  Len := 0;

  K := WordPosition(Index, S, WordDelims);

  if K <> 0 then

    { find the end of the current word }

    while (K <= Length(S)) and not(S[K] in WordDelims) do

    begin

      { add the I'th character to result }

      Inc(Len);

      SetLength(Result, Len);

      Result[Len] := S[K];

      Inc(K);

    end;

  SetLength(Result, Len);
end;

// Перевод из строки
procedure Print;
var

  K : Integer;
begin

  for K := 1 to Count do

    Write(' ', BufWords[K]);

  WriteLn;
end; 

procedure Generate(K : Integer);
var

  J : Integer;

  procedure Swap(K, J : Integer);

  var

    Temp : String;

  begin

    Temp        := BufWords[K];

    BufWords[K] := BufWords[J];

    BufWords[J] := Temp;

  end;

begin

  if K = Count then

    Print

  else

    for J := K + 1 to Count do

    begin

      Swap(K + 1, J);

      Generate(K + 1);

      Swap(K + 1, J);

    end;
end;

procedure Main;
var

  K : Integer;
begin

  Write('vvedite predlogenie: ');

  ReadLn(St);

  // считаем количество введённых слов

  Count := WordCount(St, [' ']);

  // заполняем буфер словами

  for K := 1 to Count do

    BufWords[K] := ExtractWord(K, St, [' ']);

  Generate(0);

  ReadLn;
end;

begin

  Main;
end.