Кодирование стего двоичными нулями.
program StegoZero;

(***************************************************************)
(*     Простая  стеганографическая  программа  для  работы   с *)
(* текстами основанная на подмене первого пробела в группе  из *)
(* двух  или  более  пробелов  двоичным  нулём.  Режим  работы *)
(* программы определяется параметрами вызова. Возможны от 1 до *)
(* 3 параметров, из которых первый описывает файл-контейнер.   *)
(*     Если  этот  параметр   единственный,   то   проверяется *)
(* наличие стеганограммы в контейнере с выводом результата  на *)
(* экран. По сути это режим стеганодетектора.                  *)
(*     Если таких параметров два, стеганограмма извлекается из *)
(* контейнера, а  результат  записывается  в  заданный  вторым *)
(* параметром файл.                                            *)
(*     Наконец,  если  используются  все  три  параметра,   то *)
(* стеганографический  текст   из   файла   заданного   вторым *)
(* параметром, упрятывается в файл-контейнер, заданный  первым *)
(* параметром, а результат стеганографического  преобразования *)
(* записывается   в   файл,   заданный   третьим   параметром. *)
(* Совпадение двух имён файлов допускается (трёх - абсурд).    *)
(***************************************************************)

type
      StringType = string [$FF];

const
      TempName = '$$$$$$$$.$$$';
      Key1     = $1234;
      Key2     = $4567;

var
      F, G, H    : text;
      Line       : StringType;
      I, K, L, Z : byte;
      C          : char;
      Count      : real;

begin
      LowVideo;

      if not (ParamCount in [1..3])
      then
           begin
                 WriteLn ('Ожидается от  1 до 3  параметров:');
                 WriteLn ('1 - вывод стеганограммы на экран;');
                 WriteLn ('2 - вывод стеганограммы  в  файл;');
                 WriteLn ('3 - запись стеганограммы в  файл.');
                 Exit
           end;

      Assign (F, ParamStr (1));
      Reset (F);
      Count := 0;

      MemW [Dseg : $01FE] := Key1;
      MemW [Dseg : $01FC] := Key2;

(*---------------------ВЫВОД СТЕГАНОГРАММЫ НА ЭКРАН--------------------*)
      if ParamCount = 1
      then
           begin
                 L := 0;
                 Z := 0;

                 while not Eof (F)
                 do
                    begin
                          ReadLn (F, Line);

                          while (Line <> '')
                            and (Line [1] <= ' ')
                          do Delete (Line, 1, 1);

                          while (Line <> '')
                            and (Line [Length (Line)] <= ' ')
                          do Delete (Line, Length (Line), 1);

                          while Line <> ''
                          do
                             begin
                                   while (Line <> '') and (Line [1] > ' ')
                                   do Delete (Line, 1, 1);

                                   if (Length (Line) > 1)
                                    and ((Copy (Line, 1, 2) = #00' ')
                                      or (Copy (Line, 1, 2) =   '  '))
                                   then
                                        begin
                                              Z := Z shr 1;

                                              if Line [1] = #00
                                              then Z := Z or $80;

                                              L := Succ (L) mod 8;

                                              if L = 0
                                              then Write (Chr (Z))
                                        end;

                                   while (Line <> '') and (Line [1] <= ' ')
                                   do Delete (Line, 1, 1)
                             end
                    end;

                 Close (F);

                 if WhereX <> 1
                 then WriteLn;

                 WriteLn ('Ok!');
                 Exit
           end;

(*----------------------ВЫВОД СТЕГАНОГРАММЫ В ФАЙЛ---------------------*)
      if ParamCount = 2
      then
           begin
                 if Pos (':', ParamStr (2)) <> 2
                 then Assign (G, TempName)
                 else Assign (G, Copy (ParamStr (2), 1, 2) + TempName);

                 Rewrite (G);

                 L := 0;
                 Z := 0;

                 while not Eof (F)
                 do
                    begin
                          ReadLn (F, Line);

                          while (Line <> '')
                            and (Line [1] <= ' ')
                          do Delete (Line, 1, 1);

                          while (Line <> '')
                            and (Line [Length (Line)] <= ' ')
                          do Delete (Line, Length (Line), 1);

                          while Line <> ''
                          do
                             begin
                                   while (Line <> '') and (Line [1] > ' ')
                                   do Delete (Line, 1, 1);

                                   if (Length (Line) > 1)
                                    and ((Copy (Line, 1, 2) = #00' ')
                                      or (Copy (Line, 1, 2) =   '  '))
                                   then
                                        begin
                                              Z := Z shr 1;

                                              if Line [1] = #00
                                              then Z := Z or $80;

                                              L := Succ (L) mod 8;

                                              if L = 0
                                              then
                                                   begin
                                                         Count := Count + 1;
                                                         C := Chr (Z
                                                           xor Random (256));
                                                         Write (G, C);
                                                         Write (C)
                                                   end
                                        end;

                                   while (Line <> '') and (Line [1] <= ' ')
                                   do Delete (Line, 1, 1)
                             end
                    end;

                 Close (F);
                 Close (G);
                 Assign (F, ParamStr (2));
(*$I-*)
                 Erase (F);
(*$I+*)
                 I := IoResult;
                 Rename (G, ParamStr (2));

                 if WhereX <> 1
                 then WriteLn;

                 WriteLn ('Прочитано ', Count : 0 : 0, ' байт стего...');
                 Exit
           end;

(*----------------------ЗАПмСЬ СТЕГАНОГРАММЫ В ФАЙЛ--------------------*)
      Assign (G, ParamStr (2));

      if Pos (':', ParamStr (3)) <> 2
      then Assign (H, TempName)
      else Assign (H, Copy (ParamStr (3), 1, 2) + TempName);

      Reset   (G);
      Rewrite (H);
      L := 0;

      while not Eof (F)
      do
         begin
               ReadLn (F, Line);
               I := 0; (* последний пробельный символ *)

               while (I < Length (Line)) and (Line [Succ (I)] <= ' ')
               do I := Succ (I);

               K := Length (Line); (* последний непробельный символ *)

               while (K > I) and (Line [K] <= ' ')
               do K := Pred (K);

               while I < K
               do
                  begin
                        while (I < K) and (Line [Succ (I)] > ' ')
                        do I := Succ (I);

                        if (K - I > 2) and (Copy (Line, Succ (I), 2) = '  ')
                        then
                             begin
                                   if L = 0
                                   then
                                        begin
                                              if Eof (G)
                                              then C := #00
                                              else Read (G, C);

                                              Z := Ord (C) xor Random (256)
                                        end;

                                   if Z and 1 = 1
                                   then Line [Succ (I)] := #00;

                                   Z := Z shr 1;
                                   L := Succ (L) mod 8;
                                   I := I + 2;

                                   if L = 0
                                   then
                                        begin
                                              Write (C);
                                              Count := Count + 1
                                        end
                             end;

                        while (I < K) and (Line [Succ (I)] = ' ')
                        do I := Succ (I)
                  end;

               WriteLn (H, Line)
         end;

      Close (F);
      Close (G);
      Close (H);

      Assign (F, ParamStr (3));
(*$I-*)
      Erase (F);
(*$I+*)
      I := IoResult;
      Rename (H, ParamStr (3));

      if WhereX <> 1
      then WriteLn;

      WriteLn ('Записано ', Count : 0 : 0, ' байт стего...');
      Exit
end.
456