{ $Id$ This file is part of the Free Pascal run time library. Copyright (c) 1999-2000 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. **********************************************************************} unit Graph; interface uses windows; {$i graphh.inc} var { this procedure allows to hook keyboard messages } charmessagehandler : WndProc; { this procedure allows to hook mouse messages } mousemessagehandler : WndProc; { this procedure allows to wm_command messages } commandmessagehandler : WndProc; NotifyMessageHandler : WndProc; OnGraphWindowCreation : procedure; GraphWindow,ParentWindow : HWnd; // this allows direct drawing to the window bitmapdc : hdc; windc : hdc; const { predefined window style } { we shouldn't set CS_DBLCLKS here } { because most dos applications } { handle double clicks on it's own } graphwindowstyle : DWord = cs_hRedraw or cs_vRedraw; windowtitle : pchar = 'Graph window application'; menu : hmenu = 0; icon : hicon = 0; drawtoscreen : boolean = true; drawtobitmap : boolean = true; // the graph window can be a child window, this allows to add toolbars // to the main window UseChildWindow : boolean = false; // this allows to specify an offset for the child child window ChildOffset : rect = (left:0;top:0;right:0;bottom:0); CONST m640x200x16 = VGALo; m640x400x16 = VGAMed; m640x480x16 = VGAHi; { VESA Specific video modes. } m320x200x32k = $10D; m320x200x64k = $10E; m640x400x256 = $100; m640x480x256 = $101; m640x480x32k = $110; m640x480x64k = $111; m800x600x16 = $102; m800x600x256 = $103; m800x600x32k = $113; m800x600x64k = $114; m1024x768x16 = $104; m1024x768x256 = $105; m1024x768x32k = $116; m1024x768x64k = $117; m1280x1024x16 = $106; m1280x1024x256 = $107; m1280x1024x32k = $119; m1280x1024x64k = $11A; { some extra modes which applies only to GUI } mLargestWindow16 = $f0; mLargestWindow256 = $f1; mLargestWindow32k = $f2; mLargestWindow64k = $f3; mLargestWindow16M = $f4; mMaximizedWindow16 = $f5; mMaximizedWindow256 = $f6; mMaximizedWindow32k = $f7; mMaximizedWindow64k = $f8; mMaximizedWindow16M = $f9; implementation uses strings; { 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'; {$i graph.inc} { used to create a file containing all calls to WM_PAINT WARNING this probably creates HUGE files PM } { $define DEBUG_WM_PAINT} var savedscreen : hbitmap; graphrunning : boolean; graphdrawing : tcriticalsection; pens : array[0..15] of HPEN; {$ifdef DEBUG_WM_PAINT} graphdebug : text; const wm_paint_count : longint = 0; var {$endif DEBUG_WM_PAINT} oldbitmap : hgdiobj; pal : ^rgbrec; // SavePtr : pointer; { we don't use that pointer } MessageThreadHandle : Handle; MessageThreadID : DWord; function GetPaletteEntry(r,g,b : word) : word; var dist,i,index,currentdist : longint; begin dist:=$7fffffff; index:=0; for i:=0 to maxcolors do begin currentdist:=abs(r-pal[i].red)+abs(g-pal[i].green)+ abs(b-pal[i].blue); if currentdist(startxviewport+viewwidth)) or (y(startyviewport+viewheight)) then exit; end; if graphrunning then begin c:=RGB(pal[pixel].red,pal[pixel].green,pal[pixel].blue); EnterCriticalSection(graphdrawing); if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(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+viewwidth)) or (y(startyviewport+viewheight)) then exit; end; if graphrunning then begin EnterCriticalSection(graphdrawing); c:=Windows.GetPixel(bitmapdc,x,y); LeaveCriticalSection(graphdrawing); GetPixel16Win32GUI:=GetPaletteEntry(GetRValue(c),GetGValue(c),GetBValue(c)); 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); col:=CurrentColor; case currentwritemode of XorPut: Begin c2:=Windows.GetPixel(windc,x,y); c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2; if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(windc,x,y,c); End; AndPut: Begin c2:=Windows.GetPixel(windc,x,y); c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2; if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(windc,x,y,c); End; OrPut: Begin c2:=Windows.GetPixel(windc,x,y); c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2; if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(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); if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(windc,x,y,c); End end; LeaveCriticalSection(graphdrawing); end; end; var bitmapfontverticalcache : array[0..255] of HBITMAP; bitmapfonthorizoncache : array[0..255] of HBITMAP; procedure OutTextXYWin32GUI(x,y : smallint;const TextString : string); type Tpoint = record X,Y: smallint; end; var i,j,k,c : longint; xpos,ypos : longint; counter : longint; cnt1,cnt2 : smallint; cnt3,cnt4 : smallint; charsize : word; WriteMode : word; curX2, curY2, xpos2, ypos2, x2, y2: graph_float; oldvalues : linesettingstype; fontbitmap : TBitmapChar; chr : char; curx2i,cury2i, xpos2i,ypos2i : longint; charbitmap,oldcharbitmap : HBITMAP; chardc : HDC; color : longint; brushwin,oldbrushwin,brushbitmap,oldbrushbitmap : HBRUSH; bitmaprgn,winrgn : HRGN; begin { save current write mode } WriteMode := CurrentWriteMode; CurrentWriteMode := NormalPut; GetTextPosition(xpos,ypos,textstring); X:=X-XPos; Y:=Y+YPos; XPos:=X; YPos:=Y; CharSize := CurrentTextInfo.Charsize; if Currenttextinfo.font=DefaultFont then begin if CurrentTextInfo.direction=HorizDir then { Horizontal direction } begin if (x>viewwidth) or (y>viewheight) or (x<0) or (y<0) then begin CurrentWriteMode:=WriteMode; exit; end; EnterCriticalSection(graphdrawing); c:=length(textstring); chardc:=CreateCompatibleDC(windc); if currentcolor<>white then begin color:=RGB(pal[currentcolor].red,pal[currentcolor].green, pal[currentcolor].blue); if drawtoscreen then begin brushwin:=CreateSolidBrush(color); oldbrushwin:=SelectObject(windc,brushwin); end; if drawtobitmap then begin brushbitmap:=CreateSolidBrush(color); oldbrushbitmap:=SelectObject(bitmapdc,brushbitmap); end; end; inc(x,startxviewport); inc(y,startyviewport); { let windows do the clipping } if drawtobitmap then begin bitmaprgn:=CreateRectRgn(startxviewport,startyviewport, startxviewport+viewwidth+1,startyviewport+viewheight+1); SelectClipRgn(bitmapdc,bitmaprgn); end; if drawtoscreen then begin winrgn:=CreateRectRgn(startxviewport,startyviewport, startxviewport+viewwidth+1,startyviewport+viewheight+1); SelectClipRgn(windc,winrgn); end; for i:=0 to c-1 do begin xpos:=x+(i*8)*Charsize; if bitmapfonthorizoncache[byte(textstring[i+1])]=0 then begin charbitmap:=CreateCompatibleBitmap(windc,8,8); if charbitmap=0 then writeln('Bitmap konnte nicht erzeugt werden!'); oldcharbitmap:=SelectObject(chardc,charbitmap); Fontbitmap:=TBitmapChar(DefaultFontData[textstring[i+1]]); for j:=0 to 7 do for k:=0 to 7 do if Fontbitmap[j,k]<>0 then SetPixelV(chardc,k,j,$ffffff) else SetPixelV(chardc,k,j,0); bitmapfonthorizoncache[byte(textstring[i+1])]:=charbitmap; SelectObject(chardc,oldcharbitmap); end; oldcharbitmap:=SelectObject(chardc,bitmapfonthorizoncache[byte(textstring[i+1])]); if CharSize=1 then begin if currentcolor=white then begin if drawtoscreen then BitBlt(windc,xpos,y,8,8,chardc,0,0,SRCPAINT); if drawtobitmap then BitBlt(bitmapdc,xpos,y,8,8,chardc,0,0,SRCPAINT); end else begin { could we do this with one pattern operation ?? } { we would need something like DSnaSPao } if drawtoscreen then begin // ROP $00220326=DSna BitBlt(windc,xpos,y,8,8,chardc,0,0,$00220326); // ROP $00EA02E9 = DPSao BitBlt(windc,xpos,y,8,8,chardc,0,0,$00EA02E9); end; if drawtobitmap then begin BitBlt(bitmapdc,xpos,y,8,8,chardc,0,0,$00220326); BitBlt(bitmapdc,xpos,y,8,8,chardc,0,0,$00EA02E9); end; end; end else begin if currentcolor=white then begin if drawtoscreen then StretchBlt(windc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT); if drawtobitmap then StretchBlt(bitmapdc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT); end else begin { could we do this with one pattern operation ?? } { we would need something like DSnaSPao } if drawtoscreen then begin // ROP $00220326=DSna StretchBlt(windc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00220326); // ROP $00EA02E9 = DPSao StretchBlt(windc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9); end; if drawtobitmap then begin StretchBlt(bitmapdc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00220326); StretchBlt(bitmapdc,xpos,y,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9); end; end; end; SelectObject(chardc,oldcharbitmap); end; if currentcolor<>white then begin if drawtoscreen then begin SelectObject(windc,oldbrushwin); DeleteObject(brushwin); end; if drawtobitmap then begin SelectObject(bitmapdc,oldbrushbitmap); DeleteObject(brushbitmap); end; end; { release clip regions } if drawtobitmap then begin SelectClipRgn(bitmapdc,0); DeleteObject(bitmaprgn); end; if drawtoscreen then begin SelectClipRgn(windc,0); DeleteObject(winrgn); end; DeleteDC(chardc); LeaveCriticalSection(graphdrawing); end else { Vertical direction } begin if (x>viewwidth) or (y>viewheight) or (x<0) or (y<0) then begin CurrentWriteMode:=WriteMode; exit; end; EnterCriticalSection(graphdrawing); c:=length(textstring); chardc:=CreateCompatibleDC(windc); if currentcolor<>white then begin color:=RGB(pal[currentcolor].red,pal[currentcolor].green, pal[currentcolor].blue); if drawtoscreen then begin brushwin:=CreateSolidBrush(color); oldbrushwin:=SelectObject(windc,brushwin); end; if drawtobitmap then begin brushbitmap:=CreateSolidBrush(color); oldbrushbitmap:=SelectObject(bitmapdc,brushbitmap); end; end; inc(x,startxviewport); inc(y,startyviewport); { let windows do the clipping } if drawtoscreen then begin winrgn:=CreateRectRgn(startxviewport,startyviewport, startxviewport+viewwidth+1,startyviewport+viewheight+1); SelectClipRgn(windc,winrgn); end; if drawtobitmap then begin bitmaprgn:=CreateRectRgn(startxviewport,startyviewport, startxviewport+viewwidth+1,startyviewport+viewheight+1); SelectClipRgn(bitmapdc,bitmaprgn); end; for i:=0 to c-1 do begin ypos:=y+1-((i+1)*8)*CharSize; if bitmapfontverticalcache[byte(textstring[i+1])]=0 then begin charbitmap:=CreateCompatibleBitmap(windc,8,8); if charbitmap=0 then writeln('Bitmap konnte nicht erzeugt werden!'); oldcharbitmap:=SelectObject(chardc,charbitmap); Fontbitmap:=TBitmapChar(DefaultFontData[textstring[i+1]]); for j:=0 to 7 do for k:=0 to 7 do if Fontbitmap[j,k]<>0 then SetPixelV(chardc,j,7-k,$ffffff) else SetPixelV(chardc,j,7-k,0); bitmapfontverticalcache[byte(textstring[i+1])]:=charbitmap; SelectObject(chardc,oldcharbitmap); end; oldcharbitmap:=SelectObject(chardc,bitmapfontverticalcache[byte(textstring[i+1])]); if CharSize=1 then begin if currentcolor=white then begin if drawtoscreen then BitBlt(windc,x,ypos,8,8,chardc,0,0,SRCPAINT); if drawtobitmap then BitBlt(bitmapdc,x,ypos,8,8,chardc,0,0,SRCPAINT); end else begin { could we do this with one pattern operation ?? } { we would need something like DSnaSPao } if drawtoscreen then begin // ROP $00220326=DSna BitBlt(windc,x,ypos,8,8,chardc,0,0,$00220326); // ROP $00EA02E9 = DPSao BitBlt(windc,x,ypos,8,8,chardc,0,0,$00EA02E9); end; if drawtobitmap then begin BitBlt(bitmapdc,x,ypos,8,8,chardc,0,0,$00220326); BitBlt(bitmapdc,x,ypos,8,8,chardc,0,0,$00EA02E9); end; end; end else begin if currentcolor=white then begin if drawtoscreen then StretchBlt(windc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT); if drawtobitmap then StretchBlt(bitmapdc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,SRCPAINT); end else begin { could we do this with one pattern operation ?? } { we would need something like DSnaSPao } if drawtoscreen then begin // ROP $00220326=DSna StretchBlt(windc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00220326); // ROP $00EA02E9 = DPSao StretchBlt(windc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9); end; if drawtobitmap then begin StretchBlt(bitmapdc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00220326); StretchBlt(bitmapdc,x,ypos,8*charsize,8*charsize,chardc,0,0,8,8,$00EA02E9); end; end; end; SelectObject(chardc,oldcharbitmap); end; if currentcolor<>white then begin if drawtoscreen then begin SelectObject(windc,oldbrushwin); DeleteObject(brushwin); end; if drawtobitmap then begin SelectObject(bitmapdc,oldbrushbitmap); DeleteObject(brushbitmap); end; end; { release clip regions } if drawtoscreen then begin SelectClipRgn(windc,0); DeleteObject(winrgn); end; if drawtobitmap then begin SelectClipRgn(bitmapdc,0); DeleteObject(bitmaprgn); end; DeleteDC(chardc); LeaveCriticalSection(graphdrawing); end; end else { This is a stroked font which is already loaded into memory } begin getlinesettings(oldvalues); { reset line style to defaults } setlinestyle(solidln,oldvalues.pattern,normwidth); if Currenttextinfo.direction=vertdir then xpos:=xpos + Textheight(textstring); CurX2:=xpos; xpos2 := curX2; x2 := xpos2; CurY2:=ypos; ypos2 := curY2; y2 := ypos2; { x:=xpos; y:=ypos;} for i:=1 to length(textstring) do begin c:=byte(textstring[i]); { Stroke_Count[c] := } unpack( fonts[CurrentTextInfo.font].instr, fonts[CurrentTextInfo.font].Offsets[c], Strokes ); counter:=0; while true do begin if CurrentTextInfo.direction=VertDir then begin xpos2:=x2-(Strokes[counter].Y*CurrentYRatio); ypos2:=y2-(Strokes[counter].X*CurrentXRatio); end else begin xpos2:=x2+(Strokes[counter].X*CurrentXRatio) ; ypos2:=y2-(Strokes[counter].Y*CurrentYRatio) ; end; case opcodes(Strokes[counter].opcode) of _END_OF_CHAR: break; _DO_SCAN: begin { Currently unsupported }; end; _MOVE : Begin CurX2 := XPos2; CurY2 := YPos2; end; _DRAW: Begin curx2i:=trunc(CurX2); cury2i:=trunc(CurY2); xpos2i:=trunc(xpos2); ypos2i:=trunc(ypos2); { this optimization doesn't matter that much if (curx2i=xpos2i) then begin if (cury2i=ypos2i) then putpixel(curx2i,cury2i,currentcolor) else if (cury2i+1=ypos2i) or (cury2i=ypos2i+1) then begin putpixel(curx2i,cury2i,currentcolor); putpixel(curx2i,ypos2i,currentcolor); end else Line(curx2i,cury2i,xpos2i,ypos2i); end else if (cury2i=ypos2i) then begin if (curx2i+1=xpos2i) or (curx2i=xpos2i+1) then begin putpixel(curx2i,cury2i,currentcolor); putpixel(xpos2i,cury2i,currentcolor); end else Line(curx2i,cury2i,xpos2i,ypos2i); end else } Line(curx2i,cury2i,xpos2i,ypos2i); CurX2:=xpos2; CurY2:=ypos2; end; else Begin end; end; Inc(counter); end; { end while } if Currenttextinfo.direction=VertDir then y2:=y2-(byte(fonts[CurrenttextInfo.font].widths[c])*CurrentXRatio) else x2:=x2+(byte(fonts[Currenttextinfo.font].widths[c])*CurrentXRatio); end; setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness); end; { restore write mode } CurrentWriteMode := WriteMode; 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; if ClipPixels then begin if (x>ViewWidth) or (y<0) or (y>ViewHeight) or (x2<0) then exit; if x<0 then x:=0; if x2>ViewWidth then x2:=ViewWidth; end; X:=X+StartXViewPort; X2:=X2+StartXViewPort; Y:=Y+StartYViewPort; Case CurrentWriteMode of AndPut: Begin EnterCriticalSection(graphdrawing); col:=CurrentColor; for i:=x to x2 do begin c2:=Windows.GetPixel(windc,i,y); c:=RGB(pal[col].red,pal[col].green,pal[col].blue) and c2; if drawtobitmap then SetPixelV(bitmapdc,i,y,c); if drawtoscreen then SetPixelV(windc,i,y,c); end; LeaveCriticalSection(graphdrawing); End; XorPut: Begin EnterCriticalSection(graphdrawing); col:=CurrentColor; for i:=x to x2 do begin c2:=Windows.GetPixel(windc,i,y); c:=RGB(pal[col].red,pal[col].green,pal[col].blue) xor c2; if drawtobitmap then SetPixelV(bitmapdc,i,y,c); if drawtoscreen then SetPixelV(windc,i,y,c); end; LeaveCriticalSection(graphdrawing); End; OrPut: Begin EnterCriticalSection(graphdrawing); col:=CurrentColor; for i:=x to x2 do begin c2:=Windows.GetPixel(windc,i,y); c:=RGB(pal[col].red,pal[col].green,pal[col].blue) or c2; if drawtobitmap then SetPixelV(bitmapdc,i,y,c); if drawtoscreen then SetPixelV(windc,i,y,c); end; LeaveCriticalSection(graphdrawing); End Else Begin If CurrentWriteMode<>NotPut Then col:=CurrentColor Else col:=Not(CurrentColor); EnterCriticalSection(graphdrawing); if x2-x<=2 then begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); for x := x to x2 do begin if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(windc,x,y,c); end; end else begin if (col>=0) and (col<=high(pens)) then begin if pens[col]=0 then begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); pens[col]:=CreatePen(PS_SOLID,1,c); end; pen:=pens[col]; end else begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); pen:=CreatePen(PS_SOLID,1,c); end; if drawtobitmap then begin oldpen:=SelectObject(bitmapdc,pen); Windows.MoveToEx(bitmapdc,x,y,nil); Windows.LineTo(bitmapdc,x2+1,y); SelectObject(bitmapdc,oldpen); end; if drawtoscreen then begin oldpen:=SelectObject(windc,pen); Windows.MoveToEx(windc,x,y,nil); Windows.LineTo(windc,x2+1,y); SelectObject(windc,oldpen); end; if (col<0) or (col>high(pens)) then DeleteObject(pen); end; LeaveCriticalSection(graphdrawing); End; End; end; end; procedure VLine16Win32GUI(x,y,y2: smallint); {$ifndef fpc}far;{$endif fpc} var ytmp: smallint; col,c : longint; oldpen,pen : HPEN; Begin { must we swap the values? } if y >= y2 then Begin ytmp := y2; y2 := y; y:= ytmp; end; if ClipPixels then begin if (x>ViewWidth) or (x<0) or (y>ViewHeight) or (y2<0) then exit; if y<0 then y:=0; if y2>ViewHeight then y2:=ViewHeight; end; { First convert to global coordinates } X := X + StartXViewPort; Y2 := Y2 + StartYViewPort; Y := Y + StartYViewPort; if currentwritemode=normalput then begin col:=CurrentColor; EnterCriticalSection(graphdrawing); if y2-y<=2 then begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); for y := y to y2 do begin if drawtobitmap then SetPixelV(bitmapdc,x,y,c); if drawtoscreen then SetPixelV(windc,x,y,c); end; end else begin if (col>=0) and (col<=high(pens)) then begin if pens[col]=0 then begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); pens[col]:=CreatePen(PS_SOLID,1,c); end; pen:=pens[col]; end else begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); pen:=CreatePen(PS_SOLID,1,c); end; if drawtobitmap then begin oldpen:=SelectObject(bitmapdc,pen); Windows.MoveToEx(bitmapdc,x,y,nil); Windows.LineTo(bitmapdc,x,y2+1); SelectObject(bitmapdc,oldpen); end; if drawtoscreen then begin oldpen:=SelectObject(windc,pen); Windows.MoveToEx(windc,x,y,nil); Windows.LineTo(windc,x,y2+1); SelectObject(windc,oldpen); end; if (col<0) or (col>high(pens)) then DeleteObject(pen); end; LeaveCriticalSection(graphdrawing); end else for y := y to y2 do Directputpixel(x,y) End; procedure Circle16Win32GUI(X, Y: smallint; Radius:Word); var bitmaprgn,winrgn : HRGN; col,c : longint; oldpen,pen : HPEN; OriginalArcInfo: ArcCoordsType; OldWriteMode: word; begin if (Radius = 0) then Exit; if (Radius = 1) then begin { only normal put mode is supported by a call to PutPixel } PutPixel(X, Y, CurrentColor); Exit; end; if (Radius = 2) then begin { only normal put mode is supported by a call to PutPixel } PutPixel(X-1, Y, CurrentColor); PutPixel(X+1, Y, CurrentColor); PutPixel(X, Y-1, CurrentColor); PutPixel(X, Y+1, CurrentColor); Exit; end; if LineInfo.Thickness = Normwidth then begin EnterCriticalSection(graphdrawing); { let windows do the clipping } if drawtobitmap then begin bitmaprgn:=CreateRectRgn(startxviewport,startyviewport, startxviewport+viewwidth+1,startyviewport+viewheight+1); SelectClipRgn(bitmapdc,bitmaprgn); end; if drawtoscreen then begin winrgn:=CreateRectRgn(startxviewport,startyviewport, startxviewport+viewwidth+1,startyviewport+viewheight+1); SelectClipRgn(windc,winrgn); end; inc(x,StartXViewPort); inc(y,StartYViewPort); col:=CurrentColor; if (col>=0) and (col<=high(pens)) then begin if pens[col]=0 then begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); pens[col]:=CreatePen(PS_SOLID,1,c); end; pen:=pens[col]; end else begin c:=RGB(pal[col].red,pal[col].green,pal[col].blue); pen:=CreatePen(PS_SOLID,1,c); end; if drawtobitmap then begin oldpen:=SelectObject(bitmapdc,pen); windows.arc(bitmapdc,x-radius,y-radius,x+radius,y+radius, x,y-radius,x,y-radius); SelectObject(bitmapdc,oldpen); end; if drawtoscreen then begin oldpen:=SelectObject(windc,pen); windows.arc(windc,x-radius,y-radius,x+radius,y+radius, x,y-radius,x,y-radius); SelectObject(windc,oldpen); end; if (col<0) or (col>high(pens)) then DeleteObject(pen); { release clip regions } if drawtoscreen then begin SelectClipRgn(windc,0); DeleteObject(winrgn); end; if drawtobitmap then begin SelectClipRgn(bitmapdc,0); DeleteObject(bitmaprgn); end; LeaveCriticalSection(graphdrawing); end else begin { save state of arc information } { because it is not needed for } { a circle call. } move(ArcCall,OriginalArcInfo, sizeof(ArcCall)); InternalEllipse(X,Y,Radius,Radius,0,360,{$ifdef fpc}@{$endif}DummyPatternLine); { restore arc information } move(OriginalArcInfo, ArcCall,sizeof(ArcCall)); end; end; { Procedure PutImageWin32GUI(X,Y: smallint; var Bitmap; BitBlt: Word); {$ifndef fpc}far;{$endif fpc} type pt = array[0..$fffffff] of word; ptw = array[0..2] of longint; var k: longint; oldCurrentColor: word; oldCurrentWriteMode, i, j, y1, x1, deltaX, deltaX1, deltaY: smallint; Begin {$ifdef logging} LogLn('putImage at ('+strf(x)+','+strf(y)+') with width '+strf(ptw(Bitmap)[0])+ ' and height '+strf(ptw(Bitmap)[1])); deltaY := 0; {$endif logging} inc(x,startXViewPort); inc(y,startYViewPort); x1 := ptw(Bitmap)[0]+x; { get width and adjust end coordinate accordingly } y1 := ptw(Bitmap)[1]+y; { get height and adjust end coordinate accordingly } deltaX := 0; deltaX1 := 0; k := 3 * sizeOf(Longint) div sizeOf(Word); { Three reserved longs at start of bitmap } { check which part of the image is in the viewport } if clipPixels then begin if y < startYViewPort then begin deltaY := startYViewPort - y; inc(k,(x1-x+1)*deltaY); y := startYViewPort; end; if y1 > startYViewPort+viewHeight then y1 := startYViewPort+viewHeight; if x < startXViewPort then begin deltaX := startXViewPort-x; x := startXViewPort; end; if x1 > startXViewPort + viewWidth then begin deltaX1 := x1 - (startXViewPort + viewWidth); x1 := startXViewPort + viewWidth; end; end; {$ifdef logging} LogLn('deltax: '+strf(deltax)+', deltax1: '+strf(deltax1)+',deltay: '+strf(deltay)); {$endif logging} case bitBlt of end; oldCurrentColor := currentColor; oldCurrentWriteMode := currentWriteMode; currentWriteMode := bitBlt; for j:=Y to Y1 do Begin inc(k,deltaX); for i:=X to X1 do begin currentColor := pt(bitmap)[k]; directPutPixel(i,j); inc(k); end; inc(k,deltaX1); end; currentWriteMode := oldCurrentWriteMode; currentColor := oldCurrentColor; 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; if (colorNum>=0) and (colorNum<=high(pens)) and (pens[colorNum]<>0) then begin DeleteObject(pens[colorNum]); pens[colorNum]:=0; end; 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 WindowProcGraph(Window: HWnd; AMessage:UInt; WParam : WParam; LParam: LParam): Longint; stdcall; var dc : hdc; ps : paintstruct; r : rect; oldbrush : hbrush; oldpen : hpen; i : longint; begin WindowProcGraph := 0; case AMessage of wm_lbuttondown, wm_rbuttondown, wm_mbuttondown, wm_lbuttonup, wm_rbuttonup, wm_mbuttonup, wm_lbuttondblclk, wm_rbuttondblclk, wm_mbuttondblclk: { This leads to problem, i.e. the menu etc doesn't work any longer wm_nclbuttondown, wm_ncrbuttondown, wm_ncmbuttondown, wm_nclbuttonup, wm_ncrbuttonup, wm_ncmbuttonup, wm_nclbuttondblclk, wm_ncrbuttondblclk, wm_ncmbuttondblclk: } begin if assigned(mousemessagehandler) then WindowProcGraph:=mousemessagehandler(window,amessage,wparam,lparam); end; wm_notify: begin if assigned(notifymessagehandler) then WindowProcGraph:=notifymessagehandler(window,amessage,wparam,lparam); end; wm_command: if assigned(commandmessagehandler) then WindowProcGraph:=commandmessagehandler(window,amessage,wparam,lparam); wm_keydown, wm_keyup, wm_char: begin if assigned(charmessagehandler) then WindowProcGraph:=charmessagehandler(window,amessage,wparam,lparam); end; wm_paint: begin {$ifdef DEBUG_WM_PAINT} inc(wm_paint_count); {$endif DEBUG_WM_PAINT} {$ifdef DEBUGCHILDS} writeln('Start child painting'); {$endif DEBUGCHILDS} if not GetUpdateRect(Window,@r,false) then exit; EnterCriticalSection(graphdrawing); graphrunning:=true; dc:=BeginPaint(Window,@ps); {$ifdef DEBUG_WM_PAINT} Writeln(graphdebug,'WM_PAINT in ((',r.left,',',r.top, '),(',r.right,',',r.bottom,'))'); {$endif def DEBUG_WM_PAINT} if graphrunning then {BitBlt(dc,0,0,maxx+1,maxy+1,bitmapdc,0,0,SRCCOPY);} BitBlt(dc,r.left,r.top,r.right-r.left+1,r.bottom-r.top+1,bitmapdc,r.left,r.top,SRCCOPY); EndPaint(Window,ps); LeaveCriticalSection(graphdrawing); Exit; end; wm_create: begin {$ifdef DEBUG_WM_PAINT} assign(graphdebug,'wingraph.log'); rewrite(graphdebug); {$endif DEBUG_WM_PAINT} {$ifdef DEBUGCHILDS} writeln('Creating window (HWND: ',window,')... '); {$endif DEBUGCHILDS} GraphWindow:=window; EnterCriticalSection(graphdrawing); dc:=GetDC(window); {$ifdef DEBUGCHILDS} writeln('Window DC: ',dc); {$endif DEBUGCHILDS} bitmapdc:=CreateCompatibleDC(dc); savedscreen:=CreateCompatibleBitmap(dc,maxx+1,maxy+1); ReleaseDC(window,dc); oldbitmap:=SelectObject(bitmapdc,savedscreen); windc:=GetDC(window); // clear everything oldpen:=SelectObject(bitmapdc,GetStockObject(BLACK_PEN)); oldbrush:=SelectObject(bitmapdc,GetStockObject(BLACK_BRUSH)); Windows.Rectangle(bitmapdc,0,0,maxx,maxy); SelectObject(bitmapdc,oldpen); SelectObject(bitmapdc,oldbrush); // ... the window too oldpen:=SelectObject(windc,GetStockObject(BLACK_PEN)); oldbrush:=SelectObject(windc,GetStockObject(BLACK_BRUSH)); Windows.Rectangle(windc,0,0,maxx,maxy); SelectObject(windc,oldpen); SelectObject(windc,oldbrush); // clear font cache fillchar(bitmapfonthorizoncache,sizeof(bitmapfonthorizoncache),0); fillchar(bitmapfontverticalcache,sizeof(bitmapfontverticalcache),0); // clear predefined pens fillchar(pens,sizeof(pens),0); if assigned(OnGraphWindowCreation) then OnGraphWindowCreation; LeaveCriticalSection(graphdrawing); {$ifdef DEBUGCHILDS} writeln('done'); GetClientRect(window,@r); writeln('Window size: ',r.right,',',r.bottom); {$endif DEBUGCHILDS} end; wm_Destroy: begin EnterCriticalSection(graphdrawing); graphrunning:=false; ReleaseDC(GraphWindow,windc); SelectObject(bitmapdc,oldbitmap); DeleteObject(savedscreen); DeleteDC(bitmapdc); // release font cache for i:=0 to 255 do if bitmapfonthorizoncache[i]<>0 then DeleteObject(bitmapfonthorizoncache[i]); for i:=0 to 255 do if bitmapfontverticalcache[i]<>0 then DeleteObject(bitmapfontverticalcache[i]); for i:=0 to high(pens) do if pens[i]<>0 then DeleteObject(pens[i]); LeaveCriticalSection(graphdrawing); {$ifdef DEBUG_WM_PAINT} close(graphdebug); {$endif DEBUG_WM_PAINT} PostQuitMessage(0); Exit; end else WindowProcGraph := DefWindowProc(Window, AMessage, WParam, LParam); end; end; function WindowProcParent(Window: HWnd; AMessage:UInt; WParam : WParam; LParam: LParam): Longint; stdcall; begin WindowProcParent := 0; case AMessage of wm_keydown, wm_keyup, wm_char: begin if assigned(charmessagehandler) then WindowProcParent:=charmessagehandler(window,amessage,wparam,lparam); end; wm_notify: begin if assigned(notifymessagehandler) then WindowProcParent:=notifymessagehandler(window,amessage,wparam,lparam); end; wm_command: if assigned(commandmessagehandler) then WindowProcParent:=commandmessagehandler(window,amessage,wparam,lparam); else WindowProcParent := DefWindowProc(Window, AMessage, WParam, LParam); end; end; function WinRegister: Boolean; var WindowClass: WndClass; begin WindowClass.Style := graphwindowstyle; WindowClass.lpfnWndProc := WndProc(@WindowProcGraph); WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := 0; WindowClass.hInstance := system.MainInstance; if icon<>0 then WindowClass.hIcon := icon else WindowClass.hIcon := LoadIcon(0, idi_Application); WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH); if menu<>0 then WindowClass.lpszMenuName := MAKEINTRESOURCE(menu) else WindowClass.lpszMenuName := nil; WindowClass.lpszClassName := 'FPCGraphWindow'; winregister:=RegisterClass(WindowClass) <> 0; end; function WinRegisterWithChild: Boolean; var WindowClass: WndClass; begin WindowClass.Style := graphwindowstyle; WindowClass.lpfnWndProc := WndProc(@WindowProcParent); WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := 0; WindowClass.hInstance := system.MainInstance; if icon<>0 then WindowClass.hIcon := icon else WindowClass.hIcon := LoadIcon(0, idi_Application); WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH); if menu<>0 then WindowClass.lpszMenuName := MAKEINTRESOURCE(menu) else WindowClass.lpszMenuName := nil; WindowClass.lpszClassName := 'FPCGraphWindowMain'; WinRegisterWithChild:=RegisterClass(WindowClass) <> 0; {$ifdef DEBUGCHILDS} writeln('Main window successfully registered: WinRegisterWithChild is ',WinRegisterWithChild); {$endif DEBUGCHILDS} if WinRegisterWithChild then begin WindowClass.Style := CS_HREDRAW or CS_VREDRAW; WindowClass.lpfnWndProc := WndProc(@WindowProcGraph); WindowClass.cbClsExtra := 0; WindowClass.cbWndExtra := 0; WindowClass.hInstance := system.MainInstance; WindowClass.hIcon := 0; WindowClass.hCursor := LoadCursor(0, idc_Arrow); WindowClass.hbrBackground := GetStockObject(BLACK_BRUSH); WindowClass.lpszMenuName := nil; WindowClass.lpszClassName := 'FPCGraphWindowChild'; WinRegisterWithChild:=RegisterClass(WindowClass)<>0; {$ifdef DEBUGCHILDS} writeln('Child window registered: WinRegisterWithChild is ',WinRegisterWithChild); {$endif DEBUGCHILDS} end; end; var // here we can force the creation of a maximized window } extrastyle : cardinal; { Create the Window Class } function WinCreate : HWnd; var hWindow: HWnd; begin WinCreate:=0; if UseChildWindow then begin ParentWindow:=CreateWindow('FPCGraphWindowMain', windowtitle, WS_OVERLAPPEDWINDOW or WS_CLIPCHILDREN or extrastyle, longint(CW_USEDEFAULT), 0, maxx+ChildOffset.Left+ChildOffset.Right+1+ 2*GetSystemMetrics(SM_CXFRAME), maxy+ChildOffset.Top+ChildOffset.Bottom+1+ 2*GetSystemMetrics(SM_CYFRAME)+ GetSystemMetrics(SM_CYCAPTION), 0, 0, system.MainInstance, nil); if ParentWindow<>0 then begin ShowWindow(ParentWindow, SW_SHOW); UpdateWindow(ParentWindow); end else exit; hWindow:=CreateWindow('FPCGraphWindowChild',nil, WS_CHILD, ChildOffset.Left,ChildOffset.Top, maxx+1,maxy+1, ParentWindow, 0, system.MainInstance, nil); if hwindow<>0 then begin ShowWindow(hwindow, SW_SHOW); UpdateWindow(hwindow); end else exit; WinCreate:=hWindow; end else begin hWindow:=CreateWindow('FPCGraphWindow', windowtitle, ws_OverlappedWindow or extrastyle, longint(CW_USEDEFAULT), 0, maxx+1+2*GetSystemMetrics(SM_CXFRAME), maxy+1+2*GetSystemMetrics(SM_CYFRAME)+ GetSystemMetrics(SM_CYCAPTION), 0, 0, system.MainInstance, nil); if hWindow <> 0 then begin ShowWindow(hWindow, SW_SHOW); UpdateWindow(hWindow); WinCreate:=hWindow; end; end; end; const winregistered : boolean = false; function MessageHandleThread(p : pointer) : DWord;StdCall; var AMessage: Msg; begin if not(winregistered) then begin if UseChildWindow then begin if not(WinRegisterWithChild) then begin MessageBox(0, 'Window registration failed', nil, mb_Ok); ExitThread(1); end; end else begin if not(WinRegister) then begin MessageBox(0, 'Window registration failed', nil, mb_Ok); ExitThread(1); end; end; GraphWindow:=WinCreate; winregistered:=true; end; if longint(GraphWindow) = 0 then begin MessageBox(0, 'Window creation failed', nil, mb_Ok); ExitThread(1); end; while longint(GetMessage(@AMessage, 0, 0, 0))=longint(true) do begin TranslateMessage(AMessage); DispatchMessage(AMessage); end; MessageHandleThread:=0; end; procedure InitWin32GUI16colors; var threadexitcode : longint; begin getmem(pal,sizeof(RGBrec)*maxcolor); move(DefaultColors,pal^,sizeof(RGBrec)*maxcolor); if (IntCurrentMode=mMaximizedWindow16) or (IntCurrentMode=mMaximizedWindow256) or (IntCurrentMode=mMaximizedWindow32k) or (IntCurrentMode=mMaximizedWindow64k) or (IntCurrentMode=mMaximizedWindow16M) then extrastyle:=ws_maximize else extrastyle:=0; { start graph subsystem } InitializeCriticalSection(graphdrawing); graphrunning:=false; MessageThreadHandle:=CreateThread(nil,0,@MessageHandleThread, nil,0,MessageThreadID); repeat GetExitCodeThread(MessageThreadHandle,@threadexitcode); until graphrunning or (threadexitcode<>STILL_ACTIVE); if threadexitcode<>STILL_ACTIVE then _graphresult := grerror; end; procedure CloseGraph; begin If not isgraphmode then begin _graphresult := grnoinitgraph; exit end; if UseChildWindow then begin { if the child window isn't destroyed } { the main window can't be closed } { I don't know any other way (FK) } PostMessage(GraphWindow,wm_destroy,0,0); PostMessage(ParentWindow,wm_destroy,0,0) end else PostMessage(GraphWindow,wm_destroy,0,0); PostThreadMessage(MessageThreadHandle,wm_quit,0,0); WaitForSingleObject(MessageThreadHandle,Infinite); CloseHandle(MessageThreadHandle); DeleteCriticalSection(graphdrawing); freemem(pal,sizeof(RGBrec)*maxcolor); end; procedure LineWin32GUI(X1, Y1, X2, Y2: smallint); {$ifndef fpc}far;{$endif fpc} var X, Y : smallint; deltax, deltay : smallint; d, dinc1, dinc2: smallint; xinc1 : smallint; xinc2 : smallint; yinc1 : smallint; yinc2 : smallint; i : smallint; Flag : Boolean; { determines pixel direction in thick lines } NumPixels : smallint; PixelCount : smallint; OldCurrentColor: Word; swtmp : smallint; TmpNumPixels : smallint; col : longint; pen,oldpen : hpen; begin if graphrunning then begin {******************************************} { SOLID LINES } {******************************************} if lineinfo.LineStyle = SolidLn then Begin { Convert to global coordinates. } x1 := x1 + StartXViewPort; x2 := x2 + StartXViewPort; y1 := y1 + StartYViewPort; y2 := y2 + StartYViewPort; { if fully clipped then exit... } if ClipPixels then begin if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort, StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then exit; If LineInfo.Thickness=NormWidth then Begin EnterCriticalSection(graphdrawing); { if currentwritemode<>normalput then begin case currentwritemode of XORPut: begin SetROP2(windc,R2_XORPEN); SetROP2(bitmapdc,R2_XORPEN); end; AndPut: begin SetROP2(windc,R2_MASKPEN); SetROP2(bitmapdc,R2_MASKPEN); end; OrPut: begin SetROP2(windc,R2_MERGEPEN); SetROP2(bitmapdc,R2_MERGEPEN); end; end; end; } col:=RGB(pal[CurrentColor].red,pal[CurrentColor].green,pal[CurrentColor].blue); pen:=CreatePen(PS_SOLID,1,col); if pen=0 then writeln('Pen konnte nicht erzeugt werden!'); oldpen:=SelectObject(windc,pen); MoveToEx(windc,x1,y1,nil); Windows.LineTo(windc,x2,y2); SetPixel(windc,x2,y2,col); SelectObject(windc,oldpen); oldpen:=SelectObject(bitmapdc,pen); MoveToEx(bitmapdc,x1,y1,nil); Windows.LineTo(bitmapdc,x2,y2); SetPixel(bitmapdc,x2,y2,col); SelectObject(bitmapdc,oldpen); DeleteObject(pen); { if currentwritemode<>normalput then begin SetROP2(windc,R2_COPYPEN); SetROP2(bitmapdc,R2_COPYPEN); end; } LeaveCriticalSection(graphdrawing); end else { Thick width lines } begin { Draw the pixels } for i := 1 to numpixels do begin { all depending on the slope, we can determine } { in what direction the extra width pixels will be put } If Flag then Begin DirectPutPixelClip(x-1,y); DirectPutPixelClip(x,y); DirectPutPixelClip(x+1,y); end else Begin DirectPutPixelClip(x, y-1); DirectPutPixelClip(x, y); DirectPutPixelClip(x, y+1); end; if d < 0 then begin d := d + dinc1; x := x + xinc1; y := y + yinc1; end else begin d := d + dinc2; x := x + xinc2; y := y + yinc2; end; end; end; end; end else {******************************************} { begin patterned lines } {******************************************} Begin { Convert to global coordinates. } x1 := x1 + StartXViewPort; x2 := x2 + StartXViewPort; y1 := y1 + StartYViewPort; y2 := y2 + StartYViewPort; { if fully clipped then exit... } if ClipPixels then begin if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort, StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then exit; end; OldCurrentColor := CurrentColor; PixelCount:=0; if y1 = y2 then Begin { Check if we must swap } if x1 >= x2 then Begin swtmp := x1; x1 := x2; x2 := swtmp; end; if LineInfo.Thickness = NormWidth then Begin for PixelCount:=x1 to x2 do { optimization: PixelCount mod 16 } if LinePatterns[PixelCount and 15] = TRUE then begin DirectPutPixel(PixelCount,y2); end; end else Begin for i:=-1 to 1 do Begin for PixelCount:=x1 to x2 do { Optimization from Thomas - mod 16 = and 15 } {this optimization has been performed by the compiler for while as well (JM)} if LinePatterns[PixelCount and 15] = TRUE then begin DirectPutPixelClip(PixelCount,y2+i); end; end; end; end else if x1 = x2 then Begin { Check if we must swap } if y1 >= y2 then Begin swtmp := y1; y1 := y2; y2 := swtmp; end; if LineInfo.Thickness = NormWidth then Begin for PixelCount:=y1 to y2 do { compare if we should plot a pixel here , compare } { with predefined line patterns... } if LinePatterns[PixelCount and 15] = TRUE then begin DirectPutPixel(x1,PixelCount); end; end else Begin for i:=-1 to 1 do Begin for PixelCount:=y1 to y2 do { compare if we should plot a pixel here , compare } { with predefined line patterns... } if LinePatterns[PixelCount and 15] = TRUE then begin DirectPutPixelClip(x1+i,PixelCount); end; end; end; end else Begin oldCurrentColor := CurrentColor; { Calculate deltax and deltay for initialisation } deltax := abs(x2 - x1); deltay := abs(y2 - y1); { Initialize all vars based on which is the independent variable } if deltax >= deltay then begin Flag := FALSE; { x is independent variable } numpixels := deltax + 1; d := (2 * deltay) - deltax; dinc1 := deltay Shl 1; dinc2 := (deltay - deltax) shl 1; xinc1 := 1; xinc2 := 1; yinc1 := 0; yinc2 := 1; end else begin Flag := TRUE; { y is independent variable } numpixels := deltay + 1; d := (2 * deltax) - deltay; dinc1 := deltax Shl 1; dinc2 := (deltax - deltay) shl 1; xinc1 := 0; xinc2 := 1; yinc1 := 1; yinc2 := 1; end; { Make sure x and y move in the right directions } if x1 > x2 then begin xinc1 := - xinc1; xinc2 := - xinc2; end; if y1 > y2 then begin yinc1 := - yinc1; yinc2 := - yinc2; end; { Start drawing at } x := x1; y := y1; If LineInfo.Thickness=ThickWidth then Begin TmpNumPixels := NumPixels-1; { Draw the pixels } for i := 0 to TmpNumPixels do begin { all depending on the slope, we can determine } { in what direction the extra width pixels will be put } If Flag then Begin { compare if we should plot a pixel here , compare } { with predefined line patterns... } if LinePatterns[i and 15] = TRUE then begin DirectPutPixelClip(x-1,y); DirectPutPixelClip(x,y); DirectPutPixelClip(x+1,y); end; end else Begin { compare if we should plot a pixel here , compare } { with predefined line patterns... } if LinePatterns[i and 15] = TRUE then begin DirectPutPixelClip(x,y-1); DirectPutPixelClip(x,y); DirectPutPixelClip(x,y+1); end; end; if d < 0 then begin d := d + dinc1; x := x + xinc1; y := y + yinc1; end else begin d := d + dinc2; x := x + xinc2; y := y + yinc2; end; end; end else Begin { instead of putting in loop , substract by one now } TmpNumPixels := NumPixels-1; { NormWidth } for i := 0 to TmpNumPixels do begin if LinePatterns[i and 15] = TRUE then begin DirectPutPixel(x,y); end; if d < 0 then begin d := d + dinc1; x := x + xinc1; y := y + yinc1; end else begin d := d + dinc2; x := x + xinc2; y := y + yinc2; end; end; end end; {******************************************} { end patterned lines } {******************************************} { restore color } CurrentColor:=OldCurrentColor; end; end; end; { Line } { 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; ScreenWidth,ScreenHeight : longint; ScreenWidthMaximized,ScreenHeightMaximized : longint; procedure SetupWin32GUIDefault; begin 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}InitWin32GUI16colors; mode.OuttextXY:={$ifdef fpc}@{$endif}OuttextXYWin32GUI; mode.VLine := {$ifdef fpc}@{$endif}VLine16Win32GUI; // mode.circle := {$ifdef fpc}@{$endif}Circle16Win32GUI; // doesn't work yet // mode.Line:={$ifdef fpc}@{$endif}LineWin32GUI; end; begin SaveVideoState:={$ifdef fpc}@{$endif}savestate; RestoreVideoState:={$ifdef fpc}@{$endif}restorestate; { we must take care of the border and caption } ScreenWidth:=GetSystemMetrics(SM_CXSCREEN)- 2*GetSystemMetrics(SM_CXFRAME); ScreenHeight:=GetSystemMetrics(SM_CYSCREEN)- 2*GetSystemMetrics(SM_CYFRAME)- GetSystemMetrics(SM_CYCAPTION); { for maximozed windows it's again different } { here we've only a caption } ScreenWidthMaximized:=GetSystemMetrics(SM_CXFULLSCREEN); { neither GetSystemMetrics(SM_CYFULLSCREEN nor } { SystemParametersInfo(SPI_GETWORKAREA) } { takes a hidden try into account :( FK } ScreenHeightMaximized:=GetSystemMetrics(SM_CYFULLSCREEN); QueryAdapterInfo := ModeList; { If the mode listing already exists... } { simply return it, without changing } { anything... } if assigned(ModeList) then exit; { the first one becomes the standard mode } if (ScreenWidth>=640) and (ScreenHeight>=480) then begin InitMode(mode); mode.DriverNumber:= VGA; mode.HardwarePages:= 0; mode.ModeNumber:=VGAHi; mode.ModeName:='640 x 480 x 16 Win32GUI'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 639; mode.MaxY := 479; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; if (ScreenWidth>=640) and (ScreenHeight>=200) then begin InitMode(mode); { now add all standard VGA modes... } mode.DriverNumber:= VGA; mode.HardwarePages:= 0; mode.ModeNumber:=VGALo; mode.ModeName:='640 x 200 x 16 Win32GUI'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 639; mode.MaxY := 199; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; if (ScreenWidth>=640) and (ScreenHeight>=350) then begin InitMode(mode); mode.DriverNumber:= VGA; mode.HardwarePages:= 0; mode.ModeNumber:=VGAMed; mode.ModeName:='640 x 350 x 16 Win32GUI'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 639; mode.MaxY := 349; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; if (ScreenWidth>=640) and (ScreenHeight>=400) then begin InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m640x400x256; mode.ModeName:='640 x 400 x 256 Win32GUI'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 639; mode.MaxY := 399; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; if (ScreenWidth>=640) and (ScreenHeight>=480) then begin InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m640x480x256; mode.ModeName:='640 x 480 x 256 Win32GUI'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 639; mode.MaxY := 479; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; { add 800x600 only if screen is large enough } If (ScreenWidth>=800) and (ScreenHeight>=600) then begin InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m800x600x16; mode.ModeName:='800 x 600 x 16 Win32GUI'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 799; mode.MaxY := 599; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m800x600x256; mode.ModeName:='800 x 600 x 256 Win32GUI'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 799; mode.MaxY := 599; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; { add 1024x768 only if screen is large enough } If (ScreenWidth>=1024) and (ScreenHeight>=768) then begin InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m1024x768x16; mode.ModeName:='1024 x 768 x 16 Win32GUI'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 1023; mode.MaxY := 767; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m1024x768x256; mode.ModeName:='1024 x 768 x 256 Win32GUI'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 1023; mode.MaxY := 768; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; { add 1280x1024 only if screen is large enough } If (ScreenWidth>=1280) and (ScreenHeight>=1024) then begin InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m1280x1024x16; mode.ModeName:='1280 x 1024 x 16 Win32GUI'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 1279; mode.MaxY := 1023; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=m1280x1024x256; mode.ModeName:='1280 x 1024 x 256 Win32GUI'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := 1279; mode.MaxY := 1023; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; { at least we add a mode with the largest possible window } InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=mLargestWindow16; mode.ModeName:='Largest Window x 16'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := ScreenWidth-1; mode.MaxY := ScreenHeight-1; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=mLargestWindow256; mode.ModeName:='Largest Window x 256'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := ScreenWidth-1; mode.MaxY := ScreenHeight-1; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); { .. and a maximized window } InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=mMaximizedWindow16; mode.ModeName:='Maximized Window x 16'; mode.MaxColor := 16; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := ScreenWidthMaximized-1; mode.MaxY := ScreenHeightMaximized-1; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); InitMode(mode); mode.DriverNumber:= VESA; mode.HardwarePages:= 0; mode.ModeNumber:=mMaximizedWindow256; mode.ModeName:='Maximized Window x 256'; mode.MaxColor := 256; mode.PaletteSize := mode.MaxColor; mode.DirectColor := FALSE; mode.MaxX := ScreenWidthMaximized-1; mode.MaxY := ScreenHeightMaximized-1; SetupWin32GUIDefault; mode.XAspect := 10000; mode.YAspect := 10000; AddMode(mode); end; begin InitializeGraph; charmessagehandler:=nil; mousemessagehandler:=nil; commandmessagehandler:=nil; notifymessagehandler:=nil; OnGraphWindowCreation:=nil; end. { $Log$ Revision 1.12 2003-04-23 11:35:00 peter * wndproc definition fixed Revision 1.11 2003/04/23 11:08:09 florian * fixed parameter types Revision 1.10 2002/09/07 16:01:28 peter * old logs removed and tabs fixed Revision 1.9 2002/01/06 15:37:20 florian * log fixed Revision 1.8 2002/01/06 15:23:42 florian * SetRGBColor with cached pens fixed }