temskwk.pas

Do your applications look a little boring? Would you like to get spectacular yet easy to use visual

unit teMskWk;

interface

uses Classes, SysUtils, teRender,
  {$ifdef CLX}
  QGraphics;
  {$else}
  Windows, Graphics;
  {$endif CLX}

{$ifndef TE_NOHLP}
type
  TApply256MaskSProc = function(Work, Dst, Src, Mask: Pointer; Size,
    UpdateRowLenght, Gap: Longint): PByteArray;
  TApply256BmpMaskSProc = function(Work, Dst, Src, Mask: Pointer;
    Size, UpdateRowLenght, Gap, Dif: Longint): PByteArray;

  // General use routines
  function CreateGrayScalePalette: HPALETTE;

  // 1bpp mask routines
  procedure Apply1bppMask(Work, Dst, Mask: Pointer;
    MaskWidth, ScanLineSize, MaskScanLineSize: Integer;
    PixelFormat: TPixelFormat; UpdateRect, UnUpdateRect: TRect);
  procedure DoMaskOptimization(Mask1, Mask2: TBitmap; ScanLineSize: Integer;
    UpdateRect, UnUpdateRect: TRect);
  procedure InvertMask(Mask: PDWordArray; k: Longint);

  // 8bpp mask routines
  function  GetApply256MaskSProc: PByteArray;
  procedure Apply256MaskS(Apply256MaskSProc: TApply256MaskSProc;
    Work, Dst, Src, Mask: Pointer;
    ScanLineSize, MaskScanLineSize, Width, Height: Integer;
    UpdateRect, UnUpdateRect: TRect);
  procedure Apply256Mask(Work, Dst, Mask: Pointer;
    MaskSize, LoValue, HiValue: Longint; PixelFormat: TPixelFormat);
  function  GetApply256BmpMaskSProc(Levels: Integer; Add: Boolean): PByteArray;
  procedure Apply256BmpMaskS(
    Apply256BmpMaskSSubProc, Apply256BmpMaskSAddProc: TApply256BmpMaskSProc;
    Work, Dst, Src, Mask: Pointer;
    ScanLineSize, MaskScanLineSize, Width, Height, Dif: Integer;
    UpdateRect, UnUpdateRect: TRect);
  procedure DoDecMask1(Mask: Pointer; ScanLineSize, Width, DecValue: Longint;
    DecAll:Boolean; UpdateRect, UnUpdateRect: TRect);
  procedure DoDecMask2(Mask1, Mask2: Pointer;
    ScanLineSize, Width, DecValue: Longint; DecAll:Boolean;
    UpdateRect, UnUpdateRect: TRect);

type
  TTEUpdParams = record
    Start1,           // Bytes from end
    RowLenght1,       // Pixels to work in a row
    Gap1,             // Pixels to bypass from row to row
    Lenght1,          // Total pixels from start to end
    Start2,           // Bytes from end
    RowLenght2,       // Pixels to work in a row
    Gap2,             // Pixels to bypass from row to row
    Lenght2,          // Total pixels from start to end
    Start3,           // Bytes from end
    RowLenght3,       // Pixels to work in a row
    Gap3,             // Pixels to bypass from row to row
    Lenght3,          // Total pixels from start to end
    Start4,           // Bytes from end
    RowLenght4,       // Pixels to work in a row
    Gap4,             // Pixels to bypass from row to row
    Lenght4: Longint; // Total pixels from start to end
  end;

  function GiveMeTheUpdMode(Width, MinGapPercentage, PixelGrain: Longint;
    var UpdateRect, UnUpdateRect: TRect; PixelFormat: TPixelFormat): Byte;
  procedure GiveMeTheUpdParams(Mode: Byte; var UpdParams: TTEUpdParams;
    ScanLineSize: Longint; UpdateRect, UnUpdateRect: TRect;
    PixelFormat: TPixelFormat);

{$endif TE_NOHLP}

implementation

uses teBlndWk
  {$ifdef D6}
  , Types, Windows
  {$endif D6}
  ;

// General use routines

function CreateGrayScalePalette: HPALETTE;
var
  Pal: TMaxLogPalette;
  i: Integer;
