old/PAS/!SPbSTU/Kurs/WIN2K2.PAS

unit Win2K2;
                                INTERFACE
Uses CoolKey,CoolMice,Graph,Dos;
{$I Wtypes.inc}
{$I Errors.inc}
{$I WMs.inc}
{Main procedures}
var
  GlobalPalette : TPalette;

Function  InitWin2K2:UInt16;
Function  DoneWin2K2:UInt16;
Function  MainRunLoop:UInt16;
Function  Alloc(cbSize:Uint32):Pointer;
Function  RegisterClass(aName:String;MainWndProc:TWndProc):UInt16;
Function  CreateWindow(aTitle,aClassName:string;
                       aStyles:UINT32;
                       aX,aY,aW,aH:Int16;
                       aParent:HWND;
                       aMenu:HMENU
                      ):hWnd;
Function  DefWindowProc(ahWnd:HWND;aMsg: UINT32; awParam,alParam:UINT32):UInt32;
Function  PostQuitMessage(ahWnd:HWND):INT16;
Function  SendMessage(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;
Function  PostMessage(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;
Function  FindWindow(aT,aC : PString):HWND;
Function  FindChildWindow(aH:HWND;aT,aC : PString):HWND;
Function  WindowFromPoint(aP:POINT):HWND;
Function  ChildWindowFromPoint(aParent:hWnd;aP:POINT):HWND;
Function  GetWindowText(aH:HWND;aS:PString;StrLen:UINT8):UINT8;
Function  SetWindowText(aH:HWND;aS:PString):UINT8;
Function  PrintChar(SC:UINT8):boolean;
Function  AddOnFrameMessage(aH:hWnd):boolean;
Function  DelOnFrameMessage(aH:hWnd):boolean;
{---}
Procedure GetClientRect(aH:HWND;aR:LPRECT);
Procedure GetGlobalRect(aH:HWND;aR:LPRECT);
PRocedure GlobalToClient(aH:HWND;aX,aY:INT16;aR:LPPOINT);
Function  GetParent(aH:HWND):HWND;
Function  IsKeyActive(aH:HWND):Boolean;
{GDI}
Function BeginPaint(aH:HWND):LPPAINTSTRUCT;
Procedure EndPaint(aP:LPPAINTSTRUCT);
Procedure wSetBgColor(aP:LPPAINTSTRUCT;aNewColor:INT8);
Procedure wSetColor(aP:LPPAINTSTRUCT;aNewColor:INT8);
Procedure wSetFont(aP:LPPAINTSTRUCT;aNewFont:INT8);
Procedure wSetFontJustify(aP:LPPAINTSTRUCT;aNewH,aNewV:INT8);
Procedure wSetStyle(aP:LPPAINTSTRUCT;aNewStyle:INT8);
Procedure wSetFontSize(aP:LPPAINTSTRUCT;aNewColor:INT8);
Function wMoveToEx(aP:LPPAINTSTRUCT;X,Y:INT16;lP:LPPOINT):Boolean;
Function wLineTo(aP:LPPAINTSTRUCT;X,Y:INT16):Boolean;
Function wTextOut(aP:LPPAINTSTRUCT;X,Y:INT16;aStr:PString):Boolean;
Function wRectangle(aP:LPPAINTSTRUCT;X1,Y1,X2,Y2:INT16):Boolean;
Function wLine(aP:LPPAINTSTRUCT;X1,Y1,X2,Y2:INT16):Boolean;
Function wBar(aP:LPPAINTSTRUCT;X1,Y1,X2,Y2:INT16):Boolean;
Function wFillCircle(aP:LPPAINTSTRUCT;X1,Y1,Rad:INT16):Boolean;

                            IMPLEMENTATION
Var
  AllClasses    : PClassArray;
  AllWindows    : PWindow;
  TopMost       : PWindow;
  AllFonts      : PFontDefArray;
  FontCount     : UINT16;
  AllMenus      : PMenuList;
  KillList      : PWndList;
  OnFrameList   : PWndList;
  AllCursors    : PCursorArr;
  CursorCnt     : UINT8;
{-----------------------------------------------------------------------}
CONST
 GlobHandle     : hWnd   = 1;
 gResizeThr     : INT16  = 4;
 LastError      : Uint16 = 0;
 ClassesInitCnt : Uint16 = 20;
 ClassesCntInc  : UInt16 = 5;
 ClassesCnt     : Uint16 = 0;
 bNeedRender    : boolean = true;
{-----------------------------------------------------------------}
Procedure EGAVGADriver;external;
{$I procW2K2.inc}
Function InitWin2K2:UInt16;
Begin
 
 LastError := wInitKeyboard;
 if (LastError <> ERR_OK) then
  begin
   InitWin2K2 := LastError;
   Exit;
  end;

 LastError := wInitMouse;
 if (LastError <> ERR_OK) then
  begin
   InitWin2K2 := LastError;
   Exit;
  end;

 LastError := wInitGraph;
 if (LastError <> ERR_OK) then
  begin
   InitWin2K2 := LastError;
   Exit;
  end;

 New(AllMenus);
 AllMenus^.Handle :=0;
 AllMenus^.Next := nil;
 AllMenus^.Mn := nil;

 AllClasses := PClassArray(Alloc(ClassesInitCnt * sizeof(TClass)));
 if AllClasses = nil then
  begin
   InitWin2K2 := ERR_NOMEM;
   LastError := ERR_NOMEM;
   Exit;
  end;
 New(AllWindows);
 With AllWindows^ do
  begin
   WClass := nil;
   Handle := 0;
   Parent := Nil;
   Child  := nil;
   Brother:= nil;
   Title  := nil;
   Queue  := nil;

   zOrder := nil;
   Next   := nil;
  end;
 TopMost := AllWindows;
 KillList  := nil;
 wInitGlobalPalette;
 wInitFonts;
 wInitTitleButtons;

 LastError := ERR_OK;
 InitWin2K2 := ERR_OK;
end;{}
{-----------------------------------}
Function DoneWin2K2:UInt16;
var
 c : PWindow;
 i : UINT16;
 kl: PWndList;
Begin
  IF AllClasses <> nil then 
  begin
   For i:=0 to ClassesCnt-1 do FreeMem(AllClasses^[i].Name,ord(AllClasses^[i].Name^[0])+1);
   FreeMem(AllCLasses, ClassesInitCnt * sizeof(TClass));
  end;
  While AllWindows <> nil do 
   begin
    c:=AllWindows^.Next;
    if AllWindows^.Title <> nil then
      FreeMem(AllWindows^.Title,ord(AllWindows^.Title^[0])+1);

    Dispose(AllWindows);
    AllWindows := C;
   end;
   while KillList <> nil do
    begin
     wDestroyWindow(KillList^.Wnd);
     kl := KillList^.Next;
     Dispose(KillList);
     KillList:=kl;
    end;
   while OnFrameList <> nil do
    begin
     kl := OnFrameList^.Next;
     Dispose(OnFrameList);
     OnFrameList:=kl;
    end;
  wDoneGraph;
  wDoneMouse;
  wDoneKeyboard;
  DoneWin2k2 := 0;
  LastError := ERR_OK;
end;{}
{-----------------------------------}
Function MainRunLoop:UInt16;
var
 c    : PWindow;
 q,nq : PMessageList;
 kl   : PWndList;
Begin
 while (AllWindows^.Next <> nil) do
  begin
   ProcessKeyboard;
   ShowMouse;
   ProcessMouse;
   c := AllWindows^.Next;
   while c <> nil do
    begin
     q := c^.Queue^.Next;
     while q <> nil do
      begin
       wSendMessage(c,q^.msg.Message,q^.msg.wParam,q^.msg.lParam);
       nq := q^.next;
       Dispose(q);
       q := nq;
      end;
     c^.Queue^.Next := nil;
     c := c^.next;
    end;
   while KillList <> nil do
    begin
     wDestroyWindow(KillList^.Wnd);
     kl := KillList^.Next;
     Dispose(KillList);
     KillList:=kl;
    end;
   kl := OnFrameList;
   while kl <> nil do
    begin
     wSendMessage(kl^.wnd,WM_ONFRAME,0,0);
     kl := kl^.next;
    end;
   if bNeedRender then wRenderAll;
  end;
end;{}
{-----------------------------------}
Function RegisterClass(aName:String;MainWndProc:TWndProc):UInt16;
Var
 cp : PClass;
 na : PClassArray;
Begin                         
 cp := wGetClass(aName);
 if (cp <> nil) then 
  begin
   RegisterClass:=ERR_CLASSEXIST;
   LastError := ERR_CLASSEXIST;
   exit;
  end;
 if ClassesCnt = ClassesInitCnt then
  begin
   na := Alloc(sizeof(TClass) * (ClassesInitCnt + ClassesCntInc));
   if (na = nil) then
    begin
      RegisterClass := ERR_NOMEM;
      LastError := ERR_NOMEM;
      Exit;
    end;
   Move(AllClasses,Na,sizeof(TClass) * (ClassesInitCnt));
   Inc(ClassesInitCnt,ClassesCntInc);
  end;
 with AllClasses^[ClassesCnt] do
  begin
   Name := Alloc(ord(aName[0])+1);
   Name^ := aName;
   WndProc := MainWndProc;
  end;
 Inc(ClassesCNT);
 RegisterClass := ERR_OK;
 LastError := ERR_OK;
end;{}
{-----------------------------------}
Function CreateWindow(aTitle,aClassName:string;aStyles:UINT32;aX,aY,aW,aH:Int16;
                      aParent:HWND;aMenu:HMENU):hWNd;
Var
 mNew, c : PWindow;
 mClass  : PClass;
 g1      : hWnd;
Begin
 mClass := wGetClass(aClassName);
 if mClass = nil then
  begin
   CreateWindow := 0;
   LastError := ERR_BADCLASS; 
   Exit;
  end;
 New(mNew);
 with mNew^ do
  begin
   WClass := mClass;
   Handle := GlobHandle;Inc(GlobHandle);
   Style := aStyles;
   Parent := nil;

   New(Palette);
   Palette^ := GlobalPalette;

   New(Child);
   Child^.Brother := nil;
   Brother:= nil;
   if aParent <> NULL then 
   begin
    Parent := wGetWndByhWnd(aParent);
    if Parent=NIL then
     begin
      CreateWindow := 0;
      LastError := ERR_NOPARENT;
      Dispose(mNew);
      Exit;
     end;
    c := Parent^.Child;
    while c^.Brother <> nil do c:=c^.Brother;
    c^.Brother := mNew;
   end;
   Title := PString(Alloc(ord(aTitle[0])+1));
   Title^ := aTitle;
   Pos.A.x :=aX; Pos.a.y := aY; Pos.B.X := aW; Pos.B.Y := aH;

   New(Queue);
   Menu := nil;
   if aMenu <> NULL then
    begin
     Menu := wGetMenuByhMenu(aMenu);
     if Menu = nil then
      begin
       CreateWindow := 0;
       LastError := ERR_BADMENU;
       Dispose(mNew);
       Exit;       
      end;
    end;

   Queue^.Next := Nil;
   zOrder := nil;
   Next := nil;
  end;
  if mNew^.Parent = nil then
  begin
   mNew^.zOrder := TopMost^.zOrder;
   TopMost^.zOrder := mNew;
   mNew^.bActive := true;
   KeyActive := mNew;
   gActiveParent := mNew;
   gActiveWindow := mNew;
  end;
  c := AllWindows;
  while c^.next <> nil do c:=c^.next;
  c^.next := mNew;
  if (mNew^.Style AND WS_TITLE) = WS_TITLE then
    begin
     g1:=CreateWindow('','CLOSEBUTTON',WS_CHILD,
                  aW-mNew^.Palette^.ActTitleSize-2,-mNew^.Palette^.ActTitleSize+2,
                  mNew^.Palette^.ActTitleSize-5,mNew^.Palette^.ActTitleSize-5,
                  mNew^.Handle,NULL);

     if (mNew^.Style AND WS_MINMAX) = WS_MINMAX then
      begin
         g1:=CreateWindow('','MINBUTTON',WS_CHILD,
                      aW-3*mNew^.Palette^.ActTitleSize-2,-mNew^.Palette^.ActTitleSize+2,
                      mNew^.Palette^.ActTitleSize-5,mNew^.Palette^.ActTitleSize-5,
                      mNew^.Handle,NULL);
         g1:=CreateWindow('','MAXBUTTON',WS_CHILD,
                      aW-2*mNew^.Palette^.ActTitleSize-4,-mNew^.Palette^.ActTitleSize+2,
                      mNew^.Palette^.ActTitleSize-5,mNew^.Palette^.ActTitleSize-5,
                      mNew^.Handle,NULL);
      end;
    end;

  wSendMessage(mNew, WM_CREATE, 0, UINT32(mNew));
  LastError := ERR_OK;
  CreateWindow := mNew^.Handle
end;{}
{-----------------------------------}
Function SendMessage(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;
var
 c : PWindow;
begin
 c := wGetWndByhWnd(ahWnd);
 if (c=nil) then
  begin
   LastError := ERR_BADHANDLE;
   Exit;
  end;
 SendMessage := c^.WClass^.WndProc(c^.Handle,aMsg,wParam,lParam);
 LastError := ERR_OK;
end;
{-----------------------------------}
Function PostMessage(ahWnd:HWND;aMsg,wParam,lParam:UINT32):UINT32;
var
 c : PWindow;
begin
 c := wGetWndByhWnd(ahWnd);
 if c=nil then
  begin
   PostMessage := ERR_BADHANDLE;
   LastError := ERR_BADHANDLE;
   Exit;
  end;
 PostMessage := wPostMessage(c,aMsg,wParam,lParam);
 PostMessage := ERR_OK;
 LastError := ERR_OK;
end;
{-----------------------------------}
Function WindowFromPoint(aP:POINT):HWND;
var
 c : PWindow;
begin
  WindowFromPoint := NULL;
  c := wWindowFromPoint(aP);
  if c <> nil then WindowFromPoint := c^.handle;
  LastError := ERR_OK;
end; {WindowFromPoint}
{-----------------------------------}
Function ChildWindowFromPoint(aParent:hWnd;aP:POINT):HWND;
var
 c  : PWindow;
begin
  ChildWindowFromPoint := aParent;
  c := wGetWndByHWND(aParent);
  if c=nil then
   begin
    LastError := ERR_BADHANDLE;
    ChildWindowFromPoint := NULL;
    Exit;
   end;
  c := wChildWindowFromPoint(c,aP);
  if c <> nil then ChildWindowFromPoint := c^.Handle;
end; {ChildWindowFromPoint}
{-----------------------------------}
Function DefWindowProc(ahWnd:HWND;aMsg: UINT32; awParam,alParam:UINT32):UInt32;
begin
  case aMsg of
   WM_DESTROY:PostQuitMessage(ahWnd);    
   WM_SETTEXT:SetWindowText(ahWnd,PString(alParam));
   WM_GETTEXT:GetWindowText(ahWnd,PString(alParam),awParam);
  end;
end;
{-----------------------------------}
Function PostQuitMessage;
var
 aNew,c   : PWndList;
 wnd      : PWindow;
begin
  Wnd := wGetWndByHWND(ahWnd);
  if Wnd = nil then
   begin
    LastError := ERR_BADHANDLE;
    Exit;
   end;
  New(aNew);
  aNew^.Wnd := Wnd;
  aNew^.Next := nil;
  c := KillList;
  if c<>nil then
   begin
    while c^.Next <> nil do c:=c^.next;
    c^.next := aNew;
   end
  else
   KillList := aNew;
end;
{-----------------------------------------------}
Procedure GetClientRect(aH:HWND;aR:LPRECT);
var
 wnd : PWindow;
begin
 wnd:=wGetWndByHWND(aH);
 if (wnd = nil) or (aR = nil) then
  begin
   LastError := ERR_BADHANDLE;
   Exit;
  end;

 aR^.A.X:=0;
 aR^.A.Y:=0;

 aR^.B.X:=wnd^.Pos.B.X-1;
 aR^.B.Y:=wnd^.Pos.B.Y-1;

 if (wnd^.Style AND WS_CHILD) = WS_CHILD then Exit;

 if wnd^.bActive then
   begin
    Dec(aR^.B.X, 2*wnd^.Palette^.ActBorderSize);
    Dec(aR^.B.Y, 2*wnd^.Palette^.ActBorderSize);

   if (wnd^.Style AND WS_TITLE) = WS_TITLE then
      Dec(aR^.B.Y,wnd^.Palette^.ActTitleSize);
   end
  else
   begin
    Dec(aR^.B.X, 2*wnd^.Palette^.NoActBorderSize);
    Dec(aR^.B.Y, 2*wnd^.Palette^.NoActBorderSize);

    if (wnd^.Style AND WS_TITLE) = WS_TITLE then
      Dec(aR^.B.Y,wnd^.Palette^.NoActTitleSize);
   end;
end;
{-----------------------------------}
{$I GDI.inc}

Procedure GetGlobalRect(aH:HWND;aR:LPRECT);
var
 wnd, c : PWindow;
begin
  wnd := wGetWndByHWND(aH);
  if (wnd = nil) or (aR = NIL) then Exit;
  wGetGlobalRect(wnd,aR);
end;

{-----------------------------------}

Procedure GlobalToClient(aH:HWND;aX,aY:INT16;aR:LPPOINT);
var
 gR : RECT;
begin
 GetGlobalRect(aH,@gR);
 if aR = nil then exit;
 aR^.X := aX-gR.A.X;
 aR^.Y := aY-gR.A.Y;
end;

{-----------------------------------}

Function  GetParent(aH:HWND):HWND;
var
 wnd : PWindow;
begin
 GetParent := NULL;
 wnd := wGetWndByHWND(aH);
 if wnd^.Parent <> nil then 
  GetParent := wnd^.Parent^.Handle;
end;

{-----------------------------------}

Function  GetWindowText(aH:HWND;aS:PString;StrLen:UINT8):UINT8;
var
 wnd : PWindow;
begin
  wnd := wGetWndByHWND(aH);
  if (wnd = nil) OR (AS = nil) then
   begin
    GetWindowText := 0;
    LastError := ERR_BADHANDLE;
    Exit;
   end;
  aS^ := Copy(wnd^.Title^,0,StrLen);
  GetWindowText := Length(aS^);
end;

{-----------------------------------}

Function  SetWindowText(aH:HWND;aS:PString):UINT8;
var
 wnd : PWindow;
begin
  wnd := wGetWndByHWND(aH);
  if (wnd = nil) OR (AS = nil) then
   begin
    SetWindowText := 0;
    LastError := ERR_BADHANDLE;
    Exit;
   end;
  FreeMem(wnd^.Title,ord(wnd^.Title^[0])+1);
  wnd^.Title := Alloc(ord(aS^[0])+1);
  wnd^.Title^ := aS^;
  SetWindowText := Length(aS^);
  wPostMessage(wnd,WM_PAINT,0,0);
end;

{-----------------------------------}

Function  FindWindow(aT,aC : PString):HWND;
var
 wnd : PWindow;
begin
  FindWindow:=NULL;
  wnd := AllWindows^.Next;
  while (wnd <> nil) do
  begin
   if (aT <> nil) AND (aT^ = wnd^.Title^) then break;
   if (aC <> nil) AND (aC^ = wnd^.wClass^.Name^) then break;
   wnd := wnd^.next;
  end;

  if wnd <> nil then
    FindWindow := wnd^.Handle;
end;

{-----------------------------------}

Function  FindChildWindow(aH:HWND;aT,aC : PString):HWND;
var
 wnd : PWindow;
begin
  FindChildWindow:=NULL;
  wnd := wGetWndByHWND(aH);
  wnd := wnd^.Child^.Brother;
  while (wnd <> nil) do
  begin
   if (aT <> nil) AND (aT^ = wnd^.Title^) then break;
   if (aC <> nil) AND (aC^ = wnd^.wClass^.Name^) then break;
   wnd := wnd^.Brother;
  end;
  if wnd <> nil then
    FindChildWindow := wnd^.Handle;
end;

{-----------------------------------}

Function  PrintChar(SC:UINT8):boolean;
begin
  PrintChar := EScanCode(SC) in [SC_Q..SC_P,SC_A..SC_L,SC_Z..SC_M,
            SC_1..SC_0,SC_MINUS, SC_EQUAL, SC_BACKSLASH, SC_LBR,SC_RBR,
            SC_SEMICOLON,SC_AMPERSAND,SC_COMMA, SC_PERIOD, SC_SLASH,SC_SPACE];
end;
Function AddOnFrameMessage(aH:hWnd):boolean;
var
 Wnd:PWindow;
 aNew,c : PWndList;
begin
  Wnd := wGetWndByHWND(aH);
  if Wnd = nil then
   begin
    LastError := ERR_BADHANDLE;
    AddOnFrameMessage := false;
    Exit;
   end;
  New(aNew);
  aNew^.Wnd := Wnd;
  aNew^.Next := nil;
  c := OnFrameList;
  if c<>nil then
   begin
    while c^.Next <> nil do c:=c^.next;
    c^.next := aNew;
   end
  else
   OnFrameList := aNew;
  AddOnFrameMessage := true;
end;
Function  DelOnFrameMessage(aH:hWnd):boolean;
var
 Wnd : PWindow;
 c,d : PWndList;
begin
  DelOnFrameMessage := false; { Be pessimistic :) }
  Wnd := wGetWndByHWND(aH);
  if Wnd = nil then
   begin
    LastError := ERR_BADHANDLE;
    Exit;
   end;
  c := OnFrameList;
  if c = nil then exit;
  if c^.Wnd<>Wnd then
   begin
    while (C^.Next <> nil) AND (c^.Next^.Wnd <> Wnd) do c:=c^.next;
    if c^.next = nil then exit;
    d:=c^.next;
    c^.next := d^.next;
    dispose(d);
   end
  else
   begin
    OnFrameList := c^.Next;
    Dispose(C);
   end;
  DelOnFrameMessage:=true;
end;
Function  IsKeyActive(aH:HWND):Boolean;
begin
 IsKeyActive := KeyActive^.Handle = aH;
end;

END.