Операции над строками

function Reverse(s: string): string;
var
  i, sLen: byte;
  tmp: char;
begin
  sLen := Length(s);
  for i := 1 to sLen div 2 do
  begin
    tmp := s[i];
    s[i] := s[sLen - i + 1];
    s[sLen - i + 1] := tmp;
  end;
  Reverse := s;
end;

function DeleteDoubleS(s: string): string;
var
  i: byte;
begin
  for i := Length(s) - 1 downto 1 do
    if (s[i] = ' ') and (s[i + 1] = ' ') then
      Delete(s, i, 1);
  DeleteDoubleS := s;
end;

function MyTrim(const s: string): string;
var
  i,sLen: byte;
begin
  sLen := Length(s);
  i := 1;
  while (s[i] = ' ') and (i <= sLen) do
    Inc(i);
  if i > sLen then
    MyTrim := ''
  else
  begin
    while s[sLen] = ' ' do
      Dec(sLen);
    MyTrim := Copy(s, i, sLen - i + 1);
  end;
end;

function Replace(const s,wF,wR: string): string;
const
  Dividers = [' ', '.', ',', ':', '-', ';'];
var
  i,sLen: byte;
  tmp: string;
begin
  sLen := Length(s);
  tmp := '';
  for i := 1 to sLen do
  begin
    if not (s[i] in Dividers) then
      tmp := tmp + s[i];
    if (s[i] in Dividers) or (i = sLen) then
      if tmp = wF then
      begin
        if (i = sLen) and not (s[i] in Dividers) then
          Replace := Copy(s, 1, i - Length(wF)) + wR + Copy(s, i + 1, 255)
        else
          Replace := Copy(s, 1, i - Length(wF) - 1) + wR + Copy(s, i, 255);
        exit;
      end
      else
        tmp := '';
  end;
  Replace := s;
end;

function RemoveExtraSpaces(s: string): string;
var
  src, dst: Byte;
begin
  src := 1;
  dst := 1;
  while src <= Length(s) do
  begin
    s[dst] := s[src];
    inc(dst);
    if s[src] <> ' ' then
      inc(src)
    else
      repeat
        inc(src);
      until (src <= Length(s)) and (s[src] <> ' ');
  end;
  s[0] := Char(Byte(dst) - 1);
  RemoveExtraSpaces := s;
end;

program prob;
var
  s:string;
  i,k:integer;
begin
 readln(s);
   for i:=1 to length(s) do
     begin
      k:=pos(' ',s);
      if k>0 then delete(s,k,1)
     end;
 write(s);
end.

var
 S: string;
Begin
 S:=' fgf hh yy   hy  rf g'; {строка}
 while pos(' ',S)<>0 do delete(S,pos(' ',S),1);
 writeln(S);
 readln;
end.

Function StrToBin(TextValue:String):String;
 
    Function DecToBin(Int:Longint):String;{Перевод из 10 системы в 2 систему}
        Var
        StringConst:String[2];
        Res:String;
    Begin
        StringConst:='01';
        Res:='';
    Repeat
        Res:=StringConst[(Int Mod 2)+1] + Res;
        Int:=Int Div 2;
    Until Int=0;
        DecToBin:=Res;
    End;
 
Var
    TempString:String;
    OctString:String;
    BinString:String;
    i,k:Integer;
Begin
    For i:=1 To Length(TextValue) Do 
Begin
    TempString:=DecToBin(Ord(TextValue[i]));
    OctString:='';
If Length(TempString)<8 Then 
    Begin
        For k:=1 To 8-Length(TempString) Do 
            Begin
            OctString:=OctString+'0';
            End;
        End;
        TempString:=OctString+TempString;
        BinString:=BinString+TempString;
        StrToBin:=BinString;
    End;
End;

