Objects.pas

   1 unit objects;
   2
   3 interface
   4 uses KOL, Windows, Messages;
   5
   6 type
   7   TWndMethod = procedure(var Message: TMessage) of object;
   8
   9 function MakeObjectInstance(Method: TWndMethod): Pointer;
  10 procedure FreeObjectInstance(ObjectInstance: Pointer);
  11 function AllocateHWnd(Method: TWndMethod): HWND;
  12 procedure DeallocateHWnd(Wnd: HWND);
  13 function  IncColor(C: TColor; D: integer): TColor;
  14 procedure AjustBitmap(const M: KOL.PBitmap; S, C: TColor);
  15
  16 implementation
  17
  18 type
  19   PObjectInstance = ^TObjectInstance;
  20   TObjectInstance = packed record
  21     Code: Byte;
  22     Offset: Integer;
  23     case Integer of
  24       0: (Next: PObjectInstance);
  25       1: (Method: TWndMethod);
  26   end;
  27
  28 type
  29   PInstanceBlock = ^TInstanceBlock;
  30   TInstanceBlock = packed record
  31     Next: PInstanceBlock;
  32     Code: array[1..2] of Byte;
  33     WndProcPtr: Pointer;
  34     Instances: array[0..100] of TObjectInstance;
  35   end;
  36
  37 var
  38   InstBlockList: PInstanceBlock;
  39   InstBlockCount: integer;
  40   InstFreeList: PObjectInstance;
  41
  42 { Standard window procedure }
  43 { In    ECX = Address of method pointer }
  44 { Out   EAX = Result }
  45
  46 function StdWndProc(Window: HWND; Message, WParam: Longint;
  47   LParam: Longint): Longint; stdcall; assembler;
  48 asm
  49         XOR     EAX,EAX
  50         PUSH    EAX
  51         PUSH    LParam
  52         PUSH    WParam
  53         PUSH    Message
  54         MOV     EDX,ESP
  55         MOV     EAX,[ECX].Longint[4]
  56         CALL    [ECX].Pointer
  57         ADD     ESP,12
  58         POP     EAX
  59 end;
  60
  61 { Allocate an object instance }
  62
  63 function CalcJmpOffset(Src, Dest: Pointer): Longint;
  64 begin
  65   Result := Longint(Dest) - (Longint(Src) + 5);
  66 end;
  67
  68 function MakeObjectInstance(Method: TWndMethod): Pointer;
  69 const
  70   BlockCode: array[1..2] of Byte = (
  71     $59,       { POP ECX }
  72     $E9);      { JMP StdWndProc }
  73   PageSize = 4096;
  74 var
  75   Block: PInstanceBlock;
  76   Instance: PObjectInstance;
  77 begin
  78   if InstFreeList = nil then
  79   begin
  80     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  81     Block^.Next := InstBlockList;
  82     Move(BlockCode, Block^.Code, SizeOf(BlockCode));
  83     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
  84     Instance := @Block^.Instances;
  85     repeat
  86       Instance^.Code := $E8;  { CALL NEAR PTR Offset }
  87       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
  88       Instance^.Next := InstFreeList;
  89       InstFreeList := Instance;
  90       Inc(Longint(Instance), SizeOf(TObjectInstance));
  91     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
  92     InstBlockList := Block;
  93   end;
  94   Result := InstFreeList;
  95   Instance := InstFreeList;
  96   InstFreeList := Instance^.Next;
  97   Instance^.Method := Method;
  98   inc(InstBlockCount);
  99 end;
 100
 101 { Free an object instance }
 102
 103 procedure FreeObjectInstance(ObjectInstance: Pointer);
 104 begin
 105   if (ObjectInstance <> nil) and (InstBlockCount > 0) then
 106   begin
 107     PObjectInstance(ObjectInstance)^.Next := InstFreeList;
 108     InstFreeList := ObjectInstance;
 109     Dec(InstBlockCount);
 110     if InstBlockCount = 0 then begin
 111        VirtualFree(InstBlockList, 0, MEM_RELEASE);
 112        InstBlockList := nil;
 113        ObjectInstance := nil;
 114     end;
 115   end;
 116 end;
 117
 118 var
 119   UtilWindowClass: TWndClass = (
 120     style: 0;
 121     lpfnWndProc: @DefWindowProc;
 122     cbClsExtra: 0;
 123     cbWndExtra: 0;
 124     hInstance: 0;
 125     hIcon: 0;
 126     hCursor: 0;
 127     hbrBackground: 0;
 128     lpszMenuName: nil;
 129     lpszClassName: 'KOLFakeUtilWindow');
 130
 131 function AllocateHWnd(Method: TWndMethod): HWND;
 132 var
 133   TempClass: TWndClass;
 134   ClassRegistered: Boolean;
 135 begin
 136   UtilWindowClass.hInstance := HInstance;
 137   ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
 138     TempClass);
 139   if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
 140   begin
 141     if ClassRegistered then
 142       Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
 143     Windows.RegisterClass(UtilWindowClass);
 144   end;
 145   Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
 146     '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
 147   if Assigned(Method) then
 148     SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
 149 end;
 150
 151 procedure DeallocateHWnd(Wnd: HWND);
 152 var
 153   Instance: Pointer;
 154 begin
 155   Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
 156   DestroyWindow(Wnd);
 157   if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
 158 end;
 159
 160 procedure SplitColor(C: TColor; var r, g, b: integer);
 161 begin
 162    b := (c and $FF0000) shr 16;
 163    g := (c and $00FF00) shr 08;
 164    r := (c and $0000FF) shr 00;
 165 end;
 166
 167 procedure AjustBitmap;
 168 var i, j: integer;
 169        t: KOL.PBitmap;
 170        r,
 171        g,
 172        b,
 173       r2,
 174       g2,
 175       b2: integer;
 176        p: PRGBTriple;
 177
 178  function CalcColor(c1, c2, c3: integer): integer;
 179  begin
 180    if c1 = c3 then begin
 181       Result := c2;
 182       exit;
 183    end;
 184
 185    if c1 = 0 then begin
 186       Result := 0;
 187       exit;
 188    end;
 189
 190 {   Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
 191    exit;}
 192
 193    Result := c1 * c2 div c3;
 194    if c2 = 0 then Result := c1 * 150 div 255;
 195    if Result > 255 then Result := 255;
 196    if Result <  50 then Result :=  Result + 50;
 197 {   exit;
 198    a  := trunc(x1 * 3);
 199    a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
 200    a := 255 * 255 - 4 * a;
 201    try
 202       x1 := Trunc((255 - sqrt(a)) / 2);
 203       x2 := Trunc((255 + sqrt(a)) / 2);
 204       if x1 > x2 then Result := Trunc(x1)
 205                  else Result := Trunc(x2);
 206    except
 207       Result := 0;
 208    end;}
 209  end;
 210
 211 begin
 212    if s           = c then exit;
 213    if m.Width   = 0 then exit;
 214    if m.Height  = 0 then exit;
 215    t := NewBitmap(m.Width, m.Height);
 216    m.PixelFormat := pf24bit;
 217    t.Assign(m);
 218    SplitColor(Color2RGB(s), r, g, b);
 219    if r = 0 then r := 1;
 220    if g = 0 then g := 1;
 221    if b = 0 then b := 1;
 222    SplitColor(Color2RGB(c), r2, g2, b2);
 223    for j := 0 to t.Height - 1 do begin
 224       p := t.scanline[j];
 225       for i := 0 to t.Width - 1 do begin
 226          p.rgbtRed   := CalcColor(p.rgbtRed,   r2, r);
 227          p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
 228          p.rgbtBlue  := CalcColor(p.rgbtBlue,  b2, b);
 229          inc(p);
 230       end;
 231    end;
 232    m.Assign(t);
 233    t.Free;
 234 end;
 235
 236 function IncColor;
 237 var T: TColor;
 238     P: PRGBTriple;
 239 begin
 240    T := Color2RGB(C);
 241    p := @T;
 242    if D > 0 then begin
 243       if p.rgbtBlue  < 255 - D then p.rgbtBlue  := p.rgbtBlue  + D else p.rgbtBlue  := 255;
 244       if p.rgbtRed   < 255 - D then p.rgbtRed   := p.rgbtRed   + D else p.rgbtRed   := 255;
 245       if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
 246    end else begin
 247       if p.rgbtBlue  >       D then p.rgbtBlue  := p.rgbtBlue  - D else p.rgbtBlue  := 000;
 248       if p.rgbtRed   >       D then p.rgbtRed   := p.rgbtRed   - D else p.rgbtRed   := 000;
 249       if p.rgbtGreen >       D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
 250    end;
 251    Result := T;
 252 end;
 253
 254 begin
 255   InstBlockList  := nil;
 256   InstBlockCount := 0;
 257   InstFreeList   := nil;
 258 end.