(* --------------------------------------------------------------------------

:Program.    Palette.mod
:Contents.   Program to change the sequence of Colors in a CPic - File
:Contents.   in different ways to improve the result of Crunching.
:Author.     Thomas Zipproth
:Address.    Dr. Jochner Weg 10, 8948 Mindelheim, Germany
:Phone.      08261/4838
:Copyright.  PD
:Language.   Modula-2
:Translator. M2-Amiga A+l V3.3d
:Imports.    CPicSupport [thz]
:Imports.    ToolSupport [thz]
:History.    V2.0 [thz] 2.8.90
:Usage.      Palette <inputfile> <outputfile> [mode]
:Usage.      inputfile  : a CPic - Picture File
:Usage.      outputfile : name of the improved CPic - File
:Usage.      mode       : a number from 0 to 7 (optional)

--------------------------------------------------------------------------- *)

(* $F- $R- $V- $S- *)
MODULE Palette;

FROM Arts        IMPORT Assert,TermProcedure;
FROM SYSTEM      IMPORT ADR;
FROM Graphics    IMPORT RastPortPtr,SetAPen,ReadPixel,WritePixel,LoadRGB4;
FROM Intuition   IMPORT ScreenPtr,CloseScreen;
FROM Dos         IMPORT Rename,DeleteFile;
FROM ToolSupport IMPORT GetArg,NumArgs,WriteString,WriteLn,WriteInt,StrToInt;
FROM CPicSupport IMPORT ci,LoadCPicScreen,SaveScreen,Cle;


VAR sp1 : ScreenPtr;
    rp1 : RastPortPtr;
    Name,Name2,Zahl : ARRAY[0..79] OF CHAR;
    signed,err,success : BOOLEAN;
    len,len2,dummy,i1,NCol,na,Modus: INTEGER;
    a,b,c,d,e,f,g,h,x0,y0,x1,y1 : INTEGER;
    i,j,k,length,Min,fl1,fl2 : LONGINT;
    Coll : ARRAY[0..31],[0..31] OF LONGINT;
    C1 :   ARRAY[0..31] OF LONGINT;
    opt,seq,druck :  ARRAY[0..31] OF INTEGER;
    use :  ARRAY[0..31] OF BOOLEAN;
    nc : ARRAY[1..5] OF INTEGER;


PROCEDURE CleanUp;
BEGIN
  IF sp1#NIL THEN CloseScreen(sp1) END;
END CleanUp;


PROCEDURE LoadCPic;
BEGIN
  err:=LoadCPicScreen(Name,sp1,0,0,FALSE);
  Assert(err,ADR("Couldn't load Picture !"));
  rp1  := ADR(sp1^.rastPort);
  NCol := nc[ci.Depth]-1;
  x0 := ci.PicX0*8;
  y0 := ci.PicY0;
  x1 := x0+ci.PicX*8;
  y1 := y0+ci.PicY;
END LoadCPic;


PROCEDURE ResetAll;
VAR i,j : INTEGER;
BEGIN
  FOR i:=0 TO 31 DO
    use[i]:=TRUE;C1[i]:=0;opt[i]:=0;
    FOR j:=0 TO 31 DO
      Coll[i,j]:=0;
    END;
  END;
  use[0]:=FALSE;
END ResetAll;


PROCEDURE ResetCollSort;
VAR i : INTEGER;
BEGIN
  FOR i:=0 TO 31 DO use[i]:=TRUE;opt[i]:=0 END;
  use[0]:=FALSE;
END ResetCollSort;


