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

type
      StringType = string [$FF];

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

var
      F, G, H                   : text;
      Line, Head, Tail, Body    : StringType;
      B, I, K, L, N, LenBody, Z : byte;
      C                         : char;
      Tab                       : array [0..255] of byte;
      Count                     : real;

begin
      LowVideo;

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

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

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

(*----------------------ВЫВОД СТЕГАНОГРАММЫ В ФАЙЛ---------------------*)
      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);
                 Z := 0;
                 L := 0;

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

                    (* 1. Выделяем тело строки *)
                          while (Line <> '')
                            and (Line [1] <= ' ')
                          do Delete (Line, 1, 1);

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

                    (* 2. Заполняем таблицу пробелов *)
                          FillChar (Tab, SizeOf (Tab), 0);
                          LenBody := Length (Line);

                          K := 0;
                          I := 0;

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

                                   if (I < LenBody) and (Line [I] = ' ')
                                   then
                                        begin
                                              K := Succ (K);
                                              N := 0;

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

                                              Tab [K] := N
                                        end
                             end;

                          if K > 0
                          then K := Pred (K);

                    (* 3. Декодируем биты *)
                          I := 0;

                          while I < K
                          do
                             begin
                                   I := Succ (I);

                                   if Tab [I] > 1
                                   then
                                        begin
                                              Z := Z shr 1;

                                              if Odd (Tab [I])
                                              then Z := Z or $80;

                                              L := Succ (L) mod 8;

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

           (* 4. Завершаем работу *)
                 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
         (* 1. мнициализируем таблицу раздвижек *)
               FillChar (Tab, SizeOf (Tab), 0);

         (* 2. Читаем и разделяем строку на части *)
               ReadLn (F, Line);
               I := 0;

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

               Tab [0] := I;
               (* начало строки *)
               Head := Copy (Line, 1, I);

               I := Length (Line);

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

               (* конец строки *)
               Tail := Copy (Line, Succ (I), Length (Line) - I);
               (* тело строки *)
               Body := Copy (Line, Succ (Tab [0]), I - Tab [0]);

         (* 3. Редуцируем тело строки *)
               LenBody := Length (Body);

               while Pos ('  ', Body) > 0
               do Delete (Body, Pos ('  ', Body), 1);

               (* число вставляемых пробелов *)
               N := LenBody - Length (Body);

         (* 4. Заполняем таблицу раздвижек *)
               K := 0;

               for I := 1 to Length (Body)
               do
                  if Body [I] = ' '
                  then
                       begin
                             K := Succ (K);
                             Tab [K] := 1
                       end;

         (* 5. Распределяем значимые (информационные) пробелы *)
               I := 1;

               while I < K
               do
                  begin
                        if L = 0
                        then (* извлекаем очередной байт *)
                             begin
                                   if Eof (G)
                                   then C := #00
                                   else Read (G, C);

                                   Count := Count + 1;
                                   Z := Ord (C) xor Random (256);
                                   B := Z and 1;
                                   L := 1;
                                   Write (C);
                             end;

                        if N > Succ (B)
                        then (* запас пробелов не исчерпан *)
                             begin
                                   (* кодируем бит в таблице *)
                                   Tab [I] := Tab [I] + Succ (B);
                                   (* текущий запас пробелов *)
                                   N := N - Succ (B);
                                   (* указываем следующий бит *)
                                   Z := Z shr 1;
                                   B := Z and 1;
                                   (* счётчик записанных битов *)
                                   L := Succ (L) mod 9
                             end;

                        I := Succ (I)
                  end;

         (* 6. Монотонно перераспределяем информационные пробелы *)
               if K > 2
               then (* число пробелов должно возрастать к концу строки *)
                    begin
                          I := 0;

                          while (Tab [Pred (K)] = 1) and (I < K)
                          do
                             begin
                                   Move (Tab [1], Tab [2], K - 2);
                                   Tab [1] := 1;
                                   I := Succ (I)
                             end
                    end;

         (* 7. Распределяем выравнивающие (незначимые) пробелы *)
               while N > 1
               do
                  begin
                        I := K;

                        while (I > 0) and (N > 1)
                        do
                           begin
                                 if (Tab [I] > 1) or (I = K)
                                 then
                                      begin
                                            Tab [I] := Tab [I] + 2;
                                            N := N - 2
                                      end;

                                 I := Pred (I)
                           end
                  end;

               Tab [K] := Tab [K] + N;

         (* 8. Вставляем пробелы в тело строки *)
               N := Length (Body);

               while (N > 0) and (K > 0)
               do
                  begin
                        while (N > 0) and (Body [N] <> ' ')
                        do N := Pred (N);

                        if (Tab [K] > 0) and (N > 0)
                        then
                             for I := 1 to Pred (Tab [K])
                             do Insert (' ', Body, N);

                        if K > 0
                        then K := Pred (K);

                        if N > 0
                        then N := Pred (N)
                  end;

         (* 9. Формируем и записываем строку *)
               Line := Head + Body + Tail;
               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;

      if (Count <> 0) and (L <> 0)
      then Count := Count - 1;

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