Удалить из строки первое и последнее вхождение заданной подстроки.

uses crt;
procedure vvod(var s:string;s1:string);
begin
writeln(s1);
readln(s);
end;
function del(s,ps:string):string;
var i,p:integer;
begin
if pos(ps,s)>0 then delete(s,pos(ps,s),length(ps));
i:=length(s)-length(ps)+1;
p:=0;
while (i>0)and(p=0) do
if copy(s,i,length(ps))=ps then p:=i
else dec(i);
if p>0 then delete(s,p,length(ps));
del:=s;
end;
procedure vyvod(s,s1,ps:string);
begin
writeln(s1,ps);
writeln(s);
end;
var s,ps:string;
begin
clrscr;
vvod(s,'Введите строку');
vvod(ps,'Введите подстроку');
s:=del(s,ps);
vyvod(s,'Удаление первой и последней подстроки ',ps);
readln
end.

function del(s,ps:string):string;
var i,p:integer;
begin
  if pos(ps,s)>0 then delete(s,pos(ps,s),length(ps));
  if rpos(ps, s) > 0 then delete(s, rpos(ps, s), length(ps)); // подключить в uses модуль StrUtils
  del:=s;
end;

function del(s,ps: String): String;
var
    i: Word;
begin
    i := Pos(ps, s);
    if (i > 0)
    then
    begin
        Delete(s, i, Length(ps));
        i := RPos(ps, s);
        if (i > 0)
        then
            Delete(s, i, Length(ps));
    end;
    del := s;
end;

function del(s, ps : string) : string;
var first, last, len : integer;
begin
  len := length(ps);
  first := pos(ps, s); last := rpos(ps, s);
  // (существуют как минимум 2 разных вхождения подстрок) И
  // (они пересекаются, т.е., второе начинается раньше, чем заканчивается первое)?
  if (first * last * (first - last) <> 0) and (first + len > last) then s := ''
  else
  begin
    // пересечения нет, или вхождении подстрок меньше 2-х
    if last > 0 then delete(s, last, len); // удаляем сначала последнее
    if (first > 0) and (first <> last) then delete(s, first, len); // а потом, если их было 2 разных - то и первое
  end;
  del := s; // всё, уходим
end;

uses
    strutils;
 
procedure InputString(var s: String; const param: String);
begin
    Write(param); ReadLn(s);
end;
 
function DelSubstring(const s, ps: String): String;
var
    mn: Set Of Byte = [];
    i, j: Byte;
    Result: String = '';
begin
    i := Pos(ps, s);
    if (i > 0)
    then
    begin
        for j := i to i + Length(ps) - 1 do
            Include(mn, j);
        i := RPos(ps, s);
        for j := i to i + Length(ps) - 1 do
            Include(mn, j);
        for i := 1 to Length(s) do
            if Not (i in mn)
            then
                Result := Result + s[i];
    end;
    DelSubstring := Result;
end;
 
procedure OutputString(const s1, s2: String);
begin
    WriteLn('Original: ', s1);
    WriteLn('Modified: ', s2);
end;
 
var
    s, ss: String;
begin
    InputString(s, 'Input string: ');
    InputString(ss, 'Input substring: ');
    OutputString(s, DelSubstring(s, ss));
end.