PROCEDURE CheckEight;
BEGIN
                 INC(Coll[a,b]);INC(Coll[a,c]);INC(Coll[a,d]);
  INC(Coll[a,e]);INC(Coll[a,f]);INC(Coll[a,g]);INC(Coll[a,h]);
  INC(Coll[b,a]);               INC(Coll[b,c]);INC(Coll[b,d]);
  INC(Coll[b,e]);INC(Coll[b,f]);INC(Coll[b,g]);INC(Coll[b,h]);
  INC(Coll[c,a]);INC(Coll[c,b]);               INC(Coll[c,d]);
  INC(Coll[c,e]);INC(Coll[c,f]);INC(Coll[c,g]);INC(Coll[c,h]);
  INC(Coll[d,a]);INC(Coll[d,b]);INC(Coll[d,c]);
  INC(Coll[d,e]);INC(Coll[d,f]);INC(Coll[d,g]);INC(Coll[d,h]);
  INC(Coll[e,a]);INC(Coll[e,b]);INC(Coll[e,c]);INC(Coll[e,d]);
                 INC(Coll[e,f]);INC(Coll[e,g]);INC(Coll[e,h]);
  INC(Coll[f,a]);INC(Coll[f,b]);INC(Coll[f,c]);INC(Coll[f,d]);
  INC(Coll[f,e]);               INC(Coll[f,g]);INC(Coll[f,h]);
  INC(Coll[g,a]);INC(Coll[g,b]);INC(Coll[g,c]);INC(Coll[g,d]);
  INC(Coll[g,e]);INC(Coll[g,f]);               INC(Coll[g,h]);
  INC(Coll[h,a]);INC(Coll[h,b]);INC(Coll[h,c]);INC(Coll[h,d]);
  INC(Coll[h,e]);INC(Coll[h,f]);INC(Coll[h,g]);
END CheckEight;


PROCEDURE CollCheck1;
VAR i,j : INTEGER;
BEGIN
  FOR i:=x0 TO x1-8 BY 8  DO
    FOR j:=y0 TO y1-1 DO
      a:=ReadPixel(rp1,i,j);
      b:=ReadPixel(rp1,i+1,j);
      c:=ReadPixel(rp1,i+2,j);
      d:=ReadPixel(rp1,i+3,j);
      e:=ReadPixel(rp1,i+4,j);
      f:=ReadPixel(rp1,i+5,j);
      g:=ReadPixel(rp1,i+6,j);
      h:=ReadPixel(rp1,i+7,j);
      CheckEight;
    END;
  END;
  FOR i:=0 TO NCol DO
    FOR j:=0 TO NCol DO C1[i]:=C1[i]+Coll[i,j] END;
    C1[i]:=C1[i]-Coll[i,i];
  END;
END CollCheck1;


PROCEDURE CollCheck2;
VAR i,j,k : INTEGER;
    a1,b1,c1,d1,e1,f1,g1,h1 : INTEGER;
BEGIN
  FOR i:=x0 TO x1-8 BY 8  DO

    a:=ReadPixel(rp1,i,0);
    b:=ReadPixel(rp1,i+1,0);
    c:=ReadPixel(rp1,i+2,0);
    d:=ReadPixel(rp1,i+3,0);
    e:=ReadPixel(rp1,i+4,0);
    f:=ReadPixel(rp1,i+5,0);
    g:=ReadPixel(rp1,i+6,0);
    h:=ReadPixel(rp1,i+7,0);

    FOR j:=y0+1 TO y1-1 DO

      a1:=ReadPixel(rp1,i,j);
      b1:=ReadPixel(rp1,i+1,j);
      c1:=ReadPixel(rp1,i+2,j);
      d1:=ReadPixel(rp1,i+3,j);
      e1:=ReadPixel(rp1,i+4,j);
      f1:=ReadPixel(rp1,i+5,j);
      g1:=ReadPixel(rp1,i+6,j);
      h1:=ReadPixel(rp1,i+7,j);

      INC(Coll[a,b]);INC(Coll[b,a]);INC(Coll[b,c]);INC(Coll[c,b]);
      INC(Coll[c,d]);INC(Coll[d,c]);INC(Coll[d,e]);INC(Coll[e,d]);
      INC(Coll[e,f]);INC(Coll[f,e]);INC(Coll[f,g]);INC(Coll[g,f]);
      INC(Coll[g,h]);INC(Coll[h,g]);

      INC(Coll[a,a1]);INC(Coll[a1,a]);INC(Coll[b,b1]);INC(Coll[b1,b]);
      INC(Coll[c,c1]);INC(Coll[c1,c]);INC(Coll[d,d1]);INC(Coll[d1,d]);
      INC(Coll[e,e1]);INC(Coll[e1,e]);INC(Coll[f,f1]);INC(Coll[f1,f]);
      INC(Coll[g,g1]);INC(Coll[g1,g]);INC(Coll[h,h1]);INC(Coll[h1,h]);

      a:=a1;b:=b1;c:=c1;d:=d1;e:=e1;f:=f1;g:=g1;h:=h1;

    END;

    INC(Coll[a,b]);INC(Coll[b,a]);INC(Coll[b,c]);INC(Coll[c,b]);
    INC(Coll[c,d]);INC(Coll[d,c]);INC(Coll[d,e]);INC(Coll[e,d]);
    INC(Coll[e,f]);INC(Coll[f,e]);INC(Coll[f,g]);INC(Coll[g,f]);
    INC(Coll[g,h]);INC(Coll[h,g]);

  END;

  FOR i:=0 TO NCol DO
    FOR j:=0 TO NCol DO C1[i]:=C1[i]+Coll[i,j] END;
    C1[i]:=C1[i]-Coll[i,i];
  END;