begin
  Pal.palVersion := $300;
  Pal.palNumEntries := 256;
  for i:=0 to 255 do
  begin
    with Pal.palPalEntry[i] do
    begin
      peRed   := i;
      peGreen := i;
      peBlue  := i;
      peFlags  := 0;
    end;
  end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

// 1 bit mask routines

procedure Apply1bppMask_2_32Rect(Work2, Dst2, Mask2: Pointer;
  i, UpdateRowLenght, UpdateGap: Longint);
var
  Work,
  Dst: PDWordArray;
  Mask: PByteArray;
  k,
  UpdateGapMask,
  UpdRowLenMask,
  Limit: Longint;
begin
  k             := i               div 8;
  UpdateGapMask := UpdateGap       div 8;
  UpdRowLenMask := UpdateRowLenght div 8;
  Work          := Work2;
  Dst           := Dst2;
  Mask          := Mask2;

  while k < 0 do
  begin
    Limit := k + UpdRowLenMask;
    while k < Limit do
    begin
      if Mask[k] <> $FF then
      begin
        if(Mask[k] or $7F) = $7F then
          Work[i  ] := Dst[i  ];
        if(Mask[k] or $BF) = $BF then
          Work[i+1] := Dst[i+1];
        if(Mask[k] or $DF) = $DF then
          Work[i+2] := Dst[i+2];
        if(Mask[k] or $EF) = $EF then
          Work[i+3] := Dst[i+3];
        if(Mask[k] or $F7) = $F7 then
          Work[i+4] := Dst[i+4];
        if(Mask[k] or $FB) = $FB then
          Work[i+5] := Dst[i+5];
        if(Mask[k] or $FD) = $FD then
          Work[i+6] := Dst[i+6];
        if(Mask[k] or $FE) = $FE then
          Work[i+7] := Dst[i+7];
      end;
      Inc(k);
      Inc(i, 8);
    end;
    Inc(k, UpdateGapMask);
    Inc(i, UpdateGap);
  end;
end;

procedure Apply1bppMask_2_24Rect(Work2, Dst2, Mask2: Pointer;
  j, UpdateRowLenght, UpdateGap: Longint);
var
  Work,
  Dst,
  Mask: PByteArray;
  i,
  k,
  Limit,
  UpdRowLenMask,
  UpdateGapMask,
  UpdateGapBmp: Longint;
begin
  k             := j               div 8;
  UpdateGapMask := UpdateGap       div 8;
  UpdRowLenMask := UpdateRowLenght div 8;
  i             := j         * 3;
  UpdateGapBmp  := UpdateGap * 3;
  Work          := Work2;
  Dst           := Dst2;
  Mask          := Mask2;

  while k < 0 do
  begin
    Limit := k + UpdRowLenMask;
    while k < Limit do
    begin
      if Mask[k] <> $FF then
      begin
        if Mask[k] or $7F = $7F then
        begin
          Work[i   ] := Dst[i   ];
          Work[i+ 1] := Dst[i+ 1];
          Work[i+ 2] := Dst[i+ 2];
        end;
        if Mask[k] or $BF = $BF then
        begin
          Work[i+ 3] := Dst[i+ 3];
          Work[i+ 4] := Dst[i+ 4];
          Work[i+ 5] := Dst[i+ 5];
        end;
        if Mask[k] or $DF = $DF then
        begin
          Work[i+ 6] := Dst[i+ 6];
          Work[i+ 7] := Dst[i+ 7];
          Work[i+ 8] := Dst[i+ 8];
        end;
        if Mask[k] or $EF = $EF then
        begin
          Work[i+ 9] := Dst[i+ 9];
          Work[i+10] := Dst[i+10];
          Work[i+11] := Dst[i+11];
        end;
        if Mask[k] or $F7 = $F7 then
        begin
          Work[i+12] := Dst[i+12];
          Work[i+13] := Dst[i+13];
          Work[i+14] := Dst[i+14];
        end;
        if Mask[k] or $FB = $FB then
        begin
          Work[i+15] := Dst[i+15];
          Work[i+16] := Dst[i+16];
          Work[i+17] := Dst[i+17];
        end;
        if Mask[k] or $FD = $FD then
        begin
          Work[i+18] := Dst[i+18];
          Work[i+19] := Dst[i+19];
          Work[i+20] := Dst[i+20];
        end;
        if Mask[k] or $FE = $FE then
        begin
          Work[i+21] := Dst[i+21];
          Work[i+22] := Dst[i+22];
          Work[i+23] := Dst[i+23];
        end;
      end;
      Inc(k);
      Inc(i, 24);
    end;
    Inc(k, UpdateGapMask);
    Inc(i, UpdateGapBmp);
  end;
