{******************************************************************************}
{                 FRAKTÁLNÍ KOMPRESE - DEKOMPRESE OBRAZU                       }
{                         TOMÁŠ GRÍSA 2010-2011                                }
{                       PROGRAM K BAKALÁŘSKÉ PRÁCI                             }
{******************************************************************************}

unit FractalImageCompression;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Math;

{******************************************************************************}
{                              DEKLARACE TYPU                                  }
{******************************************************************************}
type
  KRecord = record
    RaSize:Word;
    XR:Word;
    YR:Word;
    XT:Word;
    YT:Word;
    Transf:Byte;
    ST:Single;
    OT:Single;
  end;
  DKMatrix   = array of KRecord;
  DIMatrix = array of array of Byte;

{******************************************************************************}
{                       DEKLARACE GLOBÁLNÍCH PROMĚNNÝCH                        }
{******************************************************************************}
var

  InputImageMatrix_R, InputImageMatrix_G, InputImageMatrix_B, OutputImageMatrix,
  MemoryOutputImageMatrix_R, MemoryOutputImageMatrix_G,
  MemoryOutputImageMatrix_B: DIMatrix;                            //Dynamicke matice obrazku
  KompresMatrix_R, KompresMatrix_G, KompresMatrix_B: DKMatrix;    //Dynamicka matice pro kompr. data
  Progres, PProgres : LongInt;                                    //Vypocet prubehu
  BW: Boolean;
  TextOutput: TextFile;                    //Textovy soubor pro log                                                     //B-W?

  function DoRange(a,b,InRSize: Integer; var IM: DIMatrix):DIMatrix;
  function ResizeDomain(XIn,YIn,InRSize: Integer; var IM: DIMatrix):DIMatrix;
  function ACount(var DomainIn: DIMatrix):Single;
  function AACount(var DomainIn: DIMatrix):Single;
  function ABCount(var RangeIn,DomainIn: DIMatrix):Single;
  function BCount(var RangeIn: DIMatrix):Single;
  function BBCount(var RangeIn: DIMatrix):Single;
  function TransformDomain(var DomainIn: DIMatrix; IIn: Byte):DIMatrix;
  procedure DekompresDo(var KompresMatrixIn: DKMatrix; var MemoryOutputImageMatrix:DIMatrix; Scale, maxit:Integer);
  procedure ReKomp(var InputMatrix:DIMatrix;var KompresMatrix:DKMatrix;Step:Word;MinStep,MaxStep,X,Y: Word;Lib:Byte;RGB:Byte);

implementation
uses kompres_window, dekompres_window;

{******************************************************************************}
{                                 FUNKCE                                       }//FUNKCE
{******************************************************************************}
 {***************************************************************************LOG}
procedure Log(var KompresMatrix:DKMatrix;k:Integer; PProgres:LongInt; RMin:Single; RGB:Byte);
begin
  AssignFile(TextOutput, PathLog);
  try
    Append(TextOutput);
    if RGB=1 then
    Write(TextOutput, 'RED:    ');
    if RGB=2 then
    Write(TextOutput, 'GREEN:  ');
    if RGB=3 then
    Write(TextOutput, 'BLUE:   ');
    Write(TextOutput, PProgres);Write(TextOutput, '%');
    Write(TextOutput, '   RMS:');
    Write(TextOutput, RMin);
    Write(TextOutput, ';   Range Size:');
    Write(TextOutput, KompresMatrix[k].RaSize);
    Write(TextOutput, ';   X of Range:');
    Write(TextOutput, KompresMatrix[k].XR);
    Write(TextOutput, ';   Y of Range:');
    Write(TextOutput, KompresMatrix[k].YR);
    Write(TextOutput, ';   X of Domain:');
    Write(TextOutput, KompresMatrix[k].XT);
    Write(TextOutput, ';   Y of Domain:');
    Write(TextOutput, KompresMatrix[k].YT);
    Write(TextOutput, ';   Number of tranf.:');
    Write(TextOutput, KompresMatrix[k].Transf);
    Write(TextOutput, ';   S:');
    Write(TextOutput, KompresMatrix[k].ST);
    Write(TextOutput, ';   O:');
    Write(TextOutput, KompresMatrix[k].OT);
    Writeln(TextOutput, '  ');
  finally
    CloseFile(TextOutput);
  end;