Function InWayFileName(Way:String;Expansion:Boolean):String;
    Var
        Name:String;{Если Expansion = True тогда результат функции имя файла с расширением, если False то выводится}
        i,j,k:Integer;{просто имя файла(без расширения)}
    Begin
        k:=0;
        j:=0;
        Name:='';
    For i:=1 To Length(Way) Do 
        Begin{Находим последний слеш в пути}
            k:=k+1;
            If Way[i]='\' Then j:=k;
        End;
    If Expansion = True Then 
        Begin
            For i:=j+1 To Pos('.',Way)-1 Do
                Name:=Name+Way[i];
        End Else
            For i:=j+1 To Length(Way) Do
                Name:=Name+Way[i];
    InWayFileName:=Name;
End;

Function Filename(Var str:string;f:boolean):string;
var
 s:string;
 i:byte;
begin
 for i:=length(str) downto 1 do
 if str[i]<>'\' then s:=str[i]+s
 else break;
 if f then Filename:=copy(s,1,pos('.',s)-1)
 else Filename:=s
end;

Function Filename(Var str:string;f:boolean):string;
var
 s:string;
 i:byte;
begin
 for i:=length(str) downto 1 do
 if str[i]<>'\' then s:=str[i]+s
 else break;
 if pos('.',s)=0 then writeln('Êàòàëîãè,ôàéëà íåò')
 else if f then Filename:=copy(s,1,pos('.',s)-1)
 else Filename:=s
end;

function Reverse( s: string):string;
var
  i, sLen:Byte;
Begin
  sLen:=length(s);
  for i:=1 to sLen do 
begin
   Insert(s[sLen], s, i);
   Delete(s, sLen+1, sLen);
end;
 Reverse:=s;
End;

unit FnUtils;
 
interface
 
(*Получить полное имя файла.*)
function GetFullFileName(const aFileName : String) : String;
(*Получить имя файла с расширением без пути.*)
function GetFileName(const aFileName : String) : String;
(*Получить имя файла без пути и без расширения.*)
function GetShortFileName(const aFileName : String) : String;
(*Получить расширение файла.*)
function GetFileExt(const aFileName : String) : String;
(*Получить полный путь к папке, в которой расположен заданный файл.*)
function GetFilePath(const aFileName : String) : String;
(*Получить полное имя исполняемого файла программы.*)
function GetExeName : String;
(*Получить полный путь к папке, в которой расположен исполняемый файл программы.*)
function GetExePath : String;
 
implementation
 
uses
  Dos;
 
(*
Получить полное имя файла.
---
Пример1:
Текущая папка   = 'D:\Bp\Projects\'
aFileName       = '0001\File1.txt'
GetFullFileName = 'D:\Bp\Projects\0001\File1.txt'
---
Пример2:
Текущая папка   = 'D:\Bp\Projects\0001\'
aFileName       = '..\0002\File1.txt'
GetFullFileName = 'D:\Bp\Projects\0002\File1.txt'
---
Пример3:
aFileName       = 'D:\Bp\Projects\0001\File1.txt'
GetFullFileName = 'D:\Bp\Projects\0001\File1.txt'
*)
function GetFullFileName(const aFileName : String) : String;
begin
  GetFullFileName := FExpand(aFileName);
end;
 
(*
Получить имя файла с расширением без пути.
---
Пример1:
aFileName   = 'D:\Bp\Projects\0001\File1.txt'
GetFileName = 'File1.txt'
*)
function GetFileName(const aFileName : String) : String;
var
  (*Путь к файлу без имени самого файла.*)
  FDir : DirStr;
  (*Имя файла без пути и без расширения.*)
  FName : NameStr;
  (*Расширение файла.*)
  FExt : ExtStr;
begin
  FSplit(aFileName, FDir, FName, FExt);
  GetFileName := FName + FExt;
end;
 
(*
Получить имя файла без пути и без расширения.
---
Пример1:
aFileName        = 'D:\Bp\Projects\0001\File1.txt'
GetShortFileName = 'File1'
*)
function GetShortFileName(const aFileName : String) : String;
var
  FDir : DirStr;
  FName : NameStr;
  FExt : ExtStr;
begin
  FSplit(aFileName, FDir, FName, FExt);
  GetShortFileName := FName;
