Найти все слова состоящие из латинских букв, расположенных в алфавитном порядке

procedure DelSpaces(var s: String);
begin
    while ((Length(s) > 0) And (s[1] = ' ')) do
        Delete(s, 1, 1);
end;
 
function ClipWord(var s: String): String;
var
    Result: String;
begin
    Result := '';
    while (s[1] <> ' ') do
    begin
        Result := Result + s[1];
        Delete(s, 1, 1);
    end;
    ClipWord := Result;
end;
 
function Check(const s: String): Boolean;
var
    i: Byte;
    Result: Boolean;
begin
    Result := True; i := 1;
    while ((i < Length(s)) And Result) do
    begin
        Result := Ord(s[i + 1]) >= Ord(s[i]);
        Inc(i);
    end;
    Check := Result;
end;
 
var
    s, ss: String;
begin
    Write('s: '); ReadLn(s);
    s := s + ' ';
    DelSpaces(s);
    while (Length(s) > 0) do
    begin
        ss := ClipWord(s);
        DelSpaces(s);
        if (Check(LowerCase(ss)))
        then
            WriteLn(ss);
    end;
end.

function ToLowerCase(s: String): String;
var
    i: Byte;
    Uppers: Set Of Char;
begin
    Uppers := ['A'..'Z'];
    for i := 1 to Length(s) do
        if (s[i] in Uppers)
        then
            s[i] := Chr(Ord(s[i]) + 32);
    ToLowerCase := s;
end;

var s,l:string;
i,j,k,f,n:integer;
 
function Strch(c:char):integer;
begin
if (ord(c)>ord('A')) and (ord(c)<=ord('Z')) then
strch:=ord(c)-ord('A');
if (ord(c)>ord('a')) and (ord(c)<=ord('z')) then
strch:=ord(c)-ord('a');
end;
 
begin
  f:=0;
  n:=length(s);
  s:=s+' ';
  read(s);
  while i<n do 
begin
    if s[i]=' ' then 
begin
         delete(s,i,1);
         n:=n-1;
end;
    if s[i]<>' ' then 
 begin
     k:=pos(' ',s);
     for j:=i to k-2 do
     if strch(s[j])>strch(s[j+1]) then 
     f:=1;
    if f=0 then 
 begin
     l:=copy(s,i,k-1);
     writeln(l);
 end;
      f:=0;
      i:=k;
 end;
 end;
  end.

const
    Uppers : Set Of Char = ['A'..'Z'];
 
function ToLowerCase(c: Char): Char; //Strch
begin
    if (c in Uppers)
    then
        c := Chr(Ord(c) + 32);
    ToLowerCase := c; //Strch
end;
 
var
    s, ss: String;
    i: Byte;
    check: Boolean;
begin
    Write('s: '); ReadLn(s);
    s := s + ' ';
    while ((Length(s) > 0) And (s[1] = ' ')) do
        Delete(s, 1, 1); //можно сказать, проверяем, не состоит ли строка из одних пробелов
    while (Length(s) > 0) do
    begin
        ss := '';
        while (s[1] <> ' ') do //вырезаем слово
        begin
            ss := ss + s[1];
            Delete(s, 1, 1);
        end;
        while ((Length(s) > 0) And (s[1] = ' ')) do //удаляем пробелы после вырезанного слова
            Delete(s, 1, 1);
        check := True; i := 1;
        while ((i < Length(ss)) And check) do //проверяем на порядок слово
        begin
            check := Ord(ToLowerCase(ss[i + 1])) >= Ord(ToLowerCase(ss[i]));
            Inc(i);
        end;
        if (check)
        then
            WriteLn(ss);
    end;
end.

ss := Copy(s, 1, Pos(' ', s) - 1);
Delete(s, 1, Pos(' ', s) - 1);

function UpCase(Ch: Char): Char;