end;

procedure Apply1bppMask_2_16Rect(Work2, Dst2, Mask2: Pointer;
  i, UpdateRowLenght, UpdateGap: Longint);
var
  Work,
  Dst: PWordArray;
  Mask: PByteArray;
  k,
  UpdateGapMask,
  UpdRowLenMask,
  Limit: Longint;
begin
  k             := i               div 8;
  UpdateGapMask := UpdateGap       div 8;
  UpdRowLenMask := UpdateRowLenght div 8;
  Work          := Work2;
  Dst           := Dst2;
  Mask          := Mask2;

  while k < 0 do
  begin
    Limit := k + UpdRowLenMask;
    while k < Limit do
    begin
      if Mask[k] <> $FF then
      begin
        if(Mask[k] or $7F) = $7F then Work[i  ] := Dst[i  ];
        if(Mask[k] or $BF) = $BF then Work[i+1] := Dst[i+1];
        if(Mask[k] or $DF) = $DF then Work[i+2] := Dst[i+2];
        if(Mask[k] or $EF) = $EF then Work[i+3] := Dst[i+3];
        if(Mask[k] or $F7) = $F7 then Work[i+4] := Dst[i+4];
        if(Mask[k] or $FB) = $FB then Work[i+5] := Dst[i+5];
        if(Mask[k] or $FD) = $FD then Work[i+6] := Dst[i+6];
        if(Mask[k] or $FE) = $FE then Work[i+7] := Dst[i+7];
      end;
      Inc(k);
      Inc(i, 8);
    end;
    Inc(k, UpdateGapMask);
    Inc(i, UpdateGap);
  end;
end;

procedure Apply1bppMask_2_8Rect(Work2, Dst2, Mask2: Pointer;
  i, UpdateRowLenght, UpdateGap: Longint);
var
  Work,
  Dst,
  Mask: PByteArray;
  k,
  UpdateGapMask,
  UpdRowLenMask,
  Limit: Longint;
begin
  k             := i               div 8;
  UpdateGapMask := UpdateGap       div 8;
  UpdRowLenMask := UpdateRowLenght div 8;
  Work          := Work2;
  Dst           := Dst2;
  Mask          := Mask2;

  while k < 0 do
  begin
    Limit := k + UpdRowLenMask;
    while k < Limit do
    begin
      if Mask[k] <> $FF then
      begin
        if(Mask[k] or $7F) = $7F then Work[i  ] := Dst[i  ];
        if(Mask[k] or $BF) = $BF then Work[i+1] := Dst[i+1];
        if(Mask[k] or $DF) = $DF then Work[i+2] := Dst[i+2];
        if(Mask[k] or $EF) = $EF then Work[i+3] := Dst[i+3];
        if(Mask[k] or $F7) = $F7 then Work[i+4] := Dst[i+4];
        if(Mask[k] or $FB) = $FB then Work[i+5] := Dst[i+5];
        if(Mask[k] or $FD) = $FD then Work[i+6] := Dst[i+6];
        if(Mask[k] or $FE) = $FE then Work[i+7] := Dst[i+7];
      end;
      Inc(k);
      Inc(i, 8);
    end;
    Inc(k, UpdateGapMask);
    Inc(i, UpdateGap);
  end;
end;

procedure Apply1bppMask_2_4Rect(Work2, Dst2, Mask2: Pointer;
  j, UpdateRowLenght, UpdateGap: Longint);