end;
{***********************************************************************DORANGE}
function DoRange(a,b,InRSize: Integer; var IM: DIMatrix):DIMatrix;
var
  c,d: Integer;
begin
  SetLength(DoRange, InRSize);
  for c:= 0 to InRSize-1 do
    SetLength(DoRange[c],InRSize);
  for c:= 0 to InRSize-1 do
  begin
    for d:= 0 to InRSize-1 do
    begin
      DoRange[c,d]:=IM[(a*InRSize)+c,(b*InRSize)+d];
    end;
  end;
end;
{*******************************************************************RESIZDOMAIN}
function ResizeDomain(XIn,YIn,InRSize: Integer; var IM: DIMatrix):DIMatrix;
var
  a,b: Integer;
begin
  SetLength(ResizeDomain, InRSize);
  for a:= 0 to InRSize-1 do
    SetLength(ResizeDomain[a],InRSize);
  for a:= 0 to InRSize-1 do
  begin
    for b:= 0 to InRSize-1 do
    begin
      ResizeDomain[a,b]:=(
                       (IM[XIn+(2*a)+1,YIn+(2*b)])   +
                       (IM[XIn+(2*a)  ,YIn+(2*b)])   +
                       (IM[XIn+(2*a)  ,YIn+(2*b)+1]) +
                       (IM[XIn+(2*a)+1,YIn+(2*b)+1])
                       ) div 4;
    end;
  end;
end;
{***************************************************************************RMS}
function RMS(var RangeIn: DIMatrix; SIn,OIn,A,AA,AB,B,BB: Single):Single;
var InRSize: Integer;
begin
  InRSize:=High(RangeIn)+1;
  RMS:=((BB + (SIn*((SIn*AA) - (2*AB) + (2*OIn*A))) +
        (OIn*((OIn*InRSize*InRSize) - (2*B))))/(InRSize*InRSize));
end;
{************************************************************************ACOUNT}
function ACount(var DomainIn: DIMatrix):Single;
var MemSum: Single;
    a,b,InRSize: Integer;
begin
  MemSum:=0;
  InRSize:=High(DomainIn)+1;
  for a:= 0 to InRSize-1 do
  begin
    for b:= 0 to InRSize-1 do
    begin
      MemSum:=MemSum+(DomainIn[a,b]);
    end;
  end;
  ACount:=MemSum;
end;
{***********************************************************************AACOUNT}
function AACount(var DomainIn: DIMatrix):Single;
var MemSum: Single;
    a,b,InRSize: Integer;
begin
  MemSum:=0;
  InRSize:=High(DomainIn)+1;
  for a:= 0 to InRSize-1 do
  begin
    for b:= 0 to InRSize-1 do
    begin
      MemSum:=MemSum+(DomainIn[a,b]*DomainIn[a,b]);
    end;
  end;
  AACount:=MemSum;
end;
{************************************************************************BCOUNT}
function BCount(var RangeIn: DIMatrix):Single;
var MemSum: Single;
    a,b,InRSize: Integer;
begin
  MemSum:=0;
  InRSize:=High(RangeIn)+1;
  for a:= 0 to InRSize-1 do
  begin
    for b:= 0 to InRSize-1 do
    begin
      MemSum:=MemSum+RangeIn[a,b];
    end;
  end;
  BCount:=MemSum;
end;
{***********************************************************************BBCOUNT}
function BBCount(var RangeIn: DIMatrix):Single;
var MemSum: Single;
    a,b,InRSize: Integer;
begin
  MemSum:=0;
  InRSize:=High(RangeIn)+1;
  for a:= 0 to InRSize-1 do
  begin
    for b:= 0 to InRSize-1 do
    begin
      MemSum:=MemSum+(RangeIn[a,b]*RangeIn[a,b]);
    end;
  end;
  BBCount:=MemSum;
end;
{***********************************************************************ABCOUNT}
function ABCount(var RangeIn,DomainIn: DIMatrix):Single;
var MemSum: Single;
    a,b,InRSize: Integer;
begin
  MemSum:=0;
  InRSize:=High(RangeIn)+1;
  for a:= 0 to InRSize-1 do
  begin
    for b:= 0 to InRSize-1 do
    begin
      MemSum:=MemSum+(DomainIn[a,b]*RangeIn[a,b]);
    end;
  end;
  ABCount:=MemSum;
