unit UtilClass;

interface

uses
  windows,
  messages,
  UtilFunc;

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------

//------------------------------------------------------------
//                    Classes
//------------------------------------------------------------

//-----------------  TIntegerList ------------------------------
const
  MaxItem = 200000;

type
TIntegerArray = array[0..MaxItem] of Integer;
PIntegerArray = ^TIntegerArray;

TIntegerList = class(TObject)
private
  FPointer: PIntegerArray;
  FCount: integer;
  FSize: integer;
  FReAllocSize: integer;
  FInitialSize: integer;
  function GetItem(index: integer):Integer;
  procedure SetItem(index: integer; value: Integer);
  function GetCount: integer;
  function GetRealSize: integer;
protected
public
  constructor Create(InitialSize,ReAllocSize:integer);virtual;
  destructor Destroy; override;
  procedure Clear;
  procedure Add(value:Integer);
  procedure Delete(index: integer);
  procedure Insert(index: integer; value: Integer);
  function Search(value: Integer): integer;
  procedure CopyTo(var IL: TIntegerList);
  property Item[i:integer]:Integer read GetItem write SetItem;default;
  property Count: integer read GetCount;
  property Size: integer read FSize;
  property RealSize: integer read GetRealSize;
end;

//------------------ TMessageDispatcher ----------------------

TSubClass = class; // forward

TMessageDispatcher = class(TObject)
private
  FSList: TIntegerList;
  FParentList: TIntegerList;
  FParentProc: TIntegerList;
  FMessageList: TIntegerList;
  FMessageObject: TIntegerList;
  FCopyList: TIntegerList;
  FCopyList2: TIntegerList;
  FNeedCopy: Boolean;
  function GetCount:integer;
protected
  function IsNewParent(hWindow:HWND):Boolean;
  function IsParent(hWindow:HWND):Boolean;
  function GetParentProc(hWindow:HWND):TFNWndProc;
public
  constructor Create;
  destructor Destroy; override;
  procedure DefaultHandler(var Message);override;
  procedure Add(Obj:TSubClass);
  procedure Delete(Obj:TSubClass);
  procedure TrapMessage(Msg: UINT; Obj: TSubClass);
  property Count: integer read GetCount;
end;

//------------------ TSubClass -------------------------------
TSubClass = class(TObject)
private
  FParent: HWND;
  FData: integer;
protected
public
  constructor Create(hParent:HWND); virtual;
  destructor Destroy; override;
  property Parent: HWND read FParent;
  property Data : integer read FData write FData;
end;

//-----------------  TAPITimer -------------------------------------------
TAPITimer = class(TSubClass)
private
  FInterval : integer;
  FOnTimer: TNotifyMessage;
  FIsOn : Boolean;
public
  constructor Create(hParent: HWND); override;
  destructor Destroy; override;
  procedure DefaultHandler(var AMessage); override;
  procedure On;
  procedure Off;
  property IsOn: Boolean read FIsOn;
  property Interval: integer read FInterval write FInterval;
  property OnTimer: TNotifyMessage read FOnTimer write FOnTimer;
end;

//----------------- TStringArray -------------------------------------
TStringArray = class(TObject)
private
  PCharArray : TIntegerList;
  FCount: integer;
  function GetItems(index:integer): string;
  procedure SetItem(index: integer;value:string);
  function GetCount: integer;
protected
public
  constructor Create; virtual;
  destructor Destroy; override;
  property Items[i:integer]:string read GetItems write SetItem;default;
  property Count: integer read GetCount;
  procedure Add(value:string);
  procedure Clear;
  procedure Delete(index: integer);
  procedure Insert(index: integer; value: string);
  function Search(s:string):integer;
  procedure Exchange(i,j: integer);
  procedure Sort;
end;

function APICompareString(S1,S2: string): integer;
procedure StringQuickSort(SS: TStringArray;l,r: Integer);


//------------------------------------------------------------
//        Create Functions
//------------------------------------------------------------
function CreateTimer(hParent:HWND; Intrvl: integer;
                     OnTimerFunc: TNotifyMessage):TAPITimer;

                     
var
  Dispatcher: TMessageDispatcher;

implementation


//------------------------------------------------------------
//                    Classes
//------------------------------------------------------------

