Program _Coder_;
{$D+,E-,N+,G+}
var
f, ftmp, fr, ftb : Text;
S : Char;
S1 : String;
Src, Dst : String;
fname, fresname, ftbname, tablename : String;
Red, Green, Blue, Gray : String;
Encode, AllSmb, inTag : Boolean;
Conv : Byte;
i, j, Lng : Integer;
Bl, Grn, Rd, Gr, Code, Code1, Color, InvMode : Integer;
Rot : array[1..3] of Byte;
ColCnt : Byte;
CurCol : Byte;
CA, CountChar : array[1..128] of Byte;
ColChAr : array [1..128, 1..128] of Char;
ChChange : Char;
const
tmpname = 'cdr.tmp';
Procedure SelectColor;
var
i : Byte;
begin
i := 1;
While Gr <[/E]|table>');
WriteLn('/G - преобразовать в оттенки серого');
WriteLn('/I{rb} - инвертировать цвета в файле');
WriteLn('/R - поменять цвета местами (новое местоположение указывается');
WriteLn(' цифрами 1, 2, 3 , для красного, зелёного, синего соответственно)');
WriteLn(' 0 - исключить цвет');
WriteLn('/T - создать из HTM-файла txt-файл, на основе таблицы table.');
WriteLn(' 1 - использовать символы, начиная с 32-ого, 0 - все символы.');
WriteLn(' 0..7 - совокупность основных цветов (1 + 2 + 4)');
WriteLn('/E - параметр, указывающий, что по файлу tablefile необходимо');
WriteLn(' произвести кодирование.');
Halt;
end;
fname := ParamStr(1);
fresname := ParamStr(2);
ftbname := ParamStr(3);
S1 := ' ';
S1 := UpString(ftbname);
if S1='/G' then Conv := 1;
if (S1[1]+S1[2]='/I') then
begin
Conv := 2;
if S1[3] = 'R' then InvMode := 1;{reverse}
if S1[3] = 'B' then InvMode := 2;{half byte change}
end;
if (S1[1]+S1[2]='/R') then
begin
Conv := 3;
Val(S1[3], Rot[1], Code);
Val(S1[4], Rot[2], Code);
Val(S1[5], Rot[3], Code);
end;
if (S1[1]+S1[2]='/T') then
begin
Conv := 4;
if S1[3] = '0' then AllSmb := True;
if S1[3] = '1' then AllSmb := False;
Val(S1[4], Color, Code);{0 - никакого, 1 - кр, 2 - зел, 4 - синий}
Color := Color and $0F;
end;
if (S1[1]+S1[2]='/C') then
begin
Conv := 5;
ChChange := S1[3];
end;
if ParamCount > 3 then
begin
tablename := ParamStr(4);
Encode := (UpString(tablename)='/E');
end;
WriteLn('Обрабатывается файл '+fname+'>>'+fresname);
Assign(f, fname);
Assign(fr, fresname);
Assign(ftmp, tmpName);
if Conv=0 then
begin
Assign(ftb, ftbname);
Reset(ftb);
ReadLn(ftb, Src);
ReadLn(ftb, Dst);
Close(ftb);
if Length(Src) <> Length(Dst) then
begin
WriteLn('Внимание! Строки для перекодировки должны иметь одинаковую длину!');
Halt;
end;
Lng := Length(Src);
end;
Reset(f);
Rewrite(ftmp);
if (Conv<>0) and (Conv<>4) then
While not EOF(f) do
begin
Read(f, S);
if S='<' then inTag := True;
if (not inTag) and (Conv=5) then
if not (S in [#0..#31]) then S := ChChange;
if S='>' then inTag := False;
Write(ftmp, S);
if (S='=') and inTag and (Conv<>5) then
begin
Read(f, Red[2]);
Read(f, Red[3]);
Read(f, Green[2]);
Read(f, Green[3]);
Read(f, Blue[2]);
Read(f, Blue[3]);
Val(Blue, Bl, Code);
Code1 := Code;
Val(Green, Grn, Code);
Code1 := Code1 + Code;
Val(Red, Rd, Code);
Code1 := Code1 + Code;
if Code1 <> 0 then
begin
Write(ftmp, Red[2]);
Write(ftmp, Red[3]);
Write(ftmp, Green[2]);
Write(ftmp, Green[3]);
Write(ftmp, Blue[2]);
Write(ftmp, Blue[3]);
end
else
case Conv of
1:
begin {Шкала серого}
Gr := Round(1.0*(Bl+Grn+Rd)/3);
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
end; {Шкала серого}
2:
begin {Инверсия}
case InvMode of
0:begin
Gr := not Rd;
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Gr := not Grn;
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Gr := not Bl;
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
end;
1:begin {reverse bytes}
Gr := Reverse(Rd);
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Gr := Reverse(Grn);
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Gr := Reverse(Bl);
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
end;
2:begin {half byte change}
Gr := (Rd and $0F) shl 4 + (Rd and $F0) shr 4;
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Gr := (Grn and $0F) shl 4 + (Grn and $F0) shr 4;
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
Gr := (Bl and $0F) shl 4 + (Bl and $F0) shr 4;
Gray := HexB(Byte(Gr));
Write(ftmp, Gray[1]);
Write(ftmp, Gray[2]);
end;
end;
end; {Инверсия}
3:
begin {Перемещение цветов}
S1 := '000000';
S1[2*Rot[1]-1] := Blue[2];
S1[2*Rot[1]] := Blue[3];
S1[2*Rot[2]-1] := Green[2];
S1[2*Rot[2]] := Green[3];
S1[2*Rot[3]-1] := Red[2];
S1[2*Rot[3]] := Red[3];
Byte(S1[0]) := 6;
Write(ftmp, S1);
end; {Перемещение цветов}
end;{case}
end;{if S='='...}
end {if Conv<>0 ... While not EOF(f)...}
else if Conv<>4 then
if Encode then
While not EOF(f) do
begin
Read(f, S);
for i := 1 to Lng do
if S=Src[i] then
begin
S := Dst[i];
Break;
end;
Write(ftmp, S);
end
else
While not EOF(f) do
begin
Read(f, S);
for i := 1 to Lng do
if S=Dst[i] then
begin
S := Src[i];
Break;
end;
Write(ftmp, S);
end;
if Conv = 4 then
begin
Assign(ftb, tablename);
Reset(ftb);
ReadLn(ftb, S1);
ReadLn(ftb, S1);
Val(S1, ColCnt, Code);
if AllSmb then
begin
for i := 1 to ColCnt do
begin
ReadLn(ftb, S1);
Val(S1, CA[i], Code);
ReadLn(ftb, S1);
Val(S1, CountChar[i], Code);
end;
for i := 1 to ColCnt do
begin
for j := 1 to CountChar[i] do
Read(ftb, ColChAr[i, j]);
ReadLn(ftb);
end;
end;
if not AllSmb then
begin
ReadLn(ftb, S1);
ReadLn(ftb, S1);
Val(S1, ColCnt, Code);
for i := 1 to ColCnt do
begin
ReadLn(ftb, S1);
Val(S1, CA[i], Code);
ReadLn(ftb, S1);
Val(S1, CountChar[i], Code);
end;
for i := 1 to ColCnt do
begin
for j := 1 to CountChar[i] do
Read(ftb, ColChAr[i, j]);
ReadLn(ftb);
end;
end;
Close(ftb);
While not EOF(f) do
begin
Read(f, S);
if S='<' then
begin
inTag := True;
Read(f, S);
S1 := UpCase(S);
Read(f, S);
S1 := S1+UpCase(S);
if S1 = 'BR' then WriteLn(ftmp);
end;
if S='>' then inTag := False;
if inTag and (S='=') then
begin
Read(f, Red[2]);
Read(f, Red[3]);
Read(f, Green[2]);
Read(f, Green[3]);
Read(f, Blue[2]);
Read(f, Blue[3]);
Val(Blue, Bl, Code);
Code1 := Code;
Val(Green, Grn, Code);
Code1 := Code1 + Code;
Val(Red, Rd, Code);
Code1 := Code1 + Code;
if Code1=0 then
begin
Gr := 0;
if (Color and 1)<>0 then Gr := Gr+Rd;
if (Color and 2)<>0 then Gr := Gr+Grn;
if (Color and 4)<>0 then Gr := Gr+Bl;
if Color <> 0 then Gr := Round(1.0*Gr/(1.0*HowMBits(Color)));
SelectColor;
end;
end;
if not inTag and not (S in ['>',#$0D,#$0A]) then
begin
S := SelectChar;
Write(ftmp, S);
end;
end;
end;
Close(ftmp);
Close(f);
{$I-}
Rename(ftmp, fresname);
{$I+}
if IOResult<>0
then
begin
{$I-}
Erase(fr);
Rename(ftmp, fresname);
{$I+}
end;
end.
< -->