END CollCheck2;


PROCEDURE CollCheck3;
VAR i,j,k : INTEGER;
    a1,b1,c1,d1,e1,f1,g1,h1,a2,b2,c2,d2,e2,f2,g2,h2 : INTEGER;
BEGIN
  FOR i:=x0 TO x1-8 BY 8  DO

    a:=ReadPixel(rp1,i,0);
    b:=ReadPixel(rp1,i+1,0);
    c:=ReadPixel(rp1,i+2,0);
    d:=ReadPixel(rp1,i+3,0);
    e:=ReadPixel(rp1,i+4,0);
    f:=ReadPixel(rp1,i+5,0);
    g:=ReadPixel(rp1,i+6,0);
    h:=ReadPixel(rp1,i+7,0);

    a1:=ReadPixel(rp1,i,1);
    b1:=ReadPixel(rp1,i+1,1);
    c1:=ReadPixel(rp1,i+2,1);
    d1:=ReadPixel(rp1,i+3,1);
    e1:=ReadPixel(rp1,i+4,1);
    f1:=ReadPixel(rp1,i+5,1);
    g1:=ReadPixel(rp1,i+6,1);
    h1:=ReadPixel(rp1,i+7,1);

    FOR j:=y0+2 TO y1-1 DO

      a2:=ReadPixel(rp1,i,j);
      b2:=ReadPixel(rp1,i+1,j);
      c2:=ReadPixel(rp1,i+2,j);
      d2:=ReadPixel(rp1,i+3,j);
      e2:=ReadPixel(rp1,i+4,j);
      f2:=ReadPixel(rp1,i+5,j);
      g2:=ReadPixel(rp1,i+6,j);
      h2:=ReadPixel(rp1,i+7,j);

      CheckEight;

      INC(Coll[a,a1]);INC(Coll[a1,a]);INC(Coll[b,b1]);INC(Coll[b1,b]);
      INC(Coll[c,c1]);INC(Coll[c1,c]);INC(Coll[d,d1]);INC(Coll[d1,d]);
      INC(Coll[e,e1]);INC(Coll[e1,e]);INC(Coll[f,f1]);INC(Coll[f1,f]);
      INC(Coll[g,g1]);INC(Coll[g1,g]);INC(Coll[h,h1]);INC(Coll[h1,h]);

      INC(Coll[a,a2]);INC(Coll[a2,a]);INC(Coll[b,b2]);INC(Coll[b2,b]);
      INC(Coll[c,c2]);INC(Coll[c2,c]);INC(Coll[d,d2]);INC(Coll[d2,d]);
      INC(Coll[e,e2]);INC(Coll[e2,e]);INC(Coll[f,f2]);INC(Coll[f2,f]);
      INC(Coll[g,g2]);INC(Coll[g2,g]);INC(Coll[h,h2]);INC(Coll[h2,h]);

      a:=a1;b:=b1;c:=c1;d:=d1;e:=e1;f:=f1;g:=g1;h:=h1;
      a1:=a2;b1:=b2;c1:=c2;d1:=d2;e1:=e2;f1:=f2;g1:=g2;h1:=h2;
    END;
    INC(Coll[a1,a2]);INC(Coll[a2,a1]);INC(Coll[b1,b2]);INC(Coll[b2,b1]);
    INC(Coll[c1,c2]);INC(Coll[c2,c1]);INC(Coll[d1,d2]);INC(Coll[d2,d1]);
    INC(Coll[e1,e2]);INC(Coll[e2,e1]);INC(Coll[f1,f2]);INC(Coll[f2,f1]);
    INC(Coll[g1,g2]);INC(Coll[g2,g1]);INC(Coll[h1,h2]);INC(Coll[h2,h1]);

    CheckEight;
    a:=a1;b:=b1;c:=c1;d:=d1;e:=e1;f:=f1;g:=g1;h:=h1;
    CheckEight;
  END;

  FOR i:=0 TO NCol DO
    FOR j:=0 TO NCol DO C1[i]:=C1[i]+Coll[i,j] END;
    C1[i]:=C1[i]-Coll[i,i];
  END;