end;
{************************************************************************TCOUNT}
function TCount(var DomainIn: DIMatrix; var A,AA:Single):Single;
var InRSize: Integer;
begin
  InRSize:=High(DomainIn)+1;
  TCount:=((InRSize*InRSize*AA)-(A*A));
end;
{************************************************************************SCOUNT}
function SCount(var RangeIn: DIMatrix; TIn,A,AB,B: Single):Single;
var InRSize: Integer;
begin
  InRSize:=High(RangeIn)+1;
  SCount:=((InRSize*InRSize*AB)-(A*B))/TIn;
end;
{************************************************************************OCOUNT}
function OCount(var RangeIn: DIMatrix; SIn,A,B:Single):Single;
var InRSize : Integer;
begin
  InRSize:=High(RangeIn)+1;
  OCount:=(B-(SIn*A))/(InRSize*InRSize);
end;
{***************************************************************TRANSFORMDOMAIN}
function TransformDomain(var DomainIn: DIMatrix; IIn: Byte):DIMatrix;
var a,b,InRSize: Integer;
begin
  InRSize:=High(DomainIn);
  SetLength(TransformDomain, InRSize+1);
  for a:= 0 to InRSize do
    SetLength(TransformDomain[a],InRSize+1);
  case IIn of
    1 : begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[a,b];
        end;
    2 : begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[InRSize-a,b];
        end;
    3 : begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[a,InRSize-b];
        end;
    4 : begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[b,a];
        end;
    5 : begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[InRSize-b,InRSize-a];
        end;
    6 :begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[InRSize-b,a];
        end;
    7 :begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[InRSize-a,InRSize-b];
        end;
    8 :begin
          for a:= 0 to InRSize do
            for b:= 0 to InRSize do
              TransformDomain[a,b]:=DomainIn[b,InRSize-a];
        end;
  end;
end;

{******************************************************************************}
{                              PROCEDURY                                       }//PROCEDURY
{******************************************************************************}

{**************************************************************REKURZIVNIDELENI}
procedure ReKomp(var InputMatrix:DIMatrix;var KompresMatrix:DKMatrix;Step:Word;MinStep,MaxStep,X,Y: Word;Lib:Byte;RGB:Byte);
var
  m,Size,DomainsInLine,TransferX,TransferY,LSL: Word;
  i,j,k,l:Word;
  TransformMin:Byte;
  Range,Domain,DomainM: DIMatrix;
  R,RMin,S,SMin,O,OMin,T,A,AA,AB,B,BB: Single;
begin
  If Step < MinStep+1 then
  begin
    Size:=High(InputMatrix)+1;
    i:=Round(Power(2,Step));
    Size:=Size div i;
    ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X,Y,Lib,RGB);
    ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X+Size,Y,Lib,RGB);
    ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X,Y+Size,Lib,RGB);
    ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X+Size,Y+Size,Lib,RGB);
  end else

  begin
    Size:=High(InputMatrix)+1;
    i:=Round(Power(2,Step));
    Size:=Size div i;
    Size:=Size*2;
    SetLength(Range, Size);
    SetLength(Domain, Size);
    for i:= 0 to Size-1 do
    begin
      SetLength(Range[i], Size);
      SetLength(Domain[i], Size);
    end;

    for i:= 0 to High(Range) do
    begin
      for j:= 0 to High(Range) do
      begin
        Range[i,j]:=InputMatrix[X+i,Y+j];
      end;
    end;

    case Lib of
      1 : begin
            LSL:=LS;
          end;
      2 : begin
            LSL:=(2*High(Range)) div LS;
          end;
      3 : begin
            LSL:=LS div (2*High(Range));
            if LSL < 1 then LSL:=1;
          end;
    end;

    RMin:=30000; SMin:=0; OMin:=0; S:=0; O:=0;
    TransformMin:=0; TransferX:=0; TransferY:=0;
    DomainsInLine:=High(InputMatrix)+1-(2*Size)+1;
    B:=BCount(Range);
    BB:=BBCount(Range);
    k:=0;
    repeat
      l:=0;
      repeat
        DomainM:= ResizeDomain(k,l,High(Domain)+1,InputMatrix);
        A:=ACount(DomainM);
        AA:=AACount(DomainM);
        T:=TCount(DomainM,A,AA);

        for m:=1 to 8 do
        begin
          Domain:=TransformDomain(DomainM,m);
          AB:=ABCount(Range,Domain);
          If T=0 then S:=0 else  S:=SCount(Range,T,A,AB,B);
          O:=OCount(Range,S,A,B);
          R:=Sqrt(Abs(RMS(Range,S,O,A,AA,AB,B,BB)));
          If (R<RMin) and (R>=0) and (S>=0) then
          begin
            SMin:=S;
            RMin:=R;
            TransferX:=k;
            TransferY:=l;
            OMin:=O;
            TransformMin:=m;
          end;
          If RMin<=OD then break;
        end;
        l:=l+LSL;
      until (RMin<=OD) or (l>DomainsInLine-LSL);
      k:=k+LSL;
    until (RMin<=OD) or (k>DomainsInLine-LSL);
    if (RMin<=OD) or (Step>=MaxStep+1) then
    begin
      k:=High(KompresMatrix)+2;
      SetLength(KompresMatrix,k);
      with KompresMatrix[k-1] do
      begin
        RaSize:=Size;
        XR:=X;
        YR:=Y;
        XT:=TransferX;
        YT:=TransferY;
        Transf:=TransformMin;
        ST:=SMin;
        OT:=OMin;
      end;
      Progres:=Progres + (Size*Size);
      PProgres:=Round((Progres/((High(InputMatrix)+1)
                      *(High(InputMatrix)+1)))*100);
      Log(KompresMatrix,k-1,PProgres,RMin,RGB);
      Exit;
    end else
    begin
      ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X,Y,Lib,RGB);
      ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X+(Size div 2),Y,Lib,RGB);
      ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep, MaxStep,X,Y+(Size div 2),Lib,RGB);
      ReKomp(InputMatrix,KompresMatrix, Step+1, MinStep,
             MaxStep,X+(Size div 2),Y+(Size div 2),Lib,RGB);
    end;
  end;
