kolmck/Addons/Objects.pas

unit objects;

interface

uses
  KOL, Windows, Messages;

type
  TWndMethod = procedure(var Message: TMessage) of object;

function MakeObjectInstance(Method: TWndMethod): Pointer;
procedure FreeObjectInstance(ObjectInstance: Pointer);
function AllocateHWnd(Method: TWndMethod): HWND;
procedure DeallocateHWnd(Wnd: HWND);
function  IncColor(C: TColor; D: integer): TColor;
procedure AjustBitmap(const M: KOL.PBitmap; S, C: TColor);

implementation

type
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: PObjectInstance);
      1: (Method: TWndMethod);
  end;

type
  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next: PInstanceBlock;
    Code: array[1..2] of Byte;
    WndProcPtr: Pointer;
    Instances: array[0..100] of TObjectInstance;
  end;

var
  InstBlockList: PInstanceBlock;
  InstBlockCount: integer;
  InstFreeList: PObjectInstance;

{ Standard window procedure }
{ In    ECX = Address of method pointer }
{ Out   EAX = Result }

function StdWndProc(Window: HWND; Message, WParam: Longint;
  LParam: Longint): Longint; stdcall; assembler;
asm
        XOR     EAX,EAX
        PUSH    EAX
        PUSH    LParam
        PUSH    WParam
        PUSH    Message
        MOV     EDX,ESP
        MOV     EAX,[ECX].Longint[4]
        CALL    [ECX].Pointer
        ADD     ESP,12
        POP     EAX
end;

{ Allocate an object instance }

function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
  Result := Longint(Dest) - (Longint(Src) + 5);
end;

function MakeObjectInstance(Method: TWndMethod): Pointer;
const
  BlockCode: array[1..2] of Byte = (
    $59,       { POP ECX }
    $E9);      { JMP StdWndProc }
  PageSize = 4096;
var
  Block: PInstanceBlock;
  Instance: PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;  { CALL NEAR PTR Offset }
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(Longint(Instance), SizeOf(TObjectInstance));
    until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block;
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
  inc(InstBlockCount);
end;

{ Free an object instance }

procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
  if (ObjectInstance <> nil) and (InstBlockCount > 0) then
  begin
    PObjectInstance(ObjectInstance)^.Next := InstFreeList;
    InstFreeList := ObjectInstance;
    Dec(InstBlockCount);
    if InstBlockCount = 0 then begin
       VirtualFree(InstBlockList, 0, MEM_RELEASE);
       InstBlockList := nil;
//       ObjectInstance := nil;
    end;
  end;
end;

var
  UtilWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'KOLFakeUtilWindow');

function AllocateHWnd(Method: TWndMethod): HWND;
var
  TempClass: TWndClass;
  ClassRegistered: Boolean;
begin
  UtilWindowClass.hInstance := HInstance;
  ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
    TempClass);
  if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
  begin
    if ClassRegistered then
      Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
    Windows.RegisterClass(UtilWindowClass);
  end;
  Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
    '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
  if Assigned(Method) then
    SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
end;

procedure DeallocateHWnd(Wnd: HWND);
var
  Instance: Pointer;
begin
  Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
  DestroyWindow(Wnd);
  if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
end;

procedure SplitColor(C: TColor; var r, g, b: integer);
begin
   b := (c and $FF0000) shr 16;
   g := (c and $00FF00) shr 08;
   r := (c and $0000FF) shr 00;
end;

procedure AjustBitmap;
var i, j: integer;
       t: KOL.PBitmap;
       r,
       g,
       b,
      r2,
      g2,
      b2: integer;
       p: PRGBTriple;

 function CalcColor(c1, c2, c3: integer): integer;
 begin
   if c1 = c3 then begin
      Result := c2;
      exit;
   end;

   if c1 = 0 then begin
      Result := 0;
      exit;
   end;

{   Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
   exit;}

   Result := c1 * c2 div c3;
   if c2 = 0 then Result := c1 * 150 div 255;
   if Result > 255 then Result := 255;
   if Result <  50 then Result :=  Result + 50;
{   exit;
   a  := trunc(x1 * 3);
   a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
   a := 255 * 255 - 4 * a;
   try
      x1 := Trunc((255 - sqrt(a)) / 2);
      x2 := Trunc((255 + sqrt(a)) / 2);
      if x1 > x2 then Result := Trunc(x1)
                 else Result := Trunc(x2);
   except
      Result := 0;
   end;}
 end;

begin
   if s           = c then exit;
   if m.Width   = 0 then exit;
   if m.Height  = 0 then exit;
   t := NewBitmap(m.Width, m.Height);
   m.PixelFormat := pf24bit;
   t.Assign(m);
   SplitColor(Color2RGB(s), r, g, b);
   if r = 0 then r := 1;
   if g = 0 then g := 1;
   if b = 0 then b := 1;
   SplitColor(Color2RGB(c), r2, g2, b2);
   for j := 0 to t.Height - 1 do begin
      p := t.scanline[j];
      for i := 0 to t.Width - 1 do begin
         p.rgbtRed   := CalcColor(p.rgbtRed,   r2, r);
         p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
         p.rgbtBlue  := CalcColor(p.rgbtBlue,  b2, b);
         inc(p);
      end;
   end;
   m.Assign(t);
   t.Free;
end;

function IncColor;
var T: TColor;
    P: PRGBTriple;
begin
   T := Color2RGB(C);
   p := @T;
   if D > 0 then begin
      if p.rgbtBlue  < 255 - D then p.rgbtBlue  := p.rgbtBlue  + D else p.rgbtBlue  := 255;
      if p.rgbtRed   < 255 - D then p.rgbtRed   := p.rgbtRed   + D else p.rgbtRed   := 255;
      if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
   end else begin
      if p.rgbtBlue  >       D then p.rgbtBlue  := p.rgbtBlue  - D else p.rgbtBlue  := 000;
      if p.rgbtRed   >       D then p.rgbtRed   := p.rgbtRed   - D else p.rgbtRed   := 000;
      if p.rgbtGreen >       D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
   end;
   Result := T;
end;

begin
  InstBlockList  := nil;
  InstBlockCount := 0;
  InstFreeList   := nil;
end.