//-----------------  TIntegerList ------------------------------
constructor TIntegerList.Create(InitialSize,ReAllocSize:integer);
begin
  if ReAllocSize = 0 then FReAllocSize := $10 else FReAllocSize := ReAllocSize;
  if InitialSize = 0 then FInitialSize := $10 else FInitialSize := InitialSize;
  FSize := FInitialSize;
  GetMem(FPointer,SizeOf(Integer)*FSize);
  FCount := -1;
end;

destructor TIntegerList.Destroy;
begin
  FreeMem(FPointer);
  inherited Destroy;
end;

procedure TIntegerList.Clear;
begin
  FreeMem(FPointer);
  FSize := FInitialSize;
  GetMem(FPointer,SizeOf(Integer)*FSize);
  FCount := -1;
end;

procedure TIntegerList.Add(value:Integer);
begin
  Inc(FCount);
  if FCount > FSize-1 then begin
    Inc(FSize,FReAllocSize);
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  FPointer^[FCount] := value;
end;

procedure TIntegerList.Delete(index: integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  if index = FCount then begin
    Dec(FCount);
    Exit;
  end;
  Move(FPointer^[index+1],FPointer^[index],
             SizeOf(Integer)*(FCount-index));
  Dec(FCount);
end;

procedure TIntegerList.Insert(index: integer; value: Integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  if FCount+1 > FSize-1 then begin
    Inc(FSize,FReAllocSize);
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  Move(FPointer^[index],FPointer^[index+1],
             SizeOf(Integer)*(FCount-index+1));
  FPointer^[index] := value;
  Inc(FCount);
end;

function TIntegerList.GetItem(index: integer):Integer;
begin
  if (index > FCount) or (index < 0) then
    result := 0
  else
    result := FPointer^[index];
end;

procedure TIntegerList.SetItem(index: integer; value: Integer);
begin
  if index > FSize-1 then begin
    repeat
      Inc(FSize,FReAllocSize);
    until  index < FSize-1;
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  FPointer^[index] := value;
  if FCount < index then FCount := index;
end;

function TIntegerList.GetCount: integer;
begin
  result := FCount+1;
end;

function TIntegerList.GetRealSize: integer;
begin
  result := FSize;
end;

function TIntegerList.Search(value: Integer): integer;
var
  i: integer;
begin
  for i := 0 to FCount do
    if FPointer^[i] = value then begin
      result := i;
      Exit;
    end;
  result := -1;
end;

procedure TIntegerList.CopyTo(var IL: TIntegerList);
var
  i: integer;
begin
  IL.Clear;
  for i := 0 to FCount do
    IL[i] := FPointer^[i];
end;

//------------------ TMessageDispatcher ----------------------
function SubClassProc(hParent: HWND; Msg: UINT;
                       wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
  OriginalProc: TFNWndProc;
begin

  result := 0;
  if not Dispatcher.IsParent(hParent) then Exit;

  OriginalProc := Dispatcher.GetParentProc(hParent);

  result := CallWindowProc(OriginalProc,hParent,Msg,wParam,lParam);

  AMsg.Msg := Msg;
  AMsg.WParam := wParam;
  AMsg.LParam := lParam;
  AMsg.Result := hParent;

  case Msg of

    WM_DESTROY: begin
      SetWindowLong(hParent,GWL_WNDPROC,integer(OriginalProc));
      Dispatcher.Dispatch(AMsg);
    end;

  else
    Dispatcher.Dispatch(AMsg);

  end; // case

  if AMsg.Result <> 0 then result := AMsg.Result;

end;

constructor TMessageDispatcher.Create;
begin
  FSList := TIntegerList.Create($10,$10);
  FParentList := TIntegerList.Create($10,$10);
  FParentProc := TIntegerList.Create($10,$10);
  FMessageList := TIntegerList.Create($10,$10);
  FMessageObject := TIntegerList.Create($10,$10);
  FCopyList := TIntegerList.Create($10,$10);
  FCopyList2 := TIntegerList.Create($10,$10);
  FNeedCopy := false;
end;

destructor TMessageDispatcher.Destroy;
begin
  FNeedCopy := false;
  FSList.Free;
  FParentList.Free;
  FParentProc.Free;
  FMessageList.Free;
  FMessageObject.Free;
  FCopyList.Free;
  FCopyList2.Free;
  inherited Destroy;
end;

procedure TMessageDispatcher.DefaultHandler(var Message);
var
  AMsg: TMessage;
  hParent: HWND;
  i: integer;
  SO: TSubClass;
begin
  AMsg := TMessage(Message);

  hParent := AMsg.Result;
  TMessage(Message).result := 0; // default return result
  AMsg.Result := 0;              // default object return

  if AMsg.Msg = WM_DESTROY then begin
    for i := FSList.Count-1 downto 0 do begin
      SO := TSubClass(FSList[i]);
      if Assigned(SO) then
        if (SO.Parent = hParent) then begin
          FSList.Delete(i);
          SO.Free;  //SO := nil;
        end;
    end;
    FParentProc.Delete(FParentList.Search(hParent));    
    FParentList.Delete(FParentList.Search(hParent));
    exit;
  end;

  if FMessageList.Search(AMsg.Msg) = -1 then
    exit
  else begin
    if FNeedCopy then begin
      FMessageList.CopyTo(FCopyList);
      FMessageObject.CopyTo(FCopyList2);
      FNeedCopy := false;
    end;
    for i := 0 to FCopyList.Count-1 do
      if DWORD(FCopyList[i]) = AMsg.Msg then begin
        SO := TSubClass(FCopyList2[i]);
        if Assigned(SO) then
          if (SO.Parent = hParent) then begin
            SO.Dispatch(AMsg);
            if AMsg.Result <> 0 then begin
              TMessage(Message).result := AMsg.Result;
             exit;
            end;
          end;
      end;
  end;
end;

procedure TMessageDispatcher.TrapMessage(Msg: UINT; Obj: TSubClass);
begin
  FMessageList.Add(Msg);
  FMessageObject.Add(integer(Obj));
  FNeedCopy := true;
end;

function TMessageDispatcher.IsNewParent(hWindow:HWND):Boolean;
begin
  result := true;
  if FParentList.Count < 1 then Exit;
  if FParentList.Search(hWindow) > -1 then result := false;
end;

function TMessageDispatcher.IsParent(hWindow:HWND):Boolean;
begin
  result := false;
  if FParentList.Count < 1 then Exit;
  if FParentList.Search(hWindow) = -1 then
    result := false
  else
    result := true;
end;

function TMessageDispatcher.GetParentProc(hWindow:HWND):TFNWndProc;
begin
  result := TFNWndProc(FParentProc[FParentList.Search(hWindow)]);
end;

procedure TMessageDispatcher.Add(Obj:TSubClass);
var
  OriginalProc: integer;
begin
  FSList.Add(Integer(Obj));

  if IsNewParent(Obj.Parent) then begin
    FParentList.Add(Obj.Parent);
    OriginalProc := GetWindowLong(Obj.Parent,GWL_WNDPROC);
    FParentProc.Add(OriginalProc);
    SetWindowLong(Obj.Parent,GWL_WNDPROC,integer(@SubClassProc));
  end;
end;

procedure TMessageDispatcher.Delete(Obj:TSubClass);
var
  i: integer;
begin
  FSList.Delete(FSList.Search(Integer(Obj)));
  for i := FMessageObject.Count-1 downto 0 do
    if FMessageObject[i] = integer(Obj) then begin
      FMessageObject.Delete(i);  // UnTrap Message
      FMessageList.Delete(i);
    end;
  FNeedCopy := true;
end;

function TMessageDispatcher.GetCount:integer;
begin
  result := FSList.Count;
end;

//------------------ TSubClass -------------------------------
constructor TSubClass.Create(hParent:HWND);
begin
  if not Assigned(Dispatcher) then Dispatcher := TMessageDispatcher.Create;
  FParent := hParent;
  Dispatcher.Add(self);
end;

destructor TSubClass.Destroy;
begin
  Dispatcher.Delete(self);
  inherited Destroy;
end;

//-----------------  TAPITimer -------------------------------------------
constructor TAPITimer.Create(hParent: HWND);
begin
  inherited Create(hParent);
  Dispatcher.TrapMessage(WM_TIMER,self);

  FInterval := 1000;
  FIsOn := false;
end;

destructor TAPITimer.Destroy;
begin
  Off;
  inherited Destroy;
end;

procedure TAPITimer.On;
begin
  if FIsOn = true then exit;
  FIsOn := true;
   // TimerID に 自分のオブジェクト参照を渡す！！
  SetTimer(Parent,integer(self),FInterval,nil);
end;

procedure TAPITimer.Off;
begin
  if FIsOn = false then exit;
  FIsOn := false;
  KillTimer(Parent,integer(self));
end;

procedure TAPITimer.DefaultHandler(var AMessage);
var
  AMsg: TMessage;
begin
  AMsg := TMessage(AMessage);
  if AMsg.Msg = WM_TIMER then
    if AMsg.WParam = integer(self) then begin
      AMsg.Msg := UINT(self);  // sender
      if Assigned(FOnTimer) then OnTimer(AMsg);
    end;
end;

//----------------- TStringArray -------------------------------------
constructor TStringArray.Create;
begin
  PCharArray := TIntegerList.Create($10,$10);
  FCount := -1;
end;

destructor TStringArray.Destroy;
var
  i: integer;
begin
  if FCount <> -1 then
    for i := 0 to FCount do FreeMem(PChar(PCharArray[i]));
  PCharArray.Free;
end;

procedure TStringArray.Add(value:string);
var
  PC: PChar;
begin
  Inc(FCount);
  GetMem(PC,Length(value)+1);
  lstrcpy(PC,PChar(value));
  PCharArray.Add(integer(PC));
end;

function TStringArray.GetItems(index:integer): string;
var
  PC: PChar;
begin
  if (index > FCount) or (index < 0) then begin
    result := 'index error';
    exit;
  end;
  PC := PChar(PCharArray[index]);
  SetString(result,PC,lstrlen(PC));
end;

procedure TStringArray.SetItem(index: integer;value:string);
var
  PC: PChar;
begin
  if (index > FCount) or (index < 0) then exit;
  GetMem(PC,Length(value)+1);
  lstrcpy(PC,PChar(value));
  FreeMem(PChar(PCharArray[index]));
  PCharArray[index] := integer(PC);
end;

procedure TStringArray.Clear;
var
  i: integer;
begin
  if FCount = -1 then exit;
  for i := 0 to FCount do FreeMem(PChar(PCharArray[i]));
  PCharArray.Clear;
  FCount := -1;
end;

procedure TStringArray.Delete(index: integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  FreeMem(PChar(PCharArray[index]));
  PCharArray.Delete(index);
  Dec(FCount);
end;

procedure TStringArray.Insert(index: integer; value: string);
var
 PC: PChar;
begin
  if (index > FCount) or (index < 0) then Exit;
  GetMem(PC,Length(value)+1);
  lstrcpy(PC,PChar(value));
  PCharArray.Insert(index,integer(PC));
  Inc(FCount);
end;

function TStringArray.Search(s:string):integer;
var
  i: integer;
begin
  i := -1;
  Repeat
    Inc(i);
  Until (Items[i] = s) or ( i>FCount );
  if i > FCount then
    Result := -1
  else
    Result := i;
end;

function TStringArray.GetCount: integer;
begin
  result := FCount+1;
end;

procedure TStringArray.Exchange(i,j: integer);
var
  s: string;
begin
  s := Items[i];
  Items[i] := Items[j];
  Items[j] := s;
end;

procedure TStringArray.Sort;
begin
  StringQuickSort(self,0,Count-1);
end;

function APICompareString(S1,S2: string): integer;
begin
  result := CompareString(LOCALE_SYSTEM_DEFAULT,0,
                          PChar(S1),-1,PChar(S2),-1) - 2;
end;

procedure StringQuickSort(SS: TStringArray;l,r: integer);
var
  i,j: integer;
  sP: string;
begin
  repeat
    i := l;
    j := r;
    sP := SS[(l+r) div 2];
    repeat
      while APICompareString(SS[i],sP) < 0 do inc(i);
      while APICompareString(SS[j],sP) > 0 do dec(j);
      if i <= j then begin
        SS.Exchange(i,j);
        inc(i);
        dec(j);
      end;
    until i > j;
    if l < j then StringQuickSort(SS,l,j);
    l := i;
  until i >= r;
end;

//------------------------------------------------------------
//        Create Functions
//------------------------------------------------------------
function CreateTimer(hParent:HWND; Intrvl: integer;
                     OnTimerFunc: TNotifyMessage):TAPITimer;
begin
  result := TAPITimer.Create(hParent);
  with result do begin
    Interval := Intrvl;
    OnTimer := OnTimerFunc;
  end;
end;

initialization

finalization
  Dispatcher.Free;

end.