Листинг 4.

Кодирование стего знаками совпадающего начертания.

program StegoChange;

(***************************************************************)
(*     Простая  стеганографическая  программа  для  работы   с *)
(* русскими текстами основанная на  частичной  замене  русских *)
(* символов  латинскими   одинакового   с   ними   начертания. *)
(* мспользует от 1  до  3  параметров,  которые  и  определяют *)
(* выполняемую  программой  функцию.  При   этом   первый   из *)
(* параметров всегда представляет файл-контейнер.              *)
(*     Если  этот  параметр   единственный,   то   проверяется *)
(* наличие  стеганограммы   в   файле-контейнере   с   выводом *)
(* результата на экран. По сути это режим стеганодетектора.    *)
(*     Если таких параметров два, стеганограмма извлекается из *)
(* контейнера, а  результат  записывается  в  заданный  вторым *)
(* параметром файл.                                            *)
(*     Наконец,  если  используются  все  три  параметра,   то *)
(* стеганографический  текст   из   файла   заданного   вторым *)
(* параметром, упрятывается в файл-контейнер, заданный  первым *)
(* параметром, а результат стеганографического  преобразования *)
(* записывается   в   файл,   заданный   третьим   параметром. *)
(* Совпадение двух имён файлов допускается (трёх - абсурд).    *)
(*     Литература:    О.Шарапов.    Программная    русификация *)
(* матричных принтеров. //Монитор. - 1993, #3, стр. 48..57.    *)
(***************************************************************)

type
      StringType = string [$FF];
      Index      = (Rus, Lat);
      SetOfChar  = set of char;

const
      TempName = '$$$$$$$$.$$$';
      Max      = 13;
      Key1     = $1234;
      Key2     = $4567;
      Tab : array [Index, 1..22] of char = ('ВЕКМНРСТХаеосАОикпрту'#32,
                                            'BEKMHPCTXaeocAOuknpmy'#00);
var
      F, G, H   : text;
      X         : StringType;
      I, J      : integer;
      K, L      : byte;
      C, CC     : char;
      LatSet    : SetOfChar;
      CharSet   : SetOfChar;
      LargeLat  : SetOfChar;
      LargeChar : SetOfChar;
      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;

      L       := 0;
      LatSet  := [];
      CharSet := [];

      for I := 1 to Max
      do
         begin
               LatSet  := LatSet  + [Tab [Lat, I]];
               CharSet := CharSet + [Tab [Rus, I]] + [Tab [Lat, I]]
         end;

      LargeLat  := LatSet;
      LargeChar := CharSet;

      for I := Succ (Max) to 21
      do
         begin
               LargeLat  := LargeLat  + [Tab [Lat, I]];
               LargeChar := LargeChar + [Tab [Lat, I]] + [Tab [Rus, I]]
         end;

(*---------------------ВЫВОД СТЕГАНОГРАММЫ НА ЭКРАН--------------------*)
      if ParamCount = 1
      then
           begin
                 while not Eof (F)
                 do
                    begin
                          ReadLn (F, X);

                          for I := 1 to Length (X)
                          do
                             begin
                                   J := 1;
                                   C := X [I];

                                   if C in LargeChar
                                   then
                                        begin
                                              K := K shl 1;

                                              if C in LargeLat
                                              then K := K or 1;

                                              L := Succ (L) mod 8;

                                              if L = 0
                                              then Write (Chr (K))
                                        end;
                             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);

                 Assign (G, TempName);
                 Rewrite (G);

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

                          for I := 1 to Length (X)
                          do
                             begin
                                   J := 1;
                                   C := X [I];

                                   if C in CharSet
                                   then
                                        begin
                                              K := K shl 1;

                                              if C in LatSet
                                              then K := K or 1;

                                              L := Succ (L) mod 8;

                                              if L = 0
                                              then
                                                begin
                                                  Count := Count + 1;
                                                  K := K xor Random (256);
                                                  Write (Chr (K));
                                                  Write (G, Chr (K))
                                                end
                                        end;
                             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);

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

               for I := 1 to Length (X)
               do
                  begin
                        J := 1;
                        C := X [I];

                        while (J <= Max) and (C <> Tab [Rus, J])
                                         and (C <> Tab [Lat, J])
                        do J := Succ (J);

                        if J <= Max
                        then
                             begin
                                   if L = 0
                                   then
                                        begin
                                              if Eof (G)
                                              then CC := #00
                                              else Read (G, CC);

                                              Count := Count + 1;
                                              Write (CC);
                                              K := Ord (CC) xor Random (256)
                                        end;

                                   if K and $80 <> 0
                                   then X [I] := Tab [Lat, J]
                                   else X [I] := Tab [Rus, J];

                                   K := K shl 1;
                                   L := Succ (L) mod 8
                             end
                  end;

               WriteLn (H, X)
         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.