Строки в Паскале

[ai\ekcah^p]

у меня вот так получилось

program zad;
uses crt;
var s:string[80];
    a:array[1..100] of string;
    i,j,kol,k:integer;
    begin
 clrscr;
 write('введите строку-> '); readln(s);
 kol:=1;
 i:=1;
 writeln;
 writeln('строку разбили на слова ');
 while (i<=length(s)) do
  begin
   if s[i]=' ' then
    begin inc(kol);inc(i);
    end;
   a[kol]:=a[kol]+s[i];
   inc(i);
  end;
  for i:=1 to kol do
  begin
   writeln(a[i]);
  end;
   kol:=1;
   writeln;
   writeln(' преобразованная строка -> ');
  for i:=1 to length(a[kol])-1 do begin
  for j:=i+1 to length(a[kol]) do begin
  if a[i]<>a[j] then
   begin
    writeln(a[kol]);
   end;
     kol:=kol+1;
     end;
     end;
     writeln(' если помог, нажми на весы слева ');
   readln;
end.

[Гамбит]

ясно... ну чтож буду пробывать

у меня нихрена не получается, если ктонибудь сможет помочь, то буду премного благодарен....

uses crt;
type str=string;
procedure ololo( var s:str);
var i,j,k,l,n:integer;s1:str;
begin
n:=ord(s[0]);
s1:=s;
l:=1;
S[0]:=#0;
for i:=1 to n do
if s1[i]=' ' then
k:=i;
for j:=l to k do
begin
if s1[j]=s1[j+1] then
s:=s+s1[j];
l:=k+1;
end;
end;
var s:str;
begin
clrscr;
read(s);
ololo(s);
write(s);
readln
end.

у меня получилось такое прошу помощи, ибо неработает =)

ну помогите ктонить!!!!!

[notHaker]

label NextWord;

var
  str : string;
  ind, StartChar, EndChar : integer;
  WrdCount : integer;

function IsBadWord(wrd : string; strt, count : integer) : boolean;
var
  ind : integer;
  aFlags : array[0..255] of boolean;
begin
 IsBadWord := false;
 {обнуляем массив с флагами}
 for ind := 0 to 255 do
   aFlags[ind] := false;
 {бежим по символам слова}
 {в качестве индекса массива флагов используем численное значения символа слова.
  если встречали символ, то выходим из цикла и возвращяем true}
 for ind := strt to count do
   if not aFlags[ord(wrd[ind])] then
     aFlags[ord(wrd[ind])] := true
   else
     begin
       IsBadWord := true;
       break;
     end;
end;

begin
  readln(str);
  if length(str) > 0 then
  begin
  ind := 1;
NextWord :
    {исчем первый не пробел}
    while (ind <= length(str)) and (str[ind] = #32) do
      inc(ind);
    {если последний был пробел, то вся строка из пробелов}
    if (ind <= length(str)) and (str[ind] <> #32) then
    begin
      StartChar := ind;
      {идём до пробела или конца строки}
      while (str[ind] <> #32) and (ind <= length(str)) do
        inc(ind);
      EndChar := ind;
      if IsBadWord(str,StartChar,EndChar) then {если "плохое" слово, то удаляем}
        delete(str,StartChar,EndChar - StartChar);
      goto NextWord; {если я применю рекурсию, то вы вабще замкнётесь :)
                      поэтому использую переход на NextWord}
    end;
  end
  else
    WriteLn('error : length(str) = 0');
  writeln(str);
  writeln('press any key');
  readln;
end.

этому коду побарабану сколько пробелов в конце или в начале строки, а также между словами... Вообщем он выполняет строго свою работу... Его можно исчо оптимизировать (pos,не чистить весь массив флагов,рекурсия, избавление от циклов), но но тогда я вас заморочу.

[Alex_FF]

вот решение, только работает для английского текста.

const
  Alphabet = ['A'..'Z', 'a'..'z'];

function Check(const S: String): Boolean;
var
  A: Array['A'..'Z'] of Byte;
  I: Integer;
begin
  Check := True;
  FillChar(A, SizeOf(A), 0);
  for I := 1 to Length(S) do
  begin
    Inc(A[UpCase(S[I])]);
    if A[UpCase(S[I])] > 1 then
    begin
      Check := False;
      Exit;
    end;
  end;
end;

var
  I: Integer;
  InStr, OutStr, tmp: String;
begin
  WriteLn('Введите строку');
  ReadLn(InStr);
  I := 1;
  while I <= Length(InStr) do
  begin
    tmp := '';
    while (InStr[I] in Alphabet) and (I <= Length(InStr)) do
    begin
      tmp := tmp + InStr[I];
      Inc(I);
    end;
    if Check(tmp) then OutStr := OutStr + tmp;
    OutStr := OutStr + InStr[I];
    Inc(I);
  end;
  WriteLn(OutStr);
  ReadLn;
end.

[Гамбит]

народ, а нельзя просто поправить мой текст? А то у вас уж очень мудрено получается.....

[Stilet]

Гамбит

Скажи ка мне вот ту ссылку что я давал ты читал, пробовал?

[notHaker]

Сообщение от Гамбит

народ, а нельзя просто поправить мой текст? А то у вас уж очень мудрено получается.....

У вас та же мудрёность и получится...

[Гамбит]

Stilet ну вообщето нет =)
И я должен извинится, я забыл сказать, что функции типа delete и copy использовать нельзя ... и всётаки можно мой код подправить? Просто я подозреваю, что у меня просто не хватает пары бегинов =)

[Гамбит]

Народ вот что у меня получилось, ПОМОГИТЕ РАССТАВИТ BEGINы плиз!

program lab_7;
uses crt;
type str=string;
procedure qwe( s:str);
var f:str;
i,j,k,l,n,t:integer;
begin
t:=0;
s:=f;
n:=ord(s[0]);
s[0]:=#0;
l:=1;
for i:=1 to n do
begin
if f[i]=' ' then
writeln('i=',i);
for k:=l to i do
begin
for j:=i+1 to i do
if f[j]=f[k] then
begin
t:=1;
exit;
end;
if t=0 then
for i:=l to i do
s:=s+f[k];
l:=i+1;
end;
end;  end;
var s:str;
begin
clrscr;
readln(s);
qwe(s);
writeln(s);
readln;
end.

[Гамбит]

Задачу решил. Всем спасибо за помощь