END CollCheck3;


PROCEDURE CollCheck4;
VAR u   : ARRAY[0..31] OF BOOLEAN;
    co   : ARRAY[1..8] OF INTEGER;
    i,j,i1,j1,z : INTEGER;

BEGIN
  FOR i:=0 TO 31 DO u[i]:=TRUE END;
  FOR i:=x0 TO x1-8 BY 8  DO
    FOR j:=y0 TO y1-1 DO
      a:=ReadPixel(rp1,i,j);
      b:=ReadPixel(rp1,i+1,j);
      c:=ReadPixel(rp1,i+2,j);
      d:=ReadPixel(rp1,i+3,j);
      e:=ReadPixel(rp1,i+4,j);
      f:=ReadPixel(rp1,i+5,j);
      g:=ReadPixel(rp1,i+6,j);
      h:=ReadPixel(rp1,i+7,j);

      z:=1;
      co[1]:=a;u[a]:=FALSE;
      IF u[b] THEN INC(z);co[z]:=b;u[b]:=FALSE END;
      IF u[c] THEN INC(z);co[z]:=c;u[c]:=FALSE END;
      IF u[d] THEN INC(z);co[z]:=d;u[d]:=FALSE END;
      IF u[e] THEN INC(z);co[z]:=e;u[e]:=FALSE END;
      IF u[f] THEN INC(z);co[z]:=f;u[f]:=FALSE END;
      IF u[g] THEN INC(z);co[z]:=g;u[g]:=FALSE END;
      IF u[h] THEN INC(z);co[z]:=h;u[h]:=FALSE END;

      FOR i1:=1 TO z DO
        FOR j1:=1 TO z DO INC(Coll[co[i1],co[j1]]) END;
      END;

      u[a]:=TRUE;u[b]:=TRUE;u[c]:=TRUE;u[d]:=TRUE;
      u[e]:=TRUE;u[f]:=TRUE;u[g]:=TRUE;u[h]:=TRUE;

    END;
  END;

  FOR i:=0 TO NCol DO
    FOR j:=0 TO NCol DO C1[i]:=C1[i]+Coll[i,j] END;
    C1[i]:=C1[i]-Coll[i,i];
  END;

END CollCheck4;


PROCEDURE CollSort;
VAR i,j,k,jmax : INTEGER;
    zt,max : LONGINT;