end;
{*****************************************************************DEKOMPRESEDO}
procedure DekompresDo(var KompresMatrixIn: DKMatrix; var MemoryOutputImageMatrix:DIMatrix; Scale, maxit:Integer);
var
  i,m,j,k,l: LongInt;
  Range,Domain,MM: DIMatrix;
begin
  SetLength(OutputImageMatrix, (KompresMatrixIn[0].XT)*Scale);
  for i:=0 to ((KompresMatrixIn[0].XT)*Scale)-1 do
    SetLength(OutputImageMatrix[i], (KompresMatrixIn[0].XT)*Scale);

  SetLength(MM, KompresMatrixIn[0].XT*Scale);
  for i:= 0 to ((KompresMatrixIn[0].XT*Scale)-1) do
    SetLength(MM[i], KompresMatrixIn[0].XT*Scale);

  for m:= 0 to maxit do
  begin

  for i:=0 to High(MM) do
    for j:= 0 to High(MM) do
      MM[i,j]:=MemoryOutputImageMatrix[i,j];

  for i:= 1 to (High(KompresMatrixIn)) do
  begin
    SetLength(Range, (KompresMatrixIn[i].RaSize*Scale));
    SetLength(Domain, (KompresMatrixIn[i].RaSize*Scale));
    for j:= 0 to ((KompresMatrixIn[i].RaSize*Scale)-1) do
    begin
      SetLength(Range[j], (KompresMatrixIn[i].RaSize*Scale));
      SetLength(Domain[j], (KompresMatrixIn[i].RaSize*Scale));
    end;

      Domain:=ResizeDomain(KompresMatrixIn[i].XT*Scale,
                           KompresMatrixIn[i].YT*Scale,
                           KompresMatrixIn[i].RaSize*Scale,
                           MemoryOutputImageMatrix);
      Domain:=TransformDomain(Domain,KompresMatrixIn[i].Transf);

      for k:= 0 to (High(Range)) do
      begin
        for l:= 0 to (High(Range)) do
        begin
          MM[(KompresMatrixIn[i].XR*scale+k),(KompresMatrixIn[i].YR*scale+l)]:=
                        Min(Max(0,Round((Domain[k,l]*KompresMatrixIn[i].ST)
                        +KompresMatrixIn[i].OT)),255);
        end;
      end;
      Range:=nil;
      Domain:=nil;
  end;

  for i:=0 to High(MM) do
    for j:= 0 to High(MM) do
      MemoryOutputImageMatrix[i,j]:=MM[i,j];
  end;
end;

end.