end;
 
(*Получить расширение файла.
---
Пример1:
aFileName  = 'D:\Bp\Projects\0001\File1.txt'
GetFileExt = '.txt'
---
Пример2:
aFileName  = 'File1'
GetFileExt = ''
*)
function GetFileExt(const aFileName : String) : String;
var
  FDir : DirStr;
  FName : NameStr;
  FExt : ExtStr;
begin
  FSplit(aFileName, FDir, FName, FExt);
  GetFileExt := FExt;
end;
 
(*
Получить полный путь к папке, в которой расположен заданный файл.
---
Пример1:
Текущая папка = 'D:\Bp\Projects\'
aFileName     = '0001\File1.txt'
GetFilePath   = 'D:\Bp\Projects\0001\'
---
Пример2:
Текущая папка = 'D:\Bp\Projects\0001\'
aFileName     = '..\0002\File1.txt'
GetFilePath   = 'D:\Bp\Projects\0002\'
---
Пример3:
Текущая папка - нет зависимости от текущей папки.
aFileName     = 'D:\Bp\Projects\0001\File1.txt'
GetFilePath   = 'D:\Bp\Projects\0001\'
*)
function GetFilePath(const aFileName : String) : String;
var
  (*Полное имя файла - состоит из полного пути и имени файла с расширением.*)
  FullFileName : String;
  (*Путь к файлу без имени самого файла.*)
  FDir : DirStr;
  (*Имя файла без пути и без расширения.*)
  FName : NameStr;
  (*Расширение файла.*)
  FExt : ExtStr;
begin
  FullFileName := FExpand(aFileName);
  FSplit(FullFileName, FDir, FName, FExt);
  GetFilePath := FDir;
end;
 
(*
Получить полное имя исполняемого файла программы. - Т. е., полный путь
с именем файла и с расширением.
---
Пример1:
Текущая папка = 'D:\Bp\Projects\'
ParamStr(0)   = '0001\PROJECT1.EXE'
GetExeName    = 'D:\BP\PROJECTS\0001\PROJECT1.EXE'
*)
function GetExeName : String;
begin
  GetExeName := FExpand( ParamStr(0) );
end;
 
(*
Получить полный путь к папке, в которой расположен исполняемый файл
программы.
---
Пример1:
Текущая папка = 'D:\Bp\Projects\'
ParamStr(0)   = '0001\PROJECT1.EXE'
GetExePath    = 'D:\BP\PROJECTS\0001\'
*)
function GetExePath : String;
var
  FullFileName : String;
  FDir : DirStr;
  FName : NameStr;
  FExt : ExtStr;
begin
  FullFileName := FExpand( ParamStr(0) );
  FSplit(FullFileName, FDir, FName, FExt);
  GetExePath := FDir;
end;
 
end.

program Project1;
 
uses
  FnUtils;
 
const
  (*Размер буфера в байтах для копирования данных.*)
  Size = 10000;
var
  (*Файловые переменные.*)
  F1, F2 : File;
  (*Имена файлов.*)
  Fn1, Fn2 : String;
  (*Указатель на буфер в памяти.*)
  PBuff : Pointer;
  (*Количество прочитанных байт из файла.*)
  Cnt : Integer;
  S : String;