var
  Work,
  Dst,
  Mask: PByteArray;
  i,
  k,
  UpdateGapMask,
  UpdateGapBmp,
  UpdRowLenMask,
  Limit: Longint;
begin
  k             := j               div 8;
  UpdateGapMask := UpdateGap       div 8;
  UpdRowLenMask := UpdateRowLenght div 8;
  UpdateGapBmp  := UpdateGap       div 2;
  i             := j               div 2;
  Work          := Work2;
  Dst           := Dst2;
  Mask          := Mask2;

  while k < 0 do
  begin
    Limit := k + UpdRowLenMask;
    while k < Limit do
    begin
      if Mask[k] <> $FF then
      begin
        if Mask[k] or $3F <> $FF then
        begin
          if Mask[k] or $3F = $3F
          then Work[i  ] := Dst[i  ]
          else if Mask[k] or $7F = $7F
          then Work[i  ] := (Dst[i  ] or $0F) and (Work[i  ] or $F0)
          else Work[i  ] := (Dst[i  ] or $F0) and (Work[i  ] or $0F);
        end;
        if Mask[k] or $CF <> $FF then
        begin
          if Mask[k] or $CF = $CF
          then Work[i+1] := Dst[i+1]
          else if Mask[k] or $DF = $DF
          then Work[i+1] := (Dst[i+1] or $0F) and (Work[i+1] or $F0)
          else Work[i+1] := (Dst[i+1] or $F0) and (Work[i+1] or $0F);
        end;
        if Mask[k] or $F3 <> $FF then
        begin
          if Mask[k] or $F3 = $F3
          then Work[i+2] := Dst[i+2]
          else if Mask[k] or $F7 = $F7
          then Work[i+2] := (Dst[i+2] or $0F) and (Work[i+2] or $F0)
          else Work[i+2] := (Dst[i+2] or $F0) and (Work[i+2] or $0F);
        end;
        if Mask[k] or $FC <> $FF then
        begin
          if Mask[k] or $FC = $FC
          then Work[i+3] := Dst[i+3]
          else if Mask[k] or $FD = $FD
          then Work[i+3] := (Dst[i+3] or $0F) and (Work[i+3] or $F0)
          else Work[i+3] := (Dst[i+3] or $F0) and (Work[i+3] or $0F);
        end;
      end;
      Inc(k);
      Inc(i, 4);
    end;
    Inc(k, UpdateGapMask);
    Inc(i, UpdateGapBmp);
  end;
end;

procedure Apply1bppMask(Work, Dst, Mask: Pointer;
  MaskWidth, ScanLineSize, MaskScanLineSize: Integer;
  PixelFormat: TPixelFormat; UpdateRect, UnUpdateRect: TRect);
type
  TApply1bppMask_2 = procedure(Work, Dst, Mask: Pointer;
    i, UpdateRowLenght, UpdateGap: Longint);
var
  Apply1bppMask_2: TApply1bppMask_2;
//  PixelGrain,
  Mode: Longint;
  UpdParBmp,
  UpdParMsk: TTEUpdParams;
begin
  Mode := GiveMeTheUpdMode(MaskWidth, 0, 8{PixelGrain}, UpdateRect,
    UnUpdateRect, pf1bit);
  GiveMeTheUpdParams(Mode, UpdParBmp, ScanLineSize    , UpdateRect,
    UnUpdateRect, PixelFormat);
  GiveMeTheUpdParams(Mode, UpdParMsk, MaskScanLineSize, UpdateRect,
    UnUpdateRect, pf1bit);

  Apply1bppMask_2 := nil;
  case PixelFormat of
    pf4bit : Apply1bppMask_2 := Apply1bppMask_2_4Rect;
    pf8bit : Apply1bppMask_2 := Apply1bppMask_2_8Rect;
    pf15bit,
    pf16bit: Apply1bppMask_2 := Apply1bppMask_2_16Rect;
    pf24bit: Apply1bppMask_2 := Apply1bppMask_2_24Rect;
    pf32bit: Apply1bppMask_2 := Apply1bppMask_2_32Rect;
  end;

  if Assigned(Apply1bppMask_2) then
  begin
    case Mode of
      1,