BEGIN
  i:=0;
  FOR k:=1 TO NCol DO
    LOOP
      max:=0;jmax:=0;
      FOR j:=1 TO NCol DO
        IF use[j] AND (i#j) THEN
          zt:=0;
          IF Modus>3 THEN FOR i1:=0 TO k-1 DO INC(zt,Coll[opt[i1],j]) END;
                     ELSE zt := Coll[i,j];
          END;
          IF zt>max THEN max:=zt;jmax:=j END;
        END;
      END;
      IF max>0 THEN use[jmax]:=FALSE;opt[k]:=jmax;EXIT END;

      max:=0;jmax:=0;
      FOR j:=1 TO NCol DO
        IF use[j] AND (i#j) THEN
          IF C1[j]>max THEN max:=C1[j];jmax:=j END;
        END;
      END;
      IF max>0 THEN use[jmax]:=FALSE;opt[k]:=jmax;EXIT END;

      jmax:=0;
      FOR j:=1 TO NCol DO
        IF use[j] AND(i#j) THEN jmax:=j END;
      END;
      IF jmax>0 THEN use[jmax]:=FALSE;opt[k]:=jmax;EXIT END;

      Assert(FALSE,ADR("Internal Error 1 !"));

    END;
    i:=jmax;
  END;
END CollSort;


PROCEDURE NeuePalette;
VAR pal1 : ARRAY[0..31] OF INTEGER;
    pal2 : ARRAY[0..31] OF INTEGER;
    set : ARRAY[0..31] OF INTEGER;
    i,j : INTEGER;
    k : LONGINT;
    dummy : BOOLEAN;
BEGIN
  FOR i:=0 TO 31 DO pal1[i]:=ci.Colors[i] END;
  FOR i:=0 TO NCol DO set[opt[i]]:=seq[i] END;
  FOR i:=0 TO NCol DO pal2[set[i]]:=pal1[i];druck[set[i]]:=i END;

  IF na=3 THEN
    WriteString("New color - sequence :");WriteLn;
    FOR i:=0 TO NCol DO
      WriteInt(druck[i],3);IF i=15 THEN WriteLn END;
    END;WriteLn;IF NCol#15 THEN WriteLn END;
  END;

  (* Make sure, that no Colors are lost : *)

  FOR i:=0 TO NCol DO
    IF (set[i]<0) OR (set[i]>NCol) THEN
      Assert(FALSE,ADR("Internal Error 2 !"));
    END;
  END;

  FOR i:=0 TO NCol-1 DO
    FOR j:=i+1 TO NCol DO
      IF set[i]=set[j] THEN Assert(FALSE,ADR("Internal Error 3 !")) END;
    END;
  END;

  LoadRGB4(ADR(sp1^.viewPort),ADR(pal2),32);
  FOR i:=x0 TO x1-1 DO
    FOR j:=y0 TO y1-1 DO
      (* $Z- *)
      k:=ReadPixel(rp1,i,j);
      (* $Z+ *)
      SetAPen(rp1,set[k]);
      (* $Z- *)
      dummy := WritePixel(rp1,i,j);
      (* $Z+ *)
    END;
  END;
END NeuePalette;


PROCEDURE TempSave;
BEGIN
  NeuePalette;
  length:=SaveScreen("CPicTemp",sp1);
  Assert(length#0,ADR("Couldn't save TempFile !"));
  WriteInt(Modus,2);WriteString(" :");
  FOR i:=0 TO ci.Depth-1 DO WriteInt(ci.Length[i],6) END;
  WriteString("  : ");WriteInt(length,7);WriteLn;
  CloseScreen(sp1);sp1:=NIL;
  IF length<Min THEN
    fl2:=0; FOR i:=0 TO ci.Depth-1 DO INC(fl2,ci.Length[i]) END;
    Min:=length;
    err:=DeleteFile(ADR(Name2));
    err:=Rename(ADR("CPicTemp"),ADR(Name2));
    Assert(err,ADR("Couldn't rename TempFile"));
  END;
END TempSave;

BEGIN

TermProcedure(CleanUp);

nc[1]:=2;nc[2]:=4;nc[3]:=8;nc[4]:=16;nc[5]:=32;

seq[0]:=0;seq[1]:=1;seq[2]:=3;seq[3]:=2;
seq[4]:=6;seq[5]:=7;seq[6]:=5;seq[7]:=4;
seq[8]:=12;seq[9]:=13;seq[10]:=15;seq[11]:=14;
seq[12]:=10;seq[13]:=11;seq[14]:=9;seq[15]:=8;
seq[16]:=24;seq[17]:=25;seq[18]:=27;seq[19]:=26;
seq[20]:=30;seq[21]:=31;seq[22]:=29;seq[23]:=28;
seq[24]:=20;seq[25]:=21;seq[26]:=23;seq[27]:=22;
seq[28]:=18;seq[29]:=19;seq[30]:=17;seq[31]:=16;

FOR i:=1 TO 31 DO use[i]:=TRUE END;use[0]:=FALSE;opt[0]:=0;

na:=NumArgs();success:=FALSE;
IF (na<2) OR (na>3)  THEN
  WriteLn;
  WriteString("Palette V 2.0  2.8.1990   by  Thomas Zipproth");
  WriteLn;WriteLn;
  WriteString("Usage : Palette <inputfile> <outputfile> [mode]");
  WriteLn;WriteLn;
  WriteString("inputfile  : a CPic - Picture File");WriteLn;
  WriteString("outputfile : name of the improved CPic - File");WriteLn;
  WriteString("mode       : a number from 0 to 7 (optional)");
  WriteLn;WriteLn;
  WriteString("This Tool changes the sequence of colors in a CPic - File");
  WriteLn;
  WriteString("in 8 different ways to improve the result of Crunching");
  WriteLn;
  WriteString("With two arguments all 8 modes are tried and the best");
  WriteLn;
  WriteString("result will be saved. In this case Current Directory");
  WriteLn;
  WriteString("and all Files must be in RAM: or RAD: !");
  WriteLn;WriteLn;
ELSIF na=2 THEN
  GetArg(1,Name,len);
  GetArg(2,Name2,len2);

  IF len=len2 THEN
    LOOP
      FOR i:=0 TO len-1 DO
        IF Name[i] # Name2[i] THEN EXIT END;
      END;
      Assert(FALSE,ADR("Names must be different"));
    END;
  END;
  Min:=2000000;
  Modus:=0; LoadCPic;
  Assert(ci.Depth<=5,ADR("Depth > 5 !"));
  FOR i:=0 TO ci.Depth-1 DO INC(fl1,ci.Length[i]) END;
  CollCheck1; CollSort; TempSave;

  Modus:=4; LoadCPic;
  ResetCollSort; CollSort; TempSave;

  Modus:=1; ResetAll; LoadCPic;
  CollCheck2; CollSort; TempSave;

  Modus:=5; LoadCPic;
  ResetCollSort; CollSort; TempSave;

  Modus:=2; ResetAll; LoadCPic;
  CollCheck3; CollSort; TempSave;

  Modus:=6; LoadCPic;
  ResetCollSort; CollSort; TempSave;

  Modus:=3; ResetAll; LoadCPic;
  CollCheck4; CollSort; TempSave;

  Modus:=7; LoadCPic;
  ResetCollSort; CollSort; TempSave;

  err:=DeleteFile(ADR("CPicTemp")); success := TRUE;
ELSE
  LOOP
    GetArg(1,Name,len);
    GetArg(2,Name2,len);
    GetArg(3,Zahl,len);
    StrToInt(Zahl,Modus);
    IF (Modus<0) OR (Modus>7) THEN
      WriteString("Wrong mode"); WriteLn;WriteLn; EXIT
    END;
    IF NOT LoadCPicScreen(Name,sp1,0,0,FALSE) THEN
      IF Cle = 10 THEN
        WriteString("Couldn't open File !");
      ELSIF Cle = 11 THEN
        WriteString("File is not a CPic - File !");
      ELSE
        WriteString("Couldn't load Picture !");
      END;
      WriteLn;WriteLn;EXIT;
    END;
    IF ci.Depth>5 THEN
      WriteString("Depth > 5 !"); WriteLn;WriteLn; EXIT;
    END;
    FOR i:=0 TO ci.Depth-1 DO INC(fl1,ci.Length[i]) END;
    rp1  := ADR(sp1^.rastPort);
    NCol := nc[ci.Depth]-1;
    x0 := ci.PicX0*8;
    y0 := ci.PicY0;
    x1 := x0+ci.PicX*8;
    y1 := y0+ci.PicY;

    WriteLn;WriteString("Screen : ");
    WriteInt(ci.Width,5);WriteString(" *");
    WriteInt(ci.Height,4);WriteString(" *");
    WriteInt(ci.Depth,2);WriteLn;
    WriteString("CPic   :  (");
    WriteInt(ci.PicX0,3);
    WriteInt(ci.PicY0,5);
    WriteString(" )");
    WriteInt(ci.PicX,6);
    WriteString("  *");
    WriteInt(ci.PicY,5);WriteLn;WriteLn;

    IF ((Modus=0) OR (Modus=4)) THEN CollCheck1
      ELSIF ((Modus=1) OR (Modus=5)) THEN CollCheck2
      ELSIF ((Modus=2) OR (Modus=6)) THEN CollCheck3
      ELSIF ((Modus=3) OR (Modus=7)) THEN CollCheck4
    END;
    CollSort;
    NeuePalette;
    length:=SaveScreen(Name2,sp1);
    IF length=0 THEN
      WriteString("Couldn't save Picture !"); WriteLn;WriteLn;EXIT;
    END;
    FOR i:=0 TO ci.Depth-1 DO INC(fl2,ci.Length[i]) END;
    success:=TRUE;EXIT;
  END;
END;
IF success THEN
  WriteString("Improvement : "); WriteInt(fl1-fl2,5);
  WriteString("  Byte");WriteLn;WriteLn;
END;
END Palette.