begin
  repeat
    Writeln('Задайте путь и имя исходного файла:');
    Readln(Fn1);
    Assign(F1, Fn1);
    (*Попытка открыть файл. Установка режима доступа с минимальным
    блоком в 1 байт.*)
    {$I-}
    Reset(F1, 1);
    {$I+}
    if IOResult <> 0 then begin
      Writeln('Не удалось открыть указанный файл. Действие отменено.');
      Writeln('Повторить - Enter. Выход - любой символ + Enter.');
      Readln(S);
      Continue;
    end;
 
    (*Формируем полное имя целевого файла на основе имени исходного файла.*)
    Fn2 := GetExePath + Copy(GetShortFileName(Fn1), 1, 5) + '_cp' + GetFileExt(Fn1);
 
    Assign(F2, Fn2);
    (*Создание файла и открытие его в режиме доступа с минимальным
    блоком в 1 байт.*)
    Rewrite(F2, 1);
    (*Выделяем память для буфера и получаем указатель на первый байт
    выделенной памяти.*)
    GetMem(PBuff, Size);
    (*Копирование всего содержимого исходного файла в целевой файл.*)
    while not Eof(F1) do begin
      BlockRead(F1, PBuff^, Size, Cnt);
      BlockWrite(F2, PBuff^, Cnt);
    end;
 
    (*Освобождение памяти буфера.*)
    FreeMem(PBuff, Size);
    (*Закрытие файлов.*)
    Close(F1);
    Close(F2);
 
    Writeln('Файл:');
    Writeln(Fn1);
    Writeln('Скопирован под именем:');
    Writeln(Fn2);
 
    Writeln('Повторить - Enter. Выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.

program main;
type DelimSet = set of char;
 
function split(var dest: array of string; const s: string; const delim: DelimSet): integer;
var
  n, i, len: integer;
begin
  n:= 0;
  i:= 1;
  len:= Length(s);
 
  while (i <= len) do begin
    if s[i] in delim then
      repeat inc(i) until (i > len) or (not (s[i] in delim))
    else begin
      dest[n]:= '';
      while (i <= len) and (not (s[i] in delim)) do begin
        dest[n]:= dest[n] + s[i];
        inc(i);
      end;
      inc(n);
    end;
  end;
  split:= n;
end;
 
var i, amount:Integer;
    s:String;
    dest:array of string;
    const delimeter=[' ','*','/'];
begin
  writeln('Enter s string: ');
  read(s);
  writeln;
  amount:=split(dest,s,delimeter);
  for i:=1 to length(s) do
    write(dest[i]);
end.

var i, amount:Integer;
    s:String;
    dest: array[1..10] of string;
    const delimeter=[' ','*','/'];
begin
  writeln('Enter s string: ');
  readln(s);
  amount:=split(dest,s,delimeter);
  for i:=1 to amount do
    write(dest[i]);
end.

SetLength(dest, 10);

var s,w:string;
 p,len,count:integer;
begin
 write ('Введите строку: '); readln (s);
 p:=1;
 while p>0 do begin
  p:=pos(' ',s);  {ищем очередной пробел}
  if p>0 then w:=copy(s,1,p-1) {если есть - копируем в переменную "слово" символы до пробела}
  else w:=s; {если нет, то вся оставшееся строка - это одно слово}
  delete (s,1,p); {удаляем переписанное в w слово вместе с пробелом }
  len:=length(w); {находим длину слово}
  if len>0 then begin {"пустые" слова - лишние пробелы - не учитываем}
   inc(count); {Увеличиваем счетчик слов}
   writeln (w); {Просто выводим очередное слово -
                 вставьте сюда свой код}
  end;
 end;
 writeln ('Всего слов: ',count);
 write ('Нажмите ENTER для выхода');
 readln;
end.

const
  //Разделители слов.
  D = ['.', ',', ':', ';', '!', '?', '-', ' ', #9, #10, #13];
var
  S : String;
  i, Len, LenW, Cnt : Integer;
begin
  Writeln('Задайте текст:');
  Readln(S);
 
  Writeln('Выделенные из текста слова:');
  Len := Length(S);
  Cnt := 0; //Количество найденных слов.
  LenW := 0; //Длина очередного слова.
  for i := 1 to Len do
    if not (S[i] in D) then begin //Если символ не разделитель, значит он принадлежит слову.
      Inc(LenW); //Учитываем очередной символ в длине слова.
      if (i = Len) or (S[i + 1] in D) then begin //Отслеживаем конец слова.
        Inc(Cnt); //Подсчёт слова.
        Writeln(Copy(S, i - LenW + 1, LenW)); //Распечатка слова.
        LenW := 0; //Сброс длины слова.
      end;
    end;
  
  Writeln('Количество слов в заданном тексте = ', Cnt);
  Readln;
end.