freepascal.compiler/rtl/inc/graph/win32.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999 by Florian Klaempfl

    This file implements the win32 gui support for the graph unit

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}


{
   Remarks:
      Colors in 16 color mode:
      ------------------------
        - the behavior of xor/or/and put isn't 100%:
          it is done using the RGB color getting from windows
          instead of the palette index!
        - palette operations aren't supported
      To solve these drawbacks, setpalette must be implemented
      by exchanging the colors in the DCs, further GetPaletteEntry
      must be used when doing xor/or/and operations
}

const
   InternalDriverName = 'WIN32GUI';

var
   savedscreen : hbitmap;
   graphrunning : boolean;
   graphdrawing : tcriticalsection;
   bitmapdc : hdc;
   oldbitmap : hgdiobj;
   mainwindow : HWnd;
   pal : ^rgbrec;
   SavePtr : pointer; { we don't use that pointer }
   MessageThreadHandle : Handle;
   MessageThreadID : DWord;
   windc : hdc;

function GetPaletteEntry(r,g,b : word) : word;

  var
     dist,i,index,currentdist : longint;

  begin
     dist:=$7fffffff;
     index:=0;
     for i:=0 to maxcolors-1 do
       begin
          currentdist:=abs(r-pal[i].red)+abs(g-pal[i].green)+
            abs(b-pal[i].blue);
          if currentdist<dist then
            begin
               index:=i;
               dist:=currentdist;
            end;
       end;
     GetPaletteEntry:=index;
  end;

procedure PutPixel16Win32GUI(x,y : integer;pixel : word);

  var
     c : colorref;

  begin
    x:=x+startxviewport;
    y:=y+startyviewport;
    { convert to absolute coordinates and then verify clipping...}
    if clippixels then
      begin
         if (x<startxviewport) or (x>(startxviewport+viewwidth)) or
           (y<StartyViewPort) or (y>(startyviewport+viewheight)) then
           exit;
      end;
    if graphrunning then
      begin
         EnterCriticalSection(graphdrawing);
         c:=RGB(pal[pixel].red,pal[pixel].green,pal[pixel].blue);
         SetPixel(bitmapdc,x,y,c);
         SetPixel(windc,x,y,c);
         LeaveCriticalSection(graphdrawing);
      end;
  end;

function GetPixel16Win32GUI(x,y : integer) : word;

  var
     c : COLORREF;

  begin
    x:=x+startxviewport;
    y:=y+startyviewport;
    { convert to absolute coordinates and then verify clipping...}
    if clippixels then
      begin
         if (x<startxviewport) or (x>(startxviewport+viewwidth)) or
           (y<StartyViewPort) or (y>(startyviewport+viewheight)) then
           exit;
      end;
    if graphrunning then
      begin
         EnterCriticalSection(graphdrawing);
         c:=Windows.GetPixel(bitmapdc,x,y);
         GetPixel16Win32GUI:=GetPaletteEntry(GetRValue(c),GetGValue(c),GetBValue(c));
         LeaveCriticalSection(graphdrawing);
      end
    else
      begin
        _graphresult:=grerror;
        exit;
      end;
  end;

procedure DirectPutPixel16Win32GUI(x,y : integer);

  var
     col : longint;
     c,c2 : COLORREF;

  begin
    if graphrunning then
      begin
         EnterCriticalSection(graphdrawing);
         case currentwritemode of
           XorPut:
             Begin
                c2:=Windows.GetPixel(bitmapdc,x,y);
                c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2;
                SetPixel(bitmapdc,x,y,c);
                SetPixel(windc,x,y,c);
             End;
           AndPut:
             Begin
                c2:=Windows.GetPixel(bitmapdc,x,y);
                c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2;
                SetPixel(bitmapdc,x,y,c);
                SetPixel(windc,x,y,c);
             End;
           OrPut:
             Begin
                c2:=Windows.GetPixel(bitmapdc,x,y);
                c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2;
                SetPixel(bitmapdc,x,y,c);
                SetPixel(windc,x,y,c);
             End
           else
             Begin
               If CurrentWriteMode<>NotPut Then
                 col:=CurrentColor
               Else col := Not(CurrentColor);
               c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
               SetPixel(bitmapdc,x,y,c);
               SetPixel(windc,x,y,c);
             End
         end;
         LeaveCriticalSection(graphdrawing);
      end;
  end;

procedure HLine16Win32GUI(x,x2,y: integer);

   var
      c,c2 : COLORREF;
      col,i : longint;
      oldpen,pen : HPEN;

   Begin
      if graphrunning then
        begin
           { must we swap the values? }
           if x>x2 then
             Begin
               x:=x xor x2;
               x2:=x xor x2;
               x:=x xor x2;
             end;
           { First convert to global coordinates }
           X:=X+StartXViewPort;
           X2:=X2+StartXViewPort;
           Y:=Y+StartYViewPort;
           if ClipPixels then
             Begin
                if LineClipped(x,y,x2,y,StartXViewPort,StartYViewPort,
                       StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
                   exit;
             end;
           Case CurrentWriteMode of
             AndPut:
               Begin
                  EnterCriticalSection(graphdrawing);
                  for i:=x to x2 do
                    begin
                       c2:=Windows.GetPixel(bitmapdc,i,y);
                       c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2;
                       SetPixel(bitmapdc,i,y,c);
                       SetPixel(windc,i,y,c);
                    end;
                  LeaveCriticalSection(graphdrawing);
               End;
             XorPut:
               Begin
                  EnterCriticalSection(graphdrawing);
                  for i:=x to x2 do
                    begin
                       c2:=Windows.GetPixel(bitmapdc,i,y);
                       c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2;
                       SetPixel(bitmapdc,i,y,c);
                       SetPixel(windc,i,y,c);
                    end;
                  LeaveCriticalSection(graphdrawing);
               End;
             OrPut:
               Begin
                  EnterCriticalSection(graphdrawing);
                  for i:=x to x2 do
                    begin
                       c2:=Windows.GetPixel(bitmapdc,i,y);
                       c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2;
                       SetPixel(bitmapdc,i,y,c);
                       SetPixel(windc,i,y,c);
                    end;
                  LeaveCriticalSection(graphdrawing);
               End
             Else
               Begin
                  If CurrentWriteMode<>NotPut Then
                    col:=CurrentColor
                  Else col:=Not(CurrentColor);
                  EnterCriticalSection(graphdrawing);
                  c:=RGB(pal[col].red,pal[col].green,pal[col].blue);
                  pen:=CreatePen(PS_SOLID,1,c);
                  oldpen:=SelectObject(bitmapdc,pen);
                  Windows.MoveToEx(bitmapdc,x,y,nil);
                  Windows.LineTo(bitmapdc,x2,y);
                  SelectObject(bitmapdc,oldpen);

                  oldpen:=SelectObject(windc,pen);
                  Windows.MoveToEx(windc,x,y,nil);
                  Windows.LineTo(windc,x2,y);
                  SelectObject(windc,oldpen);

                  DeleteObject(pen);
                  LeaveCriticalSection(graphdrawing);
               End;
           End;
        end;
   end;

procedure SetRGBPaletteWin32GUI(colorNum,redValue,greenvalue,
      bluevalue : integer);

  begin
     if directcolor or (colornum<0) or (colornum>=maxcolor) then
       begin
         _graphresult:=grerror;
         exit;
       end;
     pal[colorNum].red:=redValue;
     pal[colorNum].green:=greenValue;
     pal[colorNum].blue:=blueValue;
  end;

procedure GetRGBPaletteWin32GUI(colorNum : integer;
      var redValue,greenvalue,bluevalue : integer);

  begin
     if directcolor or (colornum<0) or (colornum>=maxcolor) then
       begin
         _graphresult:=grerror;
         exit;
       end;
     redValue:=pal[colorNum].red;
     greenValue:=pal[colorNum].green;
     blueValue:=pal[colorNum].blue;
  end;

procedure savestate;

  begin
  end;


procedure restorestate;

  begin
  end;

function WindowProc(Window: HWnd; AMessage, WParam,
                    LParam: Longint): Longint; stdcall; export;

  var
     dc : hdc;
     ps : paintstruct;
     r : rect;

begin
  WindowProc := 0;

  case AMessage of
    wm_keydown,
    wm_keyup,
    wm_char:
      if assigned(charmessagehandler) then
        WindowProc:=charmessagehandler(window,amessage,wparam,lparam);
    wm_paint:
      begin
         EnterCriticalSection(graphdrawing);
         graphrunning:=true;
         dc:=BeginPaint(Window,@ps);
         GetClientRect(Window,@r);

         if graphrunning then
           BitBlt(dc,0,0,maxx+1,maxy+1,bitmapdc,0,0,SRCCOPY);

         EndPaint(Window,ps);
         LeaveCriticalSection(graphdrawing);
         Exit;
      end;
    wm_create:
      begin
         EnterCriticalSection(graphdrawing);
         dc:=GetDC(window);
         bitmapdc:=CreateCompatibleDC(dc);
         savedscreen:=CreateCompatibleBitmap(dc,maxx+1,maxy+1);
         ReleaseDC(window,dc);
         oldbitmap:=SelectObject(bitmapdc,savedscreen);
         windc:=GetDC(window);
         LeaveCriticalSection(graphdrawing);
      end;
    wm_Destroy:
      begin
         EnterCriticalSection(graphdrawing);
         graphrunning:=false;
         ReleaseDC(mainwindow,windc);
         SelectObject(bitmapdc,oldbitmap);
         DeleteObject(savedscreen);
         DeleteDC(bitmapdc);
         LeaveCriticalSection(graphdrawing);
         PostQuitMessage(0);
         Exit;
      end
    else
      WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
  end;
end;

function WinRegister: Boolean;
var
  WindowClass: WndClass;
begin
  WindowClass.Style := cs_hRedraw or cs_vRedraw;
  WindowClass.lpfnWndProc := WndProc(@WindowProc);
  WindowClass.cbClsExtra := 0;
  WindowClass.cbWndExtra := 0;
  WindowClass.hInstance := system.MainInstance;
  WindowClass.hIcon := LoadIcon(0, idi_Application);
  WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH);
  WindowClass.lpszMenuName := nil;
  WindowClass.lpszClassName := 'MyWindow';

  winregister:=RegisterClass(WindowClass) <> 0;
end;

 { Create the Window Class }
function WinCreate: HWnd;
var
  hWindow: HWnd;
begin

  hWindow := CreateWindow('MyWindow', 'Graph window application',
              ws_OverlappedWindow, 100, 100,
              maxx+20, maxy+40, 0, 0, system.MainInstance, nil);

  if hWindow <> 0 then begin
    ShowWindow(hWindow, SW_SHOW);
    UpdateWindow(hWindow);
  end;

  wincreate:=hWindow;
end;

function MessageHandleThread(p : pointer) : DWord;StdCall;

  var
     AMessage: Msg;

  begin
     if not WinRegister then begin
       MessageBox(0, 'Register failed', nil, mb_Ok);
       Exit;
     end;
     MainWindow := WinCreate;
     if longint(mainwindow) = 0 then begin
       MessageBox(0, 'WinCreate failed', nil, mb_Ok);
       Exit;
     end;
     while GetMessage(@AMessage, 0, 0, 0) do
       begin
          TranslateMessage(AMessage);
          DispatchMessage(AMessage);
       end;
     MessageHandleThread:=0;
  end;

procedure InitWin32GUI640x480x16;

  begin
     getmem(pal,sizeof(RGBrec)*maxcolor);
     move(DefaultColors,pal^,sizeof(RGBrec)*maxcolor);
     { start graph subsystem }
     InitializeCriticalSection(graphdrawing);
     graphrunning:=false;
     MessageThreadHandle:=CreateThread(nil,0,@MessageHandleThread,
       nil,0,MessageThreadID);
     repeat until graphrunning;
  end;

procedure CloseGraph;

  begin
     If not isgraphmode then
       begin
         _graphresult := grnoinitgraph;
         exit
       end;
     WaitForSingleObject(MessageThreadHandle,Infinite);
     CloseHandle(MessageThreadHandle);
     DeleteCriticalSection(graphdrawing);
     freemem(pal,sizeof(RGBrec)*maxcolor);
  end;

{
procedure line(x1,y1,x2,y2 : longint);

  var
     pen,oldpen : hpen;
     windc : hdc;

  begin
     if graphrunning then
       begin
          EnterCriticalSection(graphdrawing);
          pen:=CreatePen(PS_SOLID,4,RGB($ff,0,0));

          oldpen:=SelectObject(bitmapdc,pen);
          MoveToEx(bitmapdc,x1,y1,nil);
          LineTo(bitmapdc,x2,y2);
          SelectObject(bitmapdc,oldpen);

          windc:=GetDC(mainwindow);
          oldpen:=SelectObject(windc,pen);
          MoveToEx(windc,x1,y1,nil);
          LineTo(windc,x2,y2);
          SelectObject(windc,oldpen);
          ReleaseDC(mainwindow,windc);

          DeleteObject(pen);
          LeaveCriticalSection(graphdrawing);
       end;
  end;

}

{ multipage support could be done by using more than one background bitmap }
procedure SetVisualWin32GUI(page: word);

  begin
  end;

procedure SetActiveWin32GUI(page: word);
  begin
  end;

function queryadapterinfo : pmodeinfo;

  var
     mode: TModeInfo;

  begin
     SaveVideoState:=savestate;
     RestoreVideoState:=restorestate;
     QueryAdapterInfo := ModeList;
     { If the mode listing already exists... }
     { simply return it, without changing    }
     { anything...                           }
     if assigned(ModeList) then
       exit;
     InitMode(mode);
     { now add all standard VGA modes...       }
     mode.DriverNumber:= VGA;
     mode.HardwarePages:= 0;
     mode.ModeNumber:=0;
     mode.ModeName:='640 x 480 Win32GUI';
     mode.MaxColor := 16;
     mode.PaletteSize := mode.MaxColor;
     mode.DirectColor := FALSE;
     mode.MaxX := 639;
     mode.MaxY := 479;
     mode.DirectPutPixel:={$ifdef fpc}@{$endif}DirectPutPixel16Win32GUI;
     mode.PutPixel:={$ifdef fpc}@{$endif}PutPixel16Win32GUI;
     mode.GetPixel:={$ifdef fpc}@{$endif}GetPixel16Win32GUI;
     mode.HLine := {$ifdef fpc}@{$endif}HLine16Win32GUI;
     mode.SetRGBPalette := {$ifdef fpc}@{$endif}SetRGBPaletteWin32GUI;
     mode.GetRGBPalette := {$ifdef fpc}@{$endif}GetRGBPaletteWin32GUI;
     mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisualWin32GUI;
     mode.SetActivePage := {$ifdef fpc}@{$endif}SetActiveWin32GUI;
     mode.InitMode := {$ifdef fpc}@{$endif}InitWin32GUI640x480x16;
     mode.XAspect := 10000;
     mode.YAspect := 10000;
     AddMode(mode);
  end;

{
  $Log$
  Revision 1.1  1999-11-03 20:23:02  florian
    + first release of win32 gui support

}