IMPLEMENTATION MODULE wingraphics; FROM SYSTEM IMPORT ADR, ADDRESS, CAST, MOVE; FROM ExStorage IMPORT ALLOCATE, DEALLOCATE; FROM MemUtils IMPORT FillMemBYTE; FROM Strings IMPORT Equal; FROM RealMath IMPORT cos, sin, pi,round; FROM WIN32 IMPORT *; FROM WINUSER IMPORT MSG,GetMessage,TranslateMessage,DispatchMessage,GetSystemMetrics,SM_CXFIXEDFRAME,SM_CYFIXEDFRAME, SM_CYCAPTION,WS_OVERLAPPED,WS_SYSMENU,WS_CAPTION,WS_MINIMIZEBOX,WS_POPUP,GetDC,GetDesktopWindow,PAINTSTRUCT,WM_CREATE, GetClientRect,WM_ERASEBKGND,WM_PAINT,GetUpdateRect,BeginPaint,EndPaint,WM_CHAR,WM_KEYDOWN,WM_SYSKEYDOWN,WM_SYSCHAR, WM_MOUSEWHEEL,WM_MOUSEMOVE,WM_LBUTTONDOWN,WM_RBUTTONDOWN,WM_MBUTTONDOWN,WM_LBUTTONUP,WM_RBUTTONUP,WM_MBUTTONUP,WM_CLOSE, WM_DESTROY,PostQuitMessage,WM_USER,DestroyWindow,DefWindowProc,WNDCLASS,CS_OWNDC,CS_BYTEALIGNCLIENT,LoadIcon,LoadCursor, IDC_ARROW,COLOR_MENU,RegisterClass,CW_USEDEFAULT,CreateWindow,UnregisterClass,PostMessage,ShowWindow,SW_SHOW, SetForegroundWindow,SW_HIDE,SW_SHOWNORMAL,SetRect,InvalidateRect,LOBYTE,GetKeyState,VK_SHIFT,VK_CONTROL,VK_MENU,VK_SPACE, VK_TAB,VK_BACK,VK_RETURN,VK_APPS,VK_INSERT,VK_DELETE,VK_HOME,VK_END,VK_NEXT,VK_PRIOR,VK_UP,VK_DOWN,VK_LEFT,VK_RIGHT,VK_F1, VK_F10,VK_F11,VK_F12,VK_PAUSE,VK_CLEAR,VK_DIVIDE,VK_MULTIPLY,VK_SUBTRACT,VK_ADD,VK_DECIMAL, MK_LBUTTON,MK_RBUTTON,MK_MBUTTON, MK_SHIFT,MK_CONTROL,LOWORD,HIWORD,GetWindowRect,GetForegroundWindow,SetCursorPos; FROM WINGDI IMPORT BITMAPFILEHEADER,BITMAPINFOHEADER,RGBQUAD,GetNearestPaletteIndex,PALETTEINDEX, PBITMAPINFO,CreateDIBSection,BI_RGB,DIB_RGB_COLORS,PLOGPALETTE,LOGPALETTE,PALETTEENTRY,CreatePalette,GetDeviceCaps, BITSPIXEL,CreateCompatibleDC,GetCurrentObject,OBJ_PAL,OBJ_PEN,OBJ_BRUSH,OBJ_FONT,OBJ_BITMAP,SelectPalette,SelectClipRgn, BitBlt,SRCCOPY,SelectObject,DeleteObject,DeleteDC,SwapBuffers,CreateCompatibleBitmap,CreateBitmap,SRCINVERT,BITMAPINFO, GetDIBits,BITMAP,SetTextColor,SRCPAINT,SRCAND,NOTSRCERASE,MERGEPAINT,SRCERASE,NOTSRCCOPY,GetObject, SetDIBits,SetDIBColorTable,CreateRectRgn,R2_COPYPEN,R2_XORPEN,R2_MERGEPEN,R2_MASKPEN,R2_NOTCOPYPEN,R2_NOT,R2_NOTXORPEN, R2_NOTMERGEPEN,R2_NOTMASKPEN,R2_MASKNOTPEN,R2_MERGENOTPEN,R2_MASKPENNOT,R2_MERGEPENNOT,R2_BLACK,R2_WHITE,R2_NOP,TRANSPARENT, OPAQUE,SetROP2,SetBkMode,GetPaletteEntries,RGB,GetRValue,GetGValue,GetBValue,GetSystemPaletteEntries,ResizePalette, SetPaletteEntries,RealizePalette,PolyBezier,Polyline,LineDDA,MoveToEx,SetPixelV,LOGPEN,PS_SOLID,PS_DASH,PS_DOT,PS_DASHDOT, PS_DASHDOTDOT,PS_NULL,CreatePenIndirect,Polygon,ExtFloodFill,Pie,LOGBRUSH,BS_HATCHED,BS_SOLID,HS_HORIZONTAL,HS_VERTICAL,HS_CROSS, HS_BDIAGONAL,HS_FDIAGONAL,HS_DIAGCROSS,BS_PATTERN,BS_NULL,CreateBrushIndirect,FLOODFILLSURFACE,FLOODFILLBORDER,TEXTMETRIC, GetTextFace,GetTextMetrics,TMPF_TRUETYPE,EnumFontFamilies,LOGFONT,TextOut,GetCurrentPositionEx,TA_LEFT,TA_CENTER,TA_RIGHT, TA_TOP,TA_BOTTOM,TA_BASELINE,SetTextAlign,TA_UPDATECP,FW_BOLD,FW_NORMAL,DEFAULT_CHARSET,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,DEFAULT_PITCH,FF_DONTCARE,CreateFontIndirect,SetTextCharacterExtra,SetTextJustification,GetTextExtentPoint32; IMPORT WINGDI; IMPORT WINUSER; FROM WINX IMPORT Instance, NULL_HWND, NULL_HMENU,NULL_HINSTANCE; TYPE (*TImage = RECORD bmiFileHeader: BITMAPFILEHEADER; bmiInfoHeader: BITMAPINFOHEADER; bmiBits : ARRAY[0..0] OF LOC; END;*) TFontString = ARRAY[0..31] OF CHAR; CONST NrVideoPages = 4; (*number OF available video pages*) Rad = pi/180.0; NrMaxFonts = 15; MinCharSize = 8; NrColorNames = 256; VAR grEnabled,palExist : BOOLEAN; screenWidth,screenHeight : INTEGER; grDriver,grMode,grResult : INTEGER; internColor : ARRAY[0..NrColorNames-1] OF CARDINAL; customWidth,customHeight : INTEGER; windowWidth,windowHeight : INTEGER; windowStyle : DWORD; bitPixel : WORD; maxColors,palSize : CARDINAL; grHandle,consHandle : HWND; grTitle : ARRAY[0..31] OF CHAR; grThread : HANDLE; maxX,maxY,origX,origY, actX,actY,aspX,aspY : INTEGER; defAspectRatio : BOOLEAN; grWindow,grMemory,grTemp : HDC; grPalette,old_Palette : HPALETTE; grPen,old_Pen : HPEN; grBrush,old_Brush : HBRUSH; grFont,old_Font : HFONT; grPattern,old_Bitmap : HBITMAP; grBitmap : ARRAY[0..NrVideoPages-1] OF HBITMAP; colTable : POINTER TO ARRAY OF RGBQUAD = NIL; protect_devices : CRITICAL_SECTION; grDirect,grUpdate : BOOLEAN; visualPage,activePage : CARDINAL; instFont : ARRAY[0..NrMaxFonts-1] OF TFontString; grClip : HRGN; frColor,bkColor : CARDINAL; lineSettings : LineSettingsType; fillSettings : FillSettingsType; textSettings : TextSettingsType; fillPattern : FillPatternType; viewPort : ViewPortType; lastArcCoords : ArcCoordsType; viewPortWidth,viewPortHeight: INTEGER; floodMode : UINT; oglEnabled,oglDirect : BOOLEAN; grCloseRequest : BOOLEAN; globalTemp : INTEGER; (*used FOR some tricky techniques*) DefaultVGAPalette: ARRAY[0..255] OF CARDINAL = {0000000H,0A80000H,000A800H,0A8A800H,00000A8H,0A800A8H,00054A8H,0A8A8A8H, 0545454H,0FC8484H,054FC54H,0FCFC54H,05454FCH,0FC54FCH,054FCFCH,0FCFCFCH, 0000000H,0141414H,0202020H,02C2C2CH,0383838H,0444444H,0505050H,0606060H, 0707070H,0808080H,0909090H,0A0A0A0H,0B4B4B4H,0C8C8C8H,0E0E0E0H,0FCFCFCH, 0FC0000H,0FC0040H,0FC007CH,0FC00BCH,0FC00FCH,0BC00FCH,07C00FCH,04000FCH, 00000FCH,00040FCH,0007CFCH,000BCFCH,000FCFCH,000FCBCH,000FC7CH,000FC40H, 000FC00H,040FC00H,07CFC00H,0BCFC00H,0FCFC00H,0FCBC00H,0FC7C00H,0FC4000H, 0FC7C7CH,0FC7C9CH,0FC7CBCH,0FC7CDCH,0FC7CFCH,0DC7CFCH,0BC7CFCH,09C7CFCH, 07C7CFCH,0FC9CFCH,07CBCFCH,07CDCFCH,07CFCFCH,07CFCDCH,07CFCBCH,07CFC9CH, 07CFC7CH,09CFC7CH,0BCFC7CH,0DCFC7CH,0FCFC7CH,0FCDC7CH,0FCBC7CH,0FC9C7CH, 0FCB4B4H,0FCB4C4H,0FCB4D8H,0FCB4E8H,0FCB4FCH,0E8B4FCH,0D8B4FCH,0C4B4FCH, 0B4B4FCH,0B4C4FCH,0B4D8FCH,0B4E8FCH,0B4FCFCH,0B4FCE8H,0B4FCD8H,0B4FCC4H, 0B4FCB4H,0C4FCB4H,0D8FCB4H,0E8FCB4H,0FCFCB4H,0FCE8B4H,0FCD8B4H,0FCC4B4H, 0700000H,070001CH,0700038H,0700054H,0700070H,0540070H,0380070H,01C0070H, 0000070H,0001C70H,0003870H,0005470H,0007070H,0007054H,0007038H,000701CH, 0007000H,01C7000H,0387000H,0547000H,0707000H,0705400H,0703800H,0701C00H, 0703838H,0703844H,0703854H,0703860H,0703870H,0603870H,0543870H,0443870H, 0383870H,0384470H,0385470H,0386070H,0387070H,0387060H,0387054H,0387044H, 0387038H,0447038H,0547038H,0607038H,0707038H,0706038H,0705438H,0704438H, 0705050H,0705058H,0705060H,0705068H,0705070H,0685070H,0605070H,0585070H, 0505070H,0505870H,0506070H,0506870H,0507070H,0507068H,0507060H,0507058H, 0507050H,0587050H,0607050H,0687050H,0707050H,0706850H,0706050H,0705850H, 0400000H,0400010H,0400020H,0400030H,0400040H,0300040H,0200040H,0100040H, 0000040H,0001040H,0002040H,0003040H,0004040H,0004030H,0004020H,0004010H, 0004000H,0104000H,0204000H,0304000H,0404000H,0403000H,0402000H,0401000H, 0402020H,0402028H,0402030H,0402038H,0402040H,0382040H,0302040H,0282040H, 0202040H,0202840H,0203040H,0203840H,0204040H,0204038H,0204030H,0204028H, 0204020H,0284020H,0304020H,0384020H,0404020H,0403820H,0403020H,0402820H, 0402C2CH,0402C30H,0402C34H,0402C3CH,0402C40H,03C2C40H,0342C40H,0302C40H, 02C3040H,02C3440H,02C3C40H,02C4040H,02C403CH,02C4034H,02C4030H,02C402CH, 030402CH,034402CH,03C402CH,040402CH,0403C2CH,040342CH,040302CH,0000000H, 0000000H,0000000H,0000000H,0000000H,0000000H,0000000H,0000000H,0000000H}; (*$IFDEF 256_COLOR_NAMES*) NamesPalette: ARRAY[0..NrColorNames-1] OF CARDINAL = {0FFF8F0H,03626E3H,000BFFFH,0CC6699H,0D7EBFAH,0D4FF7FH,05BA07BH,0FFFFF0H, 0DCF5F5H,0C4E4FFH,01F2B3DH,00DE0CAH,0000000H,0CDEBFFH,00099FFH,0FF0000H, 0E22B8AH,0B69500H,042A6B5H,000FF66H,0DEE808H,0CD00CDH,0327FCDH,02A2AA5H, 082DCF0H,0200090H,087B8DEH,00055CCH,05174E9H,024338AH,0A09E5FH,06B8678H, 03A1EC4H,0180096H,02191EDH,0D1BEADH,0AFE1ACH,06331DEH,0A77B00H,0BE522AH, 000FF7FH,01E69D2H,0003F7BH,0AB4700H,03373B8H,0507FFFH,05DECFBH,0ED9564H, 0DCF8FFH,0D0FDFFH,03C14DCH,0FFFF00H,08B0000H,0214365H,07E4508H,0606998H, 0455BCDH,08B8B00H,00B86B8H,0545454H,0006400H,0620031H,06BB7BDH,08B008BH, 0326855H,02F6B55H,0008CFFH,0CC3299H,03CC003H,08054E7H,000008BH,07A96E9H, 0190356H,08FBC8FH,08B3D48H,04F4F2FH,0457217H,0518191H,012A8FFH,0ADDBBAH, 05C4ECCH,0D1CE00H,0D30094H,09314FFH,0FFBF00H,0BD6015H,0696969H,0FF901EH, 078C850H,0660099H,042794FH,02222B2H,082DCEEH,0F0FAFFH,0228B22H,0808080H, 0A100F4H,0DCDCDCH,00F9BE4H,0FFF8F8H,000D7FFH,020A5DAH,07E7E7EH,0455946H, 0BADACAH,0008000H,02FFFADH,0FF73DFH,0F0FFF0H,0B469FFH,05C5CCDH,082004BH, 0A72F00H,0004FFFH,0F0FFFFH,06BA800H,08CE6F0H,0FAE6E6H,0F5F0FFH,000FC7CH, 010E9FDH,0CDFAFFH,0E6D8ADH,08CB4D2H,08080F0H,0FFFFE0H,0D2FAFAH,0A8A8A8H, 090EE90H,0FF80FFH,0C1B6FFH,08080FFH,07AA0FFH,0AAB220H,0FACE87H,0998877H, 0DEC4B0H,0E0FFFFH,0C8A2C8H,000FF00H,032CD32H,0E6F0FAH,0FF00FFH,051DA0BH, 0000080H,0FFB0E0H,0AACD66H,0CD0000H,0D355BAH,0DB7093H,071B33CH,0EE687BH, 09AFA00H,0CCD148H,08515C7H,0701919H,0FAFFF5H,0E1E4FFH,0B5E4FFH,0C0DCC0H, 01E03C7H,0ADDFADH,08D7A99H,058DBFFH,0ADDEFFH,0800000H,02277CCH,03BB5CFH, 0E6F5FDH,0008080H,0238E6BH,000A5FFH,00045FFH,0D670DAH,0547698H,03540AFH, 0AFADDDH,0EFCDABH,0AAE8EEH,098FB98H,0E584F9H,0666699H,0DDDAFAH,0ABBDDAH, 0EEEEAFH,09370DBH,0D5EFFFH,077DD77H,0DCD1FFH,0B4E5FFH,099CCFFH,0B9DAFFH, 0ADDFFAH,031E2D1H,0FFCCCCH,0FF0066H,03F85CDH,06F7901H,0CBC0FFH,06699FFH, 0DDA0DDH,0E6E0B0H,0533100H,09988CCH,01875FFH,0800080H,0124A73H,00000FFH, 0A2FFC9H,0CCCC00H,08F8FBCH,0E16941H,01B4680H,00E41B7H,013458BH,030C4F4H, 07280FAH,060A4F4H,00A0092H,0672508H,00024FFH,000D8FFH,0578B2EH,0EEF5FFH, 000BAFFH,0144270H,02D52A0H,0C0C0C0H,0EBCE87H,0CD5A6AH,0908070H,0FAFAFFH, 07FFF00H,0B48246H,08EB7ACH,07E98BCH,000CCFFH,0808000H,0C0F0D0H,00057CDH, 05B72E2H,0D8BFD8H,04763FFH,0D0E040H,08F0A12H,0004DFFH,0EE82EEH,0991199H, 06D8240H,0B3DEF5H,0FFFFFFH,0F5F5F5H,0DCA0C9H,000FFFFH,032CD9AH,0AFC2EBH}; (*internal routines*) PROCEDURE EnumFontFamProc(VAR lpelf:LOGFONT; VAR lpntm:TEXTMETRIC;FontType:DWORD; param:LPARAM): INTEGER [EXPORT]; BEGIN globalTemp:=1; (*we got here IF at least one font from the family font exists*) RETURN 0; END EnumFontFamProc; PROCEDURE InstallDefaultFonts; CONST NrDefFonts = 4; (*the following fonts exist on any system*) DefaultFont: ARRAY[0..NrDefFonts-1] OF TFontString = {'Courier New','MS Sans Serif','Times New Roman','Arial'}; VAR i: INTEGER; BEGIN FOR i:=0 TO NrMaxFonts-1 DO instFont[i]:=''; END; darn: FOR i:=0 TO NrDefFonts-1 DO InstallUserFont(DefaultFont[i]); IF (grResult # grOK) THEN BREAK darn; END; END; END InstallDefaultFonts; PROCEDURE LineProc(x,y:INTEGER; param:LPARAM) [EXPORT]; BEGIN param:=param SHR globalTemp; IF (param:CARDINAL BAND 0001H # 0) THEN PutPixel(x,y,frColor); END; globalTemp:=(globalTemp+1) MOD 16; END LineProc; PROCEDURE MapPaletteColors; VAR i: INTEGER; BEGIN FOR i:=0 TO NrColorNames-1 DO internColor[i]:= GetNearestPaletteIndex(grPalette,NamesPalette[i]); END; END MapPaletteColors; PROCEDURE MapColor(color:CARDINAL): CARDINAL; BEGIN IF palExist THEN RETURN PALETTEINDEX(color MOD palSize) ELSE RETURN color; END; END MapColor; PROCEDURE ProcessMessages(): INTEGER; VAR mess: MSG; BEGIN WHILE (GetMessage(mess,NIL,0,0) = TRUE) DO TranslateMessage(mess); DispatchMessage(mess); END; RETURN mess.wParam; END ProcessMessages; PROCEDURE SetAbsoluteColors; VAR i: INTEGER; BEGIN FOR i:=0 TO NrColorNames-1 DO internColor[i]:=NamesPalette[i]; END; END SetAbsoluteColors; PROCEDURE SetInternColors; BEGIN (* internColor[000]:=ADR(AliceBlue); internColor[001]:=ADR(AlizarinCrimson); internColor[002]:=ADR(Amber); internColor[003]:=ADR(Amethyst); internColor[004]:=ADR(AntiqueWhite); internColor[005]:=ADR(Aquamarine); internColor[006]:=ADR(Asparagus); internColor[007]:=ADR(Azure); internColor[008]:=ADR(Beige); internColor[009]:=ADR(Bisque); internColor[010]:=ADR(Bistre); internColor[011]:=ADR(BitterLemon); internColor[012]:=ADR(Black); internColor[013]:=ADR(BlanchedAlmond); internColor[014]:=ADR(BlazeOrange); internColor[015]:=ADR(Blue); internColor[016]:=ADR(BlueViolet); internColor[017]:=ADR(BondiBlue); internColor[018]:=ADR(Brass); internColor[019]:=ADR(BrightGreen); internColor[020]:=ADR(BrightTurquoise); internColor[021]:=ADR(BrightViolet); internColor[022]:=ADR(Bronze); internColor[023]:=ADR(Brown); internColor[024]:=ADR(Buff); internColor[025]:=ADR(Burgundy); internColor[026]:=ADR(BurlyWood); internColor[027]:=ADR(BurntOrange); internColor[028]:=ADR(BurntSienna); internColor[029]:=ADR(BurntUmber); internColor[030]:=ADR(CadetBlue); internColor[031]:=ADR(CamouflageGreen); internColor[032]:=ADR(Cardinal); internColor[033]:=ADR(Carmine); internColor[034]:=ADR(Carrot); internColor[035]:=ADR(Casper); internColor[036]:=ADR(Celadon); internColor[037]:=ADR(Cerise); internColor[038]:=ADR(Cerulean); internColor[039]:=ADR(CeruleanBlue); internColor[040]:=ADR(Chartreuse); internColor[041]:=ADR(Chocolate); internColor[042]:=ADR(Cinnamon); internColor[043]:=ADR(Cobalt); internColor[044]:=ADR(Copper); internColor[045]:=ADR(Coral); internColor[046]:=ADR(Corn); internColor[047]:=ADR(CornflowerBlue); internColor[048]:=ADR(Cornsilk); internColor[049]:=ADR(Cream); internColor[050]:=ADR(Crimson); internColor[051]:=ADR(Cyan); internColor[052]:=ADR(DarkBlue); internColor[053]:=ADR(DarkBrown); internColor[054]:=ADR(DarkCerulean); internColor[055]:=ADR(DarkChestnut); internColor[056]:=ADR(DarkCoral); internColor[057]:=ADR(DarkCyan); internColor[058]:=ADR(DarkGoldenrod); internColor[059]:=ADR(DarkGray); internColor[060]:=ADR(DarkGreen); internColor[061]:=ADR(DarkIndigo); internColor[062]:=ADR(DarkKhaki); internColor[063]:=ADR(DarkMagenta); internColor[064]:=ADR(DarkOlive); internColor[065]:=ADR(DarkOliveGreen); internColor[066]:=ADR(DarkOrange); internColor[067]:=ADR(DarkOrchid); internColor[068]:=ADR(DarkPastelGreen); internColor[069]:=ADR(DarkPink); internColor[070]:=ADR(DarkRed); internColor[071]:=ADR(DarkSalmon); internColor[072]:=ADR(DarkScarlet); internColor[073]:=ADR(DarkSeaGreen); internColor[074]:=ADR(DarkSlateBlue); internColor[075]:=ADR(DarkSlateGray); internColor[076]:=ADR(DarkSpringGreen); internColor[077]:=ADR(DarkTan); internColor[078]:=ADR(DarkTangerine); internColor[079]:=ADR(DarkTeaGreen); internColor[080]:=ADR(DarkTerraCotta); internColor[081]:=ADR(DarkTurquoise); internColor[082]:=ADR(DarkViolet); internColor[083]:=ADR(DeepPink); internColor[084]:=ADR(DeepSkyBlue); internColor[085]:=ADR(Denim); internColor[086]:=ADR(DimGray); internColor[087]:=ADR(DodgerBlue); internColor[088]:=ADR(Emerald); internColor[089]:=ADR(Eggplant); internColor[090]:=ADR(FernGreen); internColor[091]:=ADR(FireBrick); internColor[092]:=ADR(Flax); internColor[093]:=ADR(FloralWhite); internColor[094]:=ADR(ForestGreen); internColor[095]:=ADR(Fractal); internColor[096]:=ADR(Fuchsia); internColor[097]:=ADR(Gainsboro); internColor[098]:=ADR(Gamboge); internColor[099]:=ADR(GhostWhite); internColor[100]:=ADR(Gold); internColor[101]:=ADR(Goldenrod); internColor[102]:=ADR(Gray); internColor[103]:=ADR(GrayAsparagus); internColor[104]:=ADR(GrayTeaGreen); internColor[105]:=ADR(Green); internColor[106]:=ADR(GreenYellow); internColor[107]:=ADR(Heliotrope); internColor[108]:=ADR(Honeydew); internColor[109]:=ADR(HotPink); internColor[110]:=ADR(IndianRed); internColor[111]:=ADR(Indigo); internColor[112]:=ADR(InternationalKleinBlue); internColor[113]:=ADR(InternationalOrange); internColor[114]:=ADR(Ivory); internColor[115]:=ADR(Jade); internColor[116]:=ADR(Khaki); internColor[117]:=ADR(Lavender); internColor[118]:=ADR(LavenderBlush); internColor[119]:=ADR(LawnGreen); internColor[120]:=ADR(Lemon); internColor[121]:=ADR(LemonChiffon); internColor[122]:=ADR(LightBlue); internColor[123]:=ADR(LightBrown); internColor[124]:=ADR(LightCoral); internColor[125]:=ADR(LightCyan); internColor[126]:=ADR(LightGoldenrodYellow); internColor[127]:=ADR(LightGray); internColor[128]:=ADR(LightGreen); internColor[129]:=ADR(LightMagenta); internColor[130]:=ADR(LightPink); internColor[131]:=ADR(LightRed); internColor[132]:=ADR(LightSalmon); internColor[133]:=ADR(LightSeaGreen); internColor[134]:=ADR(LightSkyBlue); internColor[135]:=ADR(LightSlateGray); internColor[136]:=ADR(LightSteelBlue); internColor[137]:=ADR(LightYellow); internColor[138]:=ADR(Lilac); internColor[139]:=ADR(Lime); internColor[140]:=ADR(LimeGreen); internColor[141]:=ADR(Linen); internColor[142]:=ADR(Magenta); internColor[143]:=ADR(Malachite); internColor[144]:=ADR(Maroon); internColor[145]:=ADR(Mauve); internColor[146]:=ADR(MediumAquamarine); internColor[147]:=ADR(MediumBlue); internColor[148]:=ADR(MediumOrchid); internColor[149]:=ADR(MediumPurple); internColor[150]:=ADR(MediumSeaGreen); internColor[151]:=ADR(MediumSlateBlue); internColor[152]:=ADR(MediumSpringGreen); internColor[153]:=ADR(MediumTurquoise); internColor[154]:=ADR(MediumVioletRed); internColor[155]:=ADR(MidnightBlue); internColor[156]:=ADR(MintCream); internColor[157]:=ADR(MistyRose); internColor[158]:=ADR(Moccasin); internColor[159]:=ADR(MoneyGreen); internColor[160]:=ADR(Monza); internColor[161]:=ADR(MossGreen); internColor[162]:=ADR(MountbattenPink); internColor[163]:=ADR(Mustard); internColor[164]:=ADR(NavajoWhite); internColor[165]:=ADR(Navy); internColor[166]:=ADR(Ochre); internColor[167]:=ADR(OldGold); internColor[168]:=ADR(OldLace); internColor[169]:=ADR(Olive); internColor[170]:=ADR(OliveDrab); internColor[171]:=ADR(Orange); internColor[172]:=ADR(OrangeRed); internColor[173]:=ADR(Orchid); internColor[174]:=ADR(PaleBrown); internColor[175]:=ADR(PaleCarmine); internColor[176]:=ADR(PaleChestnut); internColor[177]:=ADR(PaleCornflowerBlue); internColor[178]:=ADR(PaleGoldenrod); internColor[179]:=ADR(PaleGreen); internColor[180]:=ADR(PaleMagenta); internColor[181]:=ADR(PaleMauve); internColor[182]:=ADR(PalePink); internColor[183]:=ADR(PaleSandyBrown); internColor[184]:=ADR(PaleTurquoise); internColor[185]:=ADR(PaleVioletRed); internColor[186]:=ADR(PapayaWhip); internColor[187]:=ADR(PastelGreen); internColor[188]:=ADR(PastelPink); internColor[189]:=ADR(Peach); internColor[190]:=ADR(PeachOrange); internColor[191]:=ADR(PeachPuff); internColor[192]:=ADR(PeachYellow); internColor[193]:=ADR(Pear); internColor[194]:=ADR(Periwinkle); internColor[195]:=ADR(PersianBlue); internColor[196]:=ADR(Peru); internColor[197]:=ADR(PineGreen); internColor[198]:=ADR(Pink); internColor[199]:=ADR(PinkOrange); internColor[200]:=ADR(Plum); internColor[201]:=ADR(PowderBlue); internColor[202]:=ADR(PrussianBlue); internColor[203]:=ADR(Puce); internColor[204]:=ADR(Pumpkin); internColor[205]:=ADR(Purple); internColor[206]:=ADR(RawUmber); internColor[207]:=ADR(Red); internColor[208]:=ADR(Reef); internColor[209]:=ADR(RobinEggBlue); internColor[210]:=ADR(RosyBrown); internColor[211]:=ADR(RoyalBlue); internColor[212]:=ADR(Russet); internColor[213]:=ADR(Rust); internColor[214]:=ADR(SaddleBrown); internColor[215]:=ADR(Saffron); internColor[216]:=ADR(Salmon); internColor[217]:=ADR(SandyBrown); internColor[218]:=ADR(Sangria); internColor[219]:=ADR(Sapphire); internColor[220]:=ADR(Scarlet); internColor[221]:=ADR(SchoolBusYellow); internColor[222]:=ADR(SeaGreen); internColor[223]:=ADR(SeaShell); internColor[224]:=ADR(SelectiveYellow); internColor[225]:=ADR(Sepia); internColor[226]:=ADR(Sienna); internColor[227]:=ADR(Silver); internColor[228]:=ADR(SkyBlue); internColor[229]:=ADR(SlateBlue); internColor[230]:=ADR(SlateGray); internColor[231]:=ADR(Snow); internColor[232]:=ADR(SpringGreen); internColor[233]:=ADR(SteelBlue); internColor[234]:=ADR(SwampGreen); internColor[235]:=ADR(Taupe); internColor[236]:=ADR(Tangerine); internColor[237]:=ADR(Teal); internColor[238]:=ADR(TeaGreen); internColor[239]:=ADR(Tenne); internColor[240]:=ADR(TerraCotta); internColor[241]:=ADR(Thistle); internColor[242]:=ADR(Tomato); internColor[243]:=ADR(Turquoise); internColor[244]:=ADR(Ultramarine); internColor[245]:=ADR(Vermilion); internColor[246]:=ADR(Violet); internColor[247]:=ADR(VioletEggplant); internColor[248]:=ADR(Viridian); internColor[249]:=ADR(Wheat); internColor[250]:=ADR(White); internColor[251]:=ADR(WhiteSmoke); internColor[252]:=ADR(Wisteria); internColor[253]:=ADR(Yellow); internColor[254]:=ADR(YellowGreen); internColor[255]:=ADR(Zinnwaldite);*) internColor[000] := AliceBlue; internColor[001] := AlizarinCrimson; internColor[002] := Amber; internColor[003] := Amethyst; internColor[004] := AntiqueWhite; internColor[005] := Aquamarine; internColor[006] := Asparagus; internColor[007] := Azure; internColor[008] := Beige; internColor[009] := Bisque; internColor[010] := Bistre; internColor[011] := BitterLemon; internColor[012] := Black; internColor[013] := BlanchedAlmond; internColor[014] := BlazeOrange; internColor[015] := Blue; internColor[016] := BlueViolet; internColor[017] := BondiBlue; internColor[018] := Brass; internColor[019] := BrightGreen; internColor[020] := BrightTurquoise; internColor[021] := BrightViolet; internColor[022] := Bronze; internColor[023] := Brown; internColor[024] := Buff; internColor[025] := Burgundy; internColor[026] := BurlyWood; internColor[027] := BurntOrange; internColor[028] := BurntSienna; internColor[029] := BurntUmber; internColor[030] := CadetBlue; internColor[031] := CamouflageGreen; internColor[032] := Cardinal; internColor[033] := Carmine; internColor[034] := Carrot; internColor[035] := Casper; internColor[036] := Celadon; internColor[037] := Cerise; internColor[038] := Cerulean; internColor[039] := CeruleanBlue; internColor[040] := Chartreuse; internColor[041] := Chocolate; internColor[042] := Cinnamon; internColor[043] := Cobalt; internColor[044] := Copper; internColor[045] := Coral; internColor[046] := Corn; internColor[047] := CornflowerBlue; internColor[048] := Cornsilk; internColor[049] := Cream; internColor[050] := Crimson; internColor[051] := Cyan; internColor[052] := DarkBlue; internColor[053] := DarkBrown; internColor[054] := DarkCerulean; internColor[055] := DarkChestnut; internColor[056] := DarkCoral; internColor[057] := DarkCyan; internColor[058] := DarkGoldenrod; internColor[059] := DarkGray; internColor[060] := DarkGreen; internColor[061] := DarkIndigo; internColor[062] := DarkKhaki; internColor[063] := DarkMagenta; internColor[064] := DarkOlive; internColor[065] := DarkOliveGreen; internColor[066] := DarkOrange; internColor[067] := DarkOrchid; internColor[068] := DarkPastelGreen; internColor[069] := DarkPink; internColor[070] := DarkRed; internColor[071] := DarkSalmon; internColor[072] := DarkScarlet; internColor[073] := DarkSeaGreen; internColor[074] := DarkSlateBlue; internColor[075] := DarkSlateGray; internColor[076] := DarkSpringGreen; internColor[077] := DarkTan; internColor[078] := DarkTangerine; internColor[079] := DarkTeaGreen; internColor[080] := DarkTerraCotta; internColor[081] := DarkTurquoise; internColor[082] := DarkViolet; internColor[083] := DeepPink; internColor[084] := DeepSkyBlue; internColor[085] := Denim; internColor[086] := DimGray; internColor[087] := DodgerBlue; internColor[088] := Emerald; internColor[089] := Eggplant; internColor[090] := FernGreen; internColor[091] := FireBrick; internColor[092] := Flax; internColor[093] := FloralWhite; internColor[094] := ForestGreen; internColor[095] := Fractal; internColor[096] := Fuchsia; internColor[097] := Gainsboro; internColor[098] := Gamboge; internColor[099] := GhostWhite; internColor[100] := Gold; internColor[101] := Goldenrod; internColor[102] := Gray; internColor[103] := GrayAsparagus; internColor[104] := GrayTeaGreen; internColor[105] := Green; internColor[106] := GreenYellow; internColor[107] := Heliotrope; internColor[108] := Honeydew; internColor[109] := HotPink; internColor[110] := IndianRed; internColor[111] := Indigo; internColor[112] := InternationalKleinBlue; internColor[113] := InternationalOrange; internColor[114] := Ivory; internColor[115] := Jade; internColor[116] := Khaki; internColor[117] := Lavender; internColor[118] := LavenderBlush; internColor[119] := LawnGreen; internColor[120] := Lemon; internColor[121] := LemonChiffon; internColor[122] := LightBlue; internColor[123] := LightBrown; internColor[124] := LightCoral; internColor[125] := LightCyan; internColor[126] := LightGoldenrodYellow; internColor[127] := LightGray; internColor[128] := LightGreen; internColor[129] := LightMagenta; internColor[130] := LightPink; internColor[131] := LightRed; internColor[132] := LightSalmon; internColor[133] := LightSeaGreen; internColor[134] := LightSkyBlue; internColor[135] := LightSlateGray; internColor[136] := LightSteelBlue; internColor[137] := LightYellow; internColor[138] := Lilac; internColor[139] := Lime; internColor[140] := LimeGreen; internColor[141] := Linen; internColor[142] := Magenta; internColor[143] := Malachite; internColor[144] := Maroon; internColor[145] := Mauve; internColor[146] := MediumAquamarine; internColor[147] := MediumBlue; internColor[148] := MediumOrchid; internColor[149] := MediumPurple; internColor[150] := MediumSeaGreen; internColor[151] := MediumSlateBlue; internColor[152] := MediumSpringGreen; internColor[153] := MediumTurquoise; internColor[154] := MediumVioletRed; internColor[155] := MidnightBlue; internColor[156] := MintCream; internColor[157] := MistyRose; internColor[158] := Moccasin; internColor[159] := MoneyGreen; internColor[160] := Monza; internColor[161] := MossGreen; internColor[162] := MountbattenPink; internColor[163] := Mustard; internColor[164] := NavajoWhite; internColor[165] := Navy; internColor[166] := Ochre; internColor[167] := OldGold; internColor[168] := OldLace; internColor[169] := Olive; internColor[170] := OliveDrab; internColor[171] := Orange; internColor[172] := OrangeRed; internColor[173] := Orchid; internColor[174] := PaleBrown; internColor[175] := PaleCarmine; internColor[176] := PaleChestnut; internColor[177] := PaleCornflowerBlue; internColor[178] := PaleGoldenrod; internColor[179] := PaleGreen; internColor[180] := PaleMagenta; internColor[181] := PaleMauve; internColor[182] := PalePink; internColor[183] := PaleSandyBrown; internColor[184] := PaleTurquoise; internColor[185] := PaleVioletRed; internColor[186] := PapayaWhip; internColor[187] := PastelGreen; internColor[188] := PastelPink; internColor[189] := Peach; internColor[190] := PeachOrange; internColor[191] := PeachPuff; internColor[192] := PeachYellow; internColor[193] := Pear; internColor[194] := Periwinkle; internColor[195] := PersianBlue; internColor[196] := Peru; internColor[197] := PineGreen; internColor[198] := Pink; internColor[199] := PinkOrange; internColor[200] := Plum; internColor[201] := PowderBlue; internColor[202] := PrussianBlue; internColor[203] := Puce; internColor[204] := Pumpkin; internColor[205] := Purple; internColor[206] := RawUmber; internColor[207] := Red; internColor[208] := Reef; internColor[209] := RobinEggBlue; internColor[210] := RosyBrown; internColor[211] := RoyalBlue; internColor[212] := Russet; internColor[213] := Rust; internColor[214] := SaddleBrown; internColor[215] := Saffron; internColor[216] := Salmon; internColor[217] := SandyBrown; internColor[218] := Sangria; internColor[219] := Sapphire; internColor[220] := Scarlet; internColor[221] := SchoolBusYellow; internColor[222] := SeaGreen; internColor[223] := SeaShell; internColor[224] := SelectiveYellow; internColor[225] := Sepia; internColor[226] := Sienna; internColor[227] := Silver; internColor[228] := SkyBlue; internColor[229] := SlateBlue; internColor[230] := SlateGray; internColor[231] := Snow; internColor[232] := SpringGreen; internColor[233] := SteelBlue; internColor[234] := SwampGreen; internColor[235] := Taupe; internColor[236] := Tangerine; internColor[237] := Teal; internColor[238] := TeaGreen; internColor[239] := Tenne; internColor[240] := TerraCotta; internColor[241] := Thistle; internColor[242] := Tomato; internColor[243] := Turquoise; internColor[244] := Ultramarine; internColor[245] := Vermilion; internColor[246] := Violet; internColor[247] := VioletEggplant; internColor[248] := Viridian; internColor[249] := Wheat; internColor[250] := White; internColor[251] := WhiteSmoke; internColor[252] := Wisteria; internColor[253] := Yellow; internColor[254] := YellowGreen; internColor[255] := Zinnwaldite; END SetInternColors; PROCEDURE SetBitmaps_WinGraph; VAR pbmi : PBITMAPINFO; pbits: LPVOID; i,nr : INTEGER; BEGIN IF palExist THEN nr:=maxColors ELSE nr:=0; END; ALLOCATE(pbmi,SIZE(BITMAPINFOHEADER)+nr*SIZE(RGBQUAD)); WITH pbmi^.bmiHeader DO biSize:=SIZE(BITMAPINFOHEADER); biWidth:=maxX+1; biHeight:=maxY+1; biPlanes:=1; biBitCount:=bitPixel; biClrUsed:=0; biCompression:=BI_RGB; biSizeImage:=0; biClrImportant:=0; END; FOR i:=0 TO NrVideoPages-1 DO grBitmap[i]:=CreateDIBSection(grWindow,pbmi^,DIB_RGB_COLORS,pbits,NIL,0); END; DISPOSE(pbmi); IF colTable # NIL THEN DISPOSE(colTable); END; NEW(colTable,nr); IF (nr > 0) THEN FillMemBYTE(colTable,nr*SIZE(RGBQUAD), 0); END; END SetBitmaps_WinGraph; PROCEDURE SetPalette_WinGraph; VAR plgpl: PLOGPALETTE; BEGIN ALLOCATE(plgpl,SIZE(LOGPALETTE)+(maxColors-1)*SIZE(PALETTEENTRY)); WITH plgpl^ DO palVersion:= 300H; palNumEntries:=maxColors; FillMemBYTE(ADR(palPalEntry[0]),palNumEntries SHL 2,0); END; grPalette:=CreatePalette(plgpl^); DISPOSE(plgpl); (*,SIZE(LOGPALETTE)+(maxColors-1)*SIZE(PALETTEENTRY));*) END SetPalette_WinGraph; PROCEDURE SetAttrib_WinGraph; VAR dx_bor,dy_bor,dx,dy,tmp: INTEGER; BEGIN dx_bor:=2*GetSystemMetrics(SM_CXFIXEDFRAME); dy_bor:=2*GetSystemMetrics(SM_CYFIXEDFRAME)+GetSystemMetrics(SM_CYCAPTION); CASE grMode OF m320x200 : dx:=320; dy:=200; |m640x200 : dx:=640; dy:=200; |m640x350 : dx:=640; dy:=350; |m640x480 : dx:=640; dy:=480; |m720x350 : dx:=720; dy:=350; |m800x600 : dx:=800; dy:=600; |m1024x768 : dx:=1024; dy:=768; |m1280x1024: dx:=1280; dy:=1024; |mDefault : dx:=-dx_bor; dy:=-dy_bor; |mMaximized: dx:=screenWidth-dx_bor; dy:=screenHeight-dy_bor; |mFullScr : dx:=screenWidth; dy:=screenHeight; |mCustom : dx:=customWidth; dy:=customHeight; ELSE dx:=65535; dy:=65535; END; windowWidth:=dx+dx_bor; windowHeight:=dy+dy_bor; IF (windowWidth <= screenWidth) AND (windowHeight <= screenHeight) THEN windowStyle:=WS_OVERLAPPED BOR WS_SYSMENU BOR WS_CAPTION BOR WS_MINIMIZEBOX ELSE IF (dx <= screenWidth) AND (dy <= screenHeight) THEN windowWidth:=dx; windowHeight:=dy; windowStyle:= WS_POPUP; ELSE grResult:=grInvalidMode; RETURN; END; END; CASE grDriver OF D1bit : bitPixel:=1; |D4bit : bitPixel:=4; |D8bit : bitPixel:=8; |NoPalette: bitPixel:= (GetDeviceCaps(GetDC(GetDesktopWindow()),BITSPIXEL)); ELSE grResult:=grInvalidDriver; RETURN; END; IF (grDriver = NoPalette) THEN palExist:=FALSE ELSE palExist:=TRUE; tmp := 1; maxColors:= tmp SHL bitPixel; END; END SetAttrib_WinGraph; PROCEDURE WinGraphProc(grHandle:HWND; mess:UINT; wParam:WPARAM; lParam:LPARAM): LRESULT [EXPORT, OScall]; VAR grRect : RECT; strPaint: PAINTSTRUCT; old_hbmp: HBITMAP; i : INTEGER; BEGIN (*Result:=0;*) CASE mess OF WM_CREATE: GetClientRect(grHandle,grRect); maxX:=grRect.right-1; maxY:=grRect.bottom-1; grWindow:=GetDC(grHandle); grMemory:=CreateCompatibleDC(NIL); grTemp:=CreateCompatibleDC(NIL); old_Palette:HGDIOBJ :=GetCurrentObject(grWindow,OBJ_PAL); old_Pen:HGDIOBJ :=GetCurrentObject(grWindow,OBJ_PEN); old_Brush:HGDIOBJ :=GetCurrentObject(grWindow,OBJ_BRUSH); old_Font:HGDIOBJ :=GetCurrentObject(grWindow,OBJ_FONT); old_Bitmap:HGDIOBJ :=GetCurrentObject(grMemory,OBJ_BITMAP); IF palExist THEN SetPalette_WinGraph; SelectPalette(grWindow,grPalette,TRUE); SelectPalette(grMemory,grPalette,TRUE); SelectPalette(grTemp,grPalette,TRUE); END; SetBitmaps_WinGraph; InitializeCriticalSection(protect_devices); IF MouseHook # NILPROC THEN MouseHook(grHandle,mess,wParam,lParam); END; IF KeyboardHook # NILPROC THEN KeyboardHook(grHandle,mess,wParam,lParam); END; grEnabled:=TRUE; |WM_ERASEBKGND: IF grEnabled THEN (*trick TO reduce flickering*) END; (*Result:=1;*) RETURN 1; |WM_PAINT: IF GetUpdateRect(grHandle,grRect,FALSE) THEN WITH grRect DO EnterCriticalSection(protect_devices); IF (grClip # NIL) THEN SelectClipRgn(grWindow,NIL); END; BeginPaint(grHandle,strPaint); IF (activePage = visualPage) THEN BitBlt(grWindow,left,top,right-left+1,bottom-top+1,grMemory,left,top,SRCCOPY) ELSE old_hbmp:HGDIOBJ :=SelectObject(grMemory,grBitmap[visualPage]:HGDIOBJ); BitBlt(grWindow,left,top,right-left+1,bottom-top+1,grMemory,left,top,SRCCOPY); SelectObject(grMemory,old_hbmp:HGDIOBJ); END; EndPaint(grHandle,strPaint); IF (grClip # NIL) THEN SelectClipRgn(grWindow,grClip); END; LeaveCriticalSection(protect_devices); END; END; RETURN 0; |WM_CHAR,WM_KEYDOWN,WM_SYSKEYDOWN: IF KeyboardHook # NILPROC THEN RETURN KeyboardHook(grHandle,mess,wParam,lParam); END; RETURN 0; |WM_SYSCHAR: RETURN 0; (*this message is inserted TO avoid keyboard beep*) |WM_MOUSEWHEEL,WM_MOUSEMOVE,WM_LBUTTONDOWN,WM_RBUTTONDOWN,WM_MBUTTONDOWN,WM_LBUTTONUP,WM_RBUTTONUP,WM_MBUTTONUP: IF MouseHook # NILPROC THEN RETURN MouseHook(grHandle,mess,wParam,lParam); END; RETURN 0; |WM_CLOSE: grCloseRequest:=TRUE; IF KeyboardHook # NILPROC THEN RETURN KeyboardHook(grHandle,mess,wParam,lParam); END; RETURN 0; |WM_DESTROY: IF MouseHook # NILPROC THEN MouseHook(grHandle,mess,wParam,lParam); END; IF KeyboardHook # NILPROC THEN KeyboardHook(grHandle,mess,wParam,lParam); END; DeleteCriticalSection(protect_devices); DeleteObject(grPattern:HGDIOBJ); SelectObject(grMemory,old_Bitmap:HGDIOBJ); FOR i:=0 TO NrVideoPages-1 DO DeleteObject(grBitmap[i]:HGDIOBJ); END; DISPOSE(colTable); colTable := NIL; IF palExist THEN SelectPalette(grWindow,old_Palette,TRUE); SelectPalette(grMemory,old_Palette,TRUE); SelectPalette(grTemp,old_Palette,TRUE); DeleteObject(grPalette:HGDIOBJ); palExist:=FALSE; END; SelectObject(grWindow,old_Font:HGDIOBJ); SelectObject(grMemory,old_Font:HGDIOBJ); DeleteObject(grFont:HGDIOBJ); SelectObject(grWindow,old_Brush:HGDIOBJ); SelectObject(grMemory,old_Brush:HGDIOBJ); DeleteObject(grBrush:HGDIOBJ); SelectObject(grWindow,old_Pen:HGDIOBJ); SelectObject(grMemory,old_Pen:HGDIOBJ); DeleteObject(grPen:HGDIOBJ); SetViewPort(0,0,maxX,maxY,ClipOff); DeleteDC(grMemory); DeleteDC(grTemp); PostQuitMessage(grOK); RETURN 0; |WM_USER: DestroyWindow(grHandle); RETURN 0; ELSE END; RETURN DefWindowProc(grHandle,mess,wParam,lParam); END WinGraphProc; PROCEDURE Create_WinGraph(param:LPVOID): DWORD [EXPORT, OScall]; TYPE TstrWindow = RECORD lpClassName : LPCTSTR; lpWindowName: LPCTSTR; dwStyle : DWORD; x : INTEGER; y : INTEGER; nWidth : INTEGER; nHeight : INTEGER; hWndParent : HWND; hMenu : HMENU; hInstance : HANDLE; lpParam : LPVOID; END; CONST className = 'WinGraphClass'; VAR lpWndClass: WNDCLASS; strWindow : TstrWindow; BEGIN (*Result:=0;*) WITH lpWndClass DO style :=CS_OWNDC BOR CS_BYTEALIGNCLIENT; lpfnWndProc :=WinGraphProc; cbClsExtra :=0; cbWndExtra :=0; hInstance :=Instance (*system.MainInstance*); hIcon :=LoadIcon(Instance,'GrIcon'); hCursor :=LoadCursor(NULL_HINSTANCE,IDC_ARROW^); hbrBackground:=CAST(HBRUSH, COLOR_MENU+1); lpszMenuName :=NIL; lpszClassName:=ADR(className); END; IF (RegisterClass(lpWndClass) = 0) THEN grResult:=grNotWindow; RETURN 0; END; WITH strWindow DO lpClassName :=ADR(className); lpWindowName:=ADR(param); dwStyle :=windowStyle; IF (windowWidth # 0) THEN x :=(screenWidth-windowWidth) DIV 2; y :=(screenHeight-windowHeight) DIV 2; nWidth :=windowWidth; nHeight:=windowHeight; ELSE x :=(CW_USEDEFAULT); y :=(CW_USEDEFAULT); nWidth :=(CW_USEDEFAULT); nHeight:=(CW_USEDEFAULT); END; hWndParent:=NULL_HWND; hMenu :=NULL_HMENU; hInstance :=Instance; lpParam :=NIL; grHandle:=CreateWindow(lpClassName^,lpWindowName^,dwStyle,x,y,nWidth,nHeight, hWndParent,hMenu,hInstance,lpParam); END; IF (grHandle = NIL) THEN grResult:=grNotWindow; RETURN 0; END; grResult:=ProcessMessages(); UnregisterClass(className,Instance); RETURN 0; END Create_WinGraph; (*initialization routines*) PROCEDURE ClearDevice; VAR old_ViewPort: ViewPortType; BEGIN old_ViewPort:=viewPort; SetViewPort(0,0,maxX,maxY,ClipOff); ClearViewPort; WITH old_ViewPort DO SetViewPort(x1,y1,x2,y2,clip); END; END ClearDevice; PROCEDURE CloseGraph; VAR exitcode: DWORD; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; grEnabled:=FALSE; PostMessage(grHandle,WM_USER,0,0); (*trick FOR main thread TO close the window*) REPEAT Sleep(10); GetExitCodeThread(grThread,exitcode); UNTIL (exitcode # STILL_ACTIVE); (*wait FOR thread TO destroy the window*) CloseHandle(grThread); IF (consHandle # NIL) THEN ShowWindow(consHandle,SW_SHOW); SetForegroundWindow(consHandle); END; END CloseGraph; PROCEDURE CloseGraphRequest(): BOOLEAN; BEGIN RETURN grCloseRequest; END CloseGraphRequest; PROCEDURE DetectGraph(VAR driver,mode:INTEGER); BEGIN driver:=NoPalette; mode:=mDefault; END DetectGraph; PROCEDURE GetDriverName(VAR nam: ARRAY OF CHAR); BEGIN CASE grDriver OF D1bit : nam := 'D1bit - 2 colors'; |D4bit : nam := 'D4bit - 16 colors'; |D8bit : nam := 'D8bit - 256 colors'; |NoPalette: nam := 'NoPalette - all colors'; ELSE nam := 'no graphics driver'; END; END GetDriverName; PROCEDURE GetGraphMode(): INTEGER; BEGIN IF (grDriver >= 0) THEN RETURN grMode; ELSE RETURN -1; END; END GetGraphMode; PROCEDURE GetMaxMode(): INTEGER; BEGIN RETURN mFullScr; END GetMaxMode; PROCEDURE GetModeName(mode:INTEGER; VAR nam: ARRAY OF CHAR); BEGIN CASE mode OF m320x200 : nam:='320 x 200'; |m640x200 : nam:='640 x 200'; |m640x350 : nam:='640 x 350'; |m640x480 : nam:='640 x 480'; |m720x350 : nam:='720 x 350'; |m800x600 : nam:='800 x 600'; |m1024x768 : nam:='1024 x 768'; |m1280x1024: nam:='1280 x 1024'; |mDefault : nam:='Windows default'; |mMaximized: nam:='Maximized'; |mFullScr : nam:='Full screen'; |mCustom : nam:='Custom'; ELSE nam:='invalid graphics mode'; RETURN; END; (*nam:=Result+' (VESA)';*) END GetModeName; PROCEDURE GetModeRange(driver:INTEGER; VAR width,height:INTEGER); BEGIN width:=(screenWidth); height:=(screenHeight); END GetModeRange; PROCEDURE GraphDefaults; VAR palette: PaletteType; pattern: FillPatternType; BEGIN IF palExist THEN GetDefaultPalette(palette); SetAllPalette(palette); ELSE SetAbsoluteColors; END; WITH lineSettings DO linestyle:=SolidLn; pattern:=0; thickness:=NormWidth; END; SetColor(White); SetBkColor(Black); FillMemBYTE(ADR(pattern),8, 0FFH); SetFillPattern(pattern,White); SetFillStyle(SolidFill,White); SetTextStyle(DefaultFont,HorizDir,16); SetTextJustify(LeftText,TopText); SetUserCharSize(0,0,0,0); SetViewPort(0,0,maxX,maxY,ClipOff); SetWriteMode(CopyMode BOR Transparent); SetAspectRatio(10000,10000); floodMode:=BorderFlood; END GraphDefaults; PROCEDURE GraphEnabled(): BOOLEAN; BEGIN RETURN grEnabled; END GraphEnabled; PROCEDURE GraphErrorMsg(errorcode:INTEGER; VAR msg: ARRAY OF CHAR); BEGIN CASE errorcode OF grOK : msg:=''; RETURN; |grInvalidDriver : msg:='Invalid graphics driver'; |grInvalidMode : msg:='Invalid graphics mode'; |grNotWindow : msg:='Creation OF graphics window failed'; |grNoInitGraph : msg:='Graphics window NOT initialized. Use InitGraph'; |grInvalidFont : msg:='Invalid font selection'; |grInvalidFontNum : msg:='Invalid font number'; |grInvalidParam : msg:='Invalid parameter value'; |grNoPalette : msg:='No palette available. Change graphics driver'; |grNoOpenGL : msg:='OpenGL driver NOT initialized'; |grError : msg:='General graphics error'; ELSE msg:='Unrecognized error code'; END; END GraphErrorMsg; PROCEDURE GraphResult(): INTEGER; VAR Result: INTEGER; BEGIN Result:=grResult; grResult:=grOK; RETURN Result; END GraphResult; PROCEDURE InitGraphics(WinX, WinY: INTEGER; title: ARRAY OF CHAR); VAR gd,gm: INTEGER; BEGIN gd:=NoPalette; gm:=mCustom; SetWindowSize(WinX,WinY); InitGraph(gd,gm,title); END InitGraphics; PROCEDURE InitGraph(VAR driver,mode:INTEGER; title: ARRAY OF CHAR); (*<- main entry point*) VAR consTitle: ARRAY[0..126] OF CHAR; idThread : DWORD; lpThreadAttrib : POINTER TO SECURITY_ATTRIBUTES = NIL; BEGIN grResult:=grOK; IF grEnabled THEN grResult:=grError; RETURN; END; IF (driver = Detect) THEN DetectGraph(grDriver,grMode); driver:=grDriver; mode:=grMode; ELSE grDriver:=driver; grMode:=mode; END; SetAttrib_WinGraph; IF (grResult # grOK) THEN RETURN; END; consHandle:=NIL; (*$IFDEF HIDE_CONSOLE IF (GetConsoleTitle(@consTitle[1],255) # 0) THEN consHandle:=FindWindow(nil,@consTitle[1]); (*on NT-based systems GetConsoleWindow can be invoked*) $ENDIF*) IF NOT Equal(title, '') THEN grTitle:=title; ELSE grTitle:='NONAME'; END; grThread:=CreateThread(lpThreadAttrib^,0,Create_WinGraph,grTitle:ADDRESS,0,idThread); SetThreadPriority(grThread,THREAD_PRIORITY_ABOVE_NORMAL); (*<- window gets more responsive*) REPEAT Sleep(10); UNTIL grEnabled OR (grResult # grOK); (*wait FOR thread TO create the window*) IF (grResult = grOK) THEN visualPage:=0; grUpdate:=TRUE; SetActivePage(0); InstallDefaultFonts; IF (grResult # grOK) THEN RETURN; END; grClip:=NIL; grPattern:=NIL; GraphDefaults; oglEnabled:=FALSE; oglDirect:=DirectOff; IF (consHandle # NIL) THEN ShowWindow(consHandle,SW_HIDE); END; ShowWindow(grHandle, SW_HIDE); ShowWindow(grHandle,SW_SHOWNORMAL); SetForegroundWindow(grHandle); grCloseRequest:=FALSE; END; END InitGraph; PROCEDURE OpenGLEnabled(): BOOLEAN; BEGIN RETURN oglEnabled; END OpenGLEnabled; PROCEDURE RestoreCrtMode; BEGIN CloseGraph; END RestoreCrtMode; PROCEDURE SetGraphMode(mode:INTEGER); BEGIN IF (grDriver >= 0) THEN InitGraph(grDriver,mode,grTitle) ELSE grResult:=grError; END; END SetGraphMode; PROCEDURE SetOpenGLMode(direct:BOOLEAN); VAR old_ViewPort: ViewPortType; BEGIN IF NOT(oglEnabled) THEN grResult:=grNoOpenGL; RETURN; END; END SetOpenGLMode; PROCEDURE SetWindowSize(width,height:CARDINAL); BEGIN customWidth:=width; customHeight:=height; END SetWindowSize; PROCEDURE UpdateGraph(bit:CARDINAL); BEGIN CASE bit OF UpdateOff: IF grUpdate THEN grUpdate:=FALSE; grDirect:=FALSE; END; |UpdateOn : IF NOT(grUpdate) THEN grUpdate:=TRUE; SetVisualPage(visualPage); END; |UpdateNow: IF oglDirect THEN SwapBuffers(grWindow) ELSE SetVisualPage(visualPage); END; END; END UpdateGraph; (*screen management routines*) PROCEDURE ClearViewPort; VAR old_FillSettings: FillSettingsType; BEGIN MoveTo(0,0); IF (grResult # grOK) THEN RETURN; END; old_FillSettings:=fillSettings; SetFillStyle(SolidFill,bkColor); Bar(0,0,viewPortWidth,viewPortHeight); WITH old_FillSettings DO SetFillStyle(pattern,color); END; END ClearViewPort; PROCEDURE FreeAnim(VAR anim:AnimatType); BEGIN EnterCriticalSection(protect_devices); WITH anim DO IF (bitHnd # NIL) THEN DeleteObject(bitHnd:HGDIOBJ); DeleteObject(maskHnd:HGDIOBJ); DeleteObject(bkgHnd:HGDIOBJ); bitHnd:=NIL; END; END; LeaveCriticalSection(protect_devices); END FreeAnim; PROCEDURE GetAnim(x1,y1,x2,y2:INTEGER; color:CARDINAL; VAR anim:AnimatType); VAR bmWidth,bmHeight: INTEGER; dc : HDC; rc : RECT; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; INC(x2); INC(y2); WITH anim DO bmWidth:=x2-x1; bmHeight:=y2-y1; bitHnd:=CreateCompatibleBitmap(grMemory,bmWidth,bmHeight); maskHnd:=CreateBitmap(bmWidth,bmHeight,1,1,NIL); bkgHnd:=CreateCompatibleBitmap(grMemory,bmWidth,bmHeight); EnterCriticalSection(protect_devices); SelectObject(grTemp,bitHnd:HGDIOBJ); BitBlt(grTemp,0,0,bmWidth,bmHeight,grMemory,x1+origX,y1+origY,SRCCOPY); dc:=CreateCompatibleDC(NIL); SelectObject(dc,maskHnd:HGDIOBJ); WINGDI.SetBkColor(grTemp,MapColor(color)); (*<- trick TO set transparency*) BitBlt(dc,0,0,bmWidth,bmHeight,grTemp,0,0,SRCCOPY); BitBlt(grTemp,0,0,bmWidth,bmHeight,dc,0,0,SRCINVERT); SetRect(rc,0,0,bmWidth,bmHeight); WINUSER.InvertRect(dc,rc); SelectObject(dc,old_Bitmap:HGDIOBJ); DeleteDC(dc); SelectObject(grTemp,old_Bitmap:HGDIOBJ); LeaveCriticalSection(protect_devices); END; END GetAnim; PROCEDURE GetAspectRatio(VAR xasp,yasp:CARDINAL); BEGIN xasp:=aspX; yasp:=aspY; END GetAspectRatio; PROCEDURE GetImage(x1,y1,x2,y2:INTEGER; VAR bitmap: IMAGE); VAR hbmp: HBITMAP; img: IMAGE;(*TImage ABSOLUTE bitmap;*) BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; WITH img.bmiFileHeader DO bfType:= 4D42H; bfOffBits:=SIZE(BITMAPFILEHEADER)+SIZE(BITMAPINFOHEADER); bfSize:=ImageSize(x1,y1,x2,y2); bfReserved1:=0; bfReserved2:=0; END; WITH img.bmiInfoHeader DO INC(x2); INC(y2); biSize:=SIZE(BITMAPINFOHEADER); biWidth:=x2-x1; biHeight:=y2-y1; biPlanes:=1; biBitCount:=24; (*hardcoded 24-bit bitmap format*) biClrUsed:=0; biCompression:=BI_RGB; biSizeImage:=0; biClrImportant:=0; hbmp:=CreateCompatibleBitmap(grMemory,x2-x1,y2-y1); EnterCriticalSection(protect_devices); SelectObject(grTemp,hbmp:HGDIOBJ); BitBlt(grTemp,0,0,x2-x1,y2-y1,grMemory,x1+origX,y1+origY,SRCCOPY); SelectObject(grTemp,old_Bitmap:HGDIOBJ); GetDIBits(grWindow,hbmp,0,biHeight,ADR(img.bmiBits),img.bmiInfoHeader:BITMAPINFO,DIB_RGB_COLORS); LeaveCriticalSection(protect_devices); END; DeleteObject(hbmp:HGDIOBJ); END GetImage; PROCEDURE GetMaxX(): INTEGER; BEGIN RETURN maxX; END GetMaxX; PROCEDURE GetMaxY(): INTEGER; BEGIN RETURN maxY; END GetMaxY; PROCEDURE GetViewSettings(VAR viewport:ViewPortType); BEGIN viewport := viewPort; END GetViewSettings; PROCEDURE GetX(): INTEGER; BEGIN RETURN actX; END GetX; PROCEDURE GetY(): INTEGER; BEGIN RETURN actY; END GetY; PROCEDURE ImageSize(x1,y1,x2,y2:INTEGER): INTEGER; VAR aux : REAL; rowsize: INTEGER; BEGIN grResult:=grOK; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN 0; END; INC(x2); INC(y2); aux := 0.75 * FLOAT(x2-x1); rowsize := TRUNC(aux); IF (FLOAT(rowsize) # aux) THEN INC(rowsize); END; RETURN SIZE(BITMAPFILEHEADER)+SIZE(BITMAPINFOHEADER)+ rowsize*(y2-y1)*4; (*hardcoded 24-bit bitmap format*) END ImageSize; PROCEDURE PutAnim(x1,y1:INTEGER; VAR anim: AnimatType; bit:CARDINAL); VAR bm : BITMAP; rop: DWORD; PROCEDURE PutBit(rop:DWORD); BEGIN SelectObject(grTemp, anim.bitHnd:HGDIOBJ); IF grDirect THEN BitBlt(grWindow,x1,y1,bm.bmWidth,bm.bmHeight,grTemp,0,0,rop); END; BitBlt(grMemory,x1,y1,bm.bmWidth,bm.bmHeight,grTemp,0,0,rop); END PutBit; PROCEDURE PutMask(rop:DWORD); VAR old_color,old_bkcolor: COLORREF; BEGIN SelectObject(grTemp, anim.maskHnd:HGDIOBJ); old_color:=SetTextColor(grMemory,02FFFFFFH); old_bkcolor:=WINGDI.SetBkColor(grMemory,02000000H); BitBlt(grMemory,x1,y1,bm.bmWidth,bm.bmHeight,grTemp,0,0,rop); SetTextColor(grMemory,old_color); WINGDI.SetBkColor(grMemory,old_bkcolor); IF grDirect THEN SetTextColor(grWindow,02FFFFFFH); WINGDI.SetBkColor(grWindow,02000000H); BitBlt(grWindow,x1,y1,bm.bmWidth,bm.bmHeight,grTemp,0,0,rop); SetTextColor(grWindow,old_color); WINGDI.SetBkColor(grWindow,old_bkcolor); END; END PutMask; PROCEDURE GetBkg; BEGIN WITH bm DO BitBlt(grTemp,0,0,bmWidth,bmHeight,grMemory,x1,y1,SRCCOPY); END; END GetBkg; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x1,origX); INC(y1,origY); CASE bit OF CopyPut : rop:=SRCCOPY; |XorPut : rop:=SRCINVERT; |OrPut : rop:=SRCPAINT; |AndPut : rop:=SRCAND; |NotPut : rop:=NOTSRCCOPY; |NotOrPut : rop:=NOTSRCERASE; |InvBitOrPut : rop:=MERGEPAINT; |InvScrAndPut : rop:=SRCERASE; |TransPut,MaskPut,BkgPut: rop:=0; ELSE grResult:=grInvalidParam; RETURN; END; IF (anim.bitHnd = NIL) THEN grResult:=grInvalidParam; RETURN; END; GetObject(anim.bitHnd:HGDIOBJ,SIZE(BITMAP),ADR(bm)); EnterCriticalSection(protect_devices); SelectObject(grTemp,anim.bkgHnd:HGDIOBJ); CASE bit OF BkgPut: IF grDirect THEN BitBlt(grWindow,x1,y1,bm.bmWidth,bm.bmHeight,grTemp,0,0,SRCCOPY); END; BitBlt(grMemory,x1,y1,bm.bmWidth,bm.bmHeight,grTemp,0,0,SRCCOPY); |TransPut: GetBkg; PutMask(SRCAND); PutBit(SRCPAINT); |MaskPut: GetBkg; PutMask(SRCCOPY); ELSE GetBkg; PutBit(rop); END; SelectObject(grTemp,old_Bitmap:HGDIOBJ); LeaveCriticalSection(protect_devices); END PutAnim; PROCEDURE PutImage(x1,y1:INTEGER; VAR bitmap: IMAGE; bit:CARDINAL); VAR hbmp: HBITMAP; img: IMAGE;(*TImage ABSOLUTE bitmap;*) rop : DWORD; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x1,origX); INC(y1,origY); CASE bit OF CopyPut : rop:=SRCCOPY; |XorPut : rop:=SRCINVERT; |OrPut : rop:=SRCPAINT; |AndPut : rop:=SRCAND; |NotPut : rop:=NOTSRCCOPY; |NotOrPut : rop:=NOTSRCERASE; |InvBitOrPut : rop:=MERGEPAINT; |InvScrAndPut : rop:=SRCERASE; ELSE grResult:=grInvalidParam; RETURN; END; WITH img.bmiInfoHeader DO hbmp:=CreateCompatibleBitmap(grMemory,biWidth,biHeight); EnterCriticalSection(protect_devices); SetDIBits(grWindow,hbmp,0,biHeight,ADR(img.bmiBits),img.bmiInfoHeader:BITMAPINFO,DIB_RGB_COLORS); SelectObject(grTemp,hbmp:HGDIOBJ); IF grDirect THEN BitBlt(grWindow,x1,y1,biWidth,biHeight,grTemp,0,0,rop); END; BitBlt(grMemory,x1,y1,biWidth,biHeight,grTemp,0,0,rop); SelectObject(grTemp,old_Bitmap:HGDIOBJ); LeaveCriticalSection(protect_devices); END; DeleteObject(hbmp:HGDIOBJ); END PutImage; PROCEDURE SetActivePage(page:CARDINAL); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (page >= NrVideoPages) THEN page:=0; END; activePage:=page; EnterCriticalSection(protect_devices); SelectObject(grMemory,grBitmap[activePage]:HGDIOBJ); LeaveCriticalSection(protect_devices); IF palExist THEN SetDIBColorTable(grMemory,0,maxColors,colTable^(*colTable[0]*)); END; grDirect:= (activePage = visualPage) AND grUpdate; END SetActivePage; PROCEDURE SetAspectRatio(xasp,yasp:CARDINAL); BEGIN aspX:=xasp; aspY:=yasp; defAspectRatio:=(xasp = 10000) AND (yasp = 10000); END SetAspectRatio; PROCEDURE SetViewPort(x1,y1,x2,y2:INTEGER; clip:BOOLEAN); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; viewPort.x1:=x1; viewPort.y1:=y1; viewPort.x2:=x2; viewPort.y2:=y2; viewPort.clip:=clip; viewPortWidth:=x2-x1; viewPortHeight:=y2-y1; origX:=x1; origY:=y1; MoveTo(0,0); EnterCriticalSection(protect_devices); IF (grClip # NIL) THEN SelectClipRgn(grWindow,NIL); SelectClipRgn(grMemory,NIL); DeleteObject(grClip:HGDIOBJ); grClip:=NIL; END; IF clip THEN grClip:=CreateRectRgn(x1,y1,x2+1,y2+1); SelectClipRgn(grWindow,grClip); SelectClipRgn(grMemory,grClip); END; LeaveCriticalSection(protect_devices); END SetViewPort; PROCEDURE SetVisualPage(page:CARDINAL); VAR lpRect : POINTER TO RECT = NIL; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (page >= NrVideoPages) THEN page:=0; END; visualPage:=page; grDirect:=(activePage = visualPage) AND grUpdate; InvalidateRect(grHandle,lpRect^,FALSE); END SetVisualPage; PROCEDURE SetWriteMode(writemode:INTEGER); VAR fnDrawMode,iBkMode: INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; fnDrawMode:=writemode MOD 10H; iBkMode:=(writemode DIV 10H) SHL 4; CASE fnDrawMode OF CopyMode : fnDrawMode:=R2_COPYPEN; |XorMode : fnDrawMode:=R2_XORPEN; |OrMode : fnDrawMode:=R2_MERGEPEN; |AndMode : fnDrawMode:=R2_MASKPEN; |NotMode : fnDrawMode:=R2_NOTCOPYPEN; |NotScrMode : fnDrawMode:=R2_NOT; |NotXorMode : fnDrawMode:=R2_NOTXORPEN; |NotOrMode : fnDrawMode:=R2_NOTMERGEPEN; |NotAndMode : fnDrawMode:=R2_NOTMASKPEN; |InvColAndMode: fnDrawMode:=R2_MASKNOTPEN; |InvColOrMode : fnDrawMode:=R2_MERGENOTPEN; |InvScrAndMode: fnDrawMode:=R2_MASKPENNOT; |InvScrOrMode : fnDrawMode:=R2_MERGEPENNOT; |BlackMode : fnDrawMode:=R2_BLACK; |WhiteMode : fnDrawMode:=R2_WHITE; |EmptyMode : fnDrawMode:=R2_NOP; ELSE grResult:=grInvalidParam; RETURN; END; CASE iBkMode OF Transparent: iBkMode:=TRANSPARENT; |Opaque : iBkMode:=OPAQUE; ELSE grResult:=grInvalidParam; RETURN; END; SetROP2(grWindow,fnDrawMode); SetBkMode(grWindow,iBkMode); SetROP2(grMemory,fnDrawMode); SetBkMode(grMemory,iBkMode); END SetWriteMode; (*color management routines*) PROCEDURE GetBkColor(): CARDINAL; BEGIN RETURN bkColor; END GetBkColor; PROCEDURE GetColor(): CARDINAL; BEGIN RETURN frColor; END GetColor; PROCEDURE GetDefaultPalette(VAR palette:PaletteType); BEGIN WITH palette DO IF palExist THEN size:=maxColors ELSE size:=256; END; MOVE(colors, DefaultVGAPalette,size*SIZE(CARDINAL)); IF (grDriver = D1bit) THEN colors[0]:=000000H; colors[1]:=0FFFFFFH; END; END; END GetDefaultPalette; PROCEDURE GetNamesPalette(VAR palette:PaletteType); BEGIN WITH palette DO IF palExist THEN size:=maxColors; ELSE size:=256; END; IF (size > NrColorNames) THEN size:=NrColorNames; END; MOVE(colors,NamesPalette,size*SIZE(CARDINAL)); IF (grDriver = D1bit) THEN colors[0]:=000000H; colors[1]:=0FFFFFFH; END; END; END GetNamesPalette; PROCEDURE GetMaxColor(): CARDINAL; BEGIN IF palExist THEN RETURN palSize-1; ELSE RETURN 0FFFFFFH; END; END GetMaxColor; PROCEDURE GetPalette(VAR palette:PaletteType); VAR pe: POINTER TO ARRAY OF PALETTEENTRY; i : INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF palExist THEN WITH palette DO size:=palSize; NEW(pe,size); GetPaletteEntries(grPalette,0,size,pe^); FOR i:=0 TO size-1 DO WITH pe^[i] DO colors[i]:=RGB(peRed,peGreen,peBlue); END; END; END; DISPOSE(pe); ELSE grResult:=grNoPalette; END; END GetPalette; PROCEDURE GetPaletteSize(): INTEGER; BEGIN IF palExist THEN RETURN palSize ELSE RETURN -1; END; END GetPaletteSize; PROCEDURE GetPixel(x,y:INTEGER): CARDINAL; VAR Result: INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN 0; END; EnterCriticalSection(protect_devices); Result:=WINGDI.GetPixel(grMemory,x+origX,y+origY); LeaveCriticalSection(protect_devices); IF palExist THEN RETURN GetNearestPaletteIndex(grPalette,Result); END; RETURN Result; END GetPixel; PROCEDURE GetRGBColor(r,g,b:CARDINAL): CARDINAL; VAR Result: INTEGER; BEGIN Result:=RGB(r,g,b); IF palExist THEN Result:=GetNearestPaletteIndex(grPalette,Result); END; RETURN Result; END GetRGBColor; PROCEDURE GetRGBComponents(color:CARDINAL; VAR r,g,b:CARDINAL); VAR pe: PALETTEENTRY; BEGIN IF palExist THEN WITH pe DO GetPaletteEntries(grPalette,color MOD palSize,1,pe); r:=peRed; g:=peGreen; b:=peBlue; END; ELSE r:=GetRValue(color); g:=GetGValue(color); b:=GetBValue(color); END; END GetRGBComponents; PROCEDURE GetSystemPalette(VAR palette:PaletteType); VAR pe: POINTER TO ARRAY OF PALETTEENTRY; i : INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; WITH palette DO IF palExist THEN size:=maxColors ELSE size:=256; END; NEW(pe,size); GetSystemPaletteEntries(grWindow,0,size,pe^); FOR i:=0 TO size-1 DO WITH pe^[i] DO colors[i]:=RGB(peRed,peGreen,peBlue); END; END; DISPOSE(pe); IF (grDriver = D1bit) THEN colors[0]:=000000H; colors[1]:=0FFFFFFH; END; END; END GetSystemPalette; PROCEDURE SetAllPalette(VAR palette:PaletteType); VAR pe: POINTER TO ARRAY OF PALETTEENTRY; i: CARDINAL; lpRect : POINTER TO RECT = NIL; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF NOT(palExist) THEN grResult:=grNoPalette; RETURN; END; WITH palette DO IF (size:CARDINAL > maxColors) THEN grResult:=grInvalidParam; RETURN; END; NEW(pe,size); FOR i:=0 TO size:CARDINAL-1 DO WITH pe^[i] DO (*,colTable[i]*) peRed:=GetRValue(colors[i]); peGreen:=GetGValue(colors[i]); peBlue:=GetBValue(colors[i]); peFlags:=0; colTable^[i].rgbRed:=peRed; colTable^[i].rgbGreen:=peGreen; colTable^[i].rgbBlue:=peBlue; colTable^[i].rgbReserved:=0; END; END; FOR i:=size:CARDINAL TO maxColors-1 DO WITH pe^[0] DO (*,colTable[i]*)(* all non-used bitmap palette entries equals the first entry*) colTable^[i].rgbRed:=peRed; colTable^[i].rgbGreen:=peGreen; colTable^[i].rgbBlue:=peBlue; colTable^[i].rgbReserved:=0; END; END; EnterCriticalSection(protect_devices); ResizePalette(grPalette,size); SetPaletteEntries(grPalette,0,size,pe^); SetDIBColorTable(grMemory,0,maxColors,colTable^); MapPaletteColors; RealizePalette(grWindow); RealizePalette(grMemory); RealizePalette(grTemp); LeaveCriticalSection(protect_devices); InvalidateRect(grHandle,lpRect^,FALSE); palSize:=size; DISPOSE(pe); END; END SetAllPalette; PROCEDURE SetBkColor(color:CARDINAL); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; bkColor:=color; color:=MapColor(color); WINGDI.SetBkColor(grWindow,color); WINGDI.SetBkColor(grMemory,color); END SetBkColor; PROCEDURE SetColor(color:CARDINAL); BEGIN frColor:=color; WITH lineSettings DO SetLineStyle(linestyle,pattern,thickness); END; IF (grResult # grOK) THEN RETURN; END; color:=MapColor(color); SetTextColor(grWindow,color); SetTextColor(grMemory,color); END SetColor; PROCEDURE SetPalette(nrcolor,color:CARDINAL); VAR col: CARDINAL; BEGIN grResult:=grOK; IF NOT(palExist) THEN grResult:=grNoPalette; RETURN; END; IF (color >= 256) THEN grResult:=grInvalidParam; RETURN; END; col:=DefaultVGAPalette[color]; SetRGBPalette(nrcolor,GetRValue(col),GetGValue(col),GetBValue(col)); END SetPalette; PROCEDURE SetRGBPalette(nrcolor,r,g,b:CARDINAL); VAR pe: PALETTEENTRY; lpRect : POINTER TO RECT = NIL; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF NOT(palExist) THEN grResult:=grNoPalette; RETURN; END; IF (nrcolor >= palSize) THEN grResult:=grInvalidParam; RETURN; END; WITH pe DO peRed:=LOBYTE(r); peGreen:=LOBYTE(g); peBlue:=LOBYTE(b); peFlags:=0; colTable^[nrcolor].rgbRed:=peRed; colTable^[nrcolor].rgbGreen:=peGreen; colTable^[nrcolor].rgbBlue:=peBlue; colTable^[nrcolor].rgbReserved:=0; END; EnterCriticalSection(protect_devices); SetPaletteEntries(grPalette,nrcolor,1,pe); SetDIBColorTable(grMemory,nrcolor,1,colTable^[nrcolor]); RealizePalette(grWindow); RealizePalette(grMemory); RealizePalette(grTemp); LeaveCriticalSection(protect_devices); InvalidateRect(grHandle,lpRect^,FALSE); END SetRGBPalette; (*drawing primitives routines*) PROCEDURE Arc(x,y:INTEGER; start,stop,radius:CARDINAL); BEGIN Ellipse(x,y,start,stop,radius,radius); END Arc; PROCEDURE Circle(x,y:INTEGER; radius:CARDINAL); BEGIN Ellipse(x,y,0,360,radius,radius); END Circle; PROCEDURE DrawBezier(nrpoints:CARDINAL; VAR polypoints:ARRAY OF PointType); VAR size,i: INTEGER; points: POINTER TO ARRAY OF PointType; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; (*SetLength(points,nrpoints); size:=nrpoints*SIZE(PointType); Move(polypoints,points[0],size); FOR i:=0 TO nrpoints-1 DO WITH points[i] DO INC(x,origX); INC(y,origY); END; END;*) IF (nrpoints >= 4) THEN EnterCriticalSection(protect_devices); IF grDirect THEN PolyBezier(grWindow,(*points[0]*)polypoints,nrpoints); END; PolyBezier(grMemory,(*points[0]*)polypoints,nrpoints); LeaveCriticalSection(protect_devices); ELSE grResult:=grInvalidParam; END; (*SetLength(points,0);*) END DrawBezier; PROCEDURE DrawPoly(nrpoints:CARDINAL; VAR polypoints:ARRAY OF PointType); VAR size,i: INTEGER; points: POINTER TO ARRAY OF PointType; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (nrpoints < 2) THEN grResult:=grInvalidParam; RETURN; END; (*SetLength(points,nrpoints); size:=nrpoints*SIZE(PointType); Move(polypoints,points[0],size); FOR i:=0 TO nrpoints-1 DO WITH points[i] DO INC(x,origX); INC(y,origY); END; END;*) EnterCriticalSection(protect_devices); IF grDirect THEN Polyline(grWindow,(*points[0]*)polypoints,nrpoints); END; Polyline(grMemory,(*points[0]*)polypoints,nrpoints); LeaveCriticalSection(protect_devices); (*SetLength(points,0);*) END DrawPoly; PROCEDURE Ellipse(x,y:INTEGER; start,stop,xradius,yradius:CARDINAL); VAR nXStartArc,nYStartArc,nXEndArc,nYEndArc: INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; lastArcCoords.x:=x; lastArcCoords.y:=y; INC(x,origX); INC(y,origY); nXStartArc:=round(FLOAT(xradius)*cos(FLOAT(start)*Rad)); nXEndArc:=round(FLOAT(xradius)*cos(FLOAT(stop)*Rad)); nYStartArc:=round(FLOAT(yradius)*sin(FLOAT(start)*Rad)); nYEndArc:=round(FLOAT(yradius)*sin(FLOAT(stop)*Rad)); IF NOT(defAspectRatio) THEN xradius:=INT(10000*xradius) DIV aspX; yradius:=INT(10000*yradius) DIV aspY; END; EnterCriticalSection(protect_devices); IF grDirect THEN WINGDI.Arc(grWindow,x-INT(xradius),y-INT(yradius),x+INT(xradius)+1,y+INT(yradius)+1,x+nXStartArc,y-nYStartArc,x+nXEndArc,y-nYEndArc); END; WINGDI.Arc(grMemory,x-INT(xradius),y-INT(yradius),x+INT(xradius)+1,y+INT(yradius)+1,x+nXStartArc,y-nYStartArc,x+nXEndArc,y-nYEndArc); LeaveCriticalSection(protect_devices); WITH lastArcCoords DO xstart:=x+nXStartArc; ystart:=y-nYStartArc; xend:=x+nXEndArc; yend:=y-nYEndArc; END; END Ellipse; PROCEDURE GetArcCoords(VAR arccoords:ArcCoordsType); BEGIN arccoords:=lastArcCoords; END GetArcCoords; PROCEDURE GetLineSettings(VAR lineinfo:LineSettingsType); BEGIN lineinfo:=lineSettings; END GetLineSettings; PROCEDURE Line(x1,y1,x2,y2:INTEGER); BEGIN MoveTo(x1,y1); LineTo(x2,y2); END Line; PROCEDURE LineRel(dx,dy:INTEGER); BEGIN LineTo(actX+dx,actY+dy); END LineRel; PROCEDURE LineTo(x,y:INTEGER); VAR x0,y0: INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; x0:=x; y0:=y; INC(x,origX); INC(y,origY); WITH lineSettings DO IF (linestyle # UserBitLn) THEN EnterCriticalSection(protect_devices); IF grDirect THEN WINGDI.LineTo(grWindow,x,y); END; WINGDI.LineTo(grMemory,x,y); LeaveCriticalSection(protect_devices); IF (thickness = NormWidth) THEN PutPixel(x0,y0,frColor); END; ELSE EnterCriticalSection(protect_devices); globalTemp:=0; LineDDA(actX,actY,x0,y0,LineProc,pattern); LeaveCriticalSection(protect_devices); END; MoveTo(x0,y0); END; END LineTo; PROCEDURE MoveRel(dx,dy:INTEGER); BEGIN INC(actX,dx); INC(actY,dy); MoveTo(actX,actY); END MoveRel; PROCEDURE MoveTo(x,y:INTEGER); VAR d : POINT; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; actX:=x; actY:=y; INC(x,origX); INC(y,origY); MoveToEx(grWindow,x,y,d); MoveToEx(grMemory,x,y,d); END MoveTo; PROCEDURE PutPixel(x,y:INTEGER; color:CARDINAL); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x,origX); INC(y,origY); color:=MapColor(color); EnterCriticalSection(protect_devices); IF grDirect THEN SetPixelV(grWindow,x,y,color); END; SetPixelV(grMemory,x,y,color); LeaveCriticalSection(protect_devices); END PutPixel; PROCEDURE Rectangle(x1,y1,x2,y2:INTEGER); VAR pt: ARRAY[1..5] OF POINT; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; INC(x1,origX); INC(y1,origY); INC(x2,origX); INC(y2,origY); IF (x1 # x2) OR (y1 # y2) THEN pt[1].x:=x1; pt[1].y:=y1; pt[2].x:=x2; pt[2].y:=y1; pt[3].x:=x2; pt[3].y:=y2; pt[4].x:=x1; pt[4].y:=y2; pt[5].x:=x1; pt[5].y:=y1; EnterCriticalSection(protect_devices); IF grDirect THEN Polyline(grWindow,pt,5); END; Polyline(grMemory,pt,5); LeaveCriticalSection(protect_devices); ELSE PutPixel(x1,y1,frColor); END; END Rectangle; PROCEDURE RotEllipse(x,y,rot:INTEGER; xradius,yradius:CARDINAL); VAR pt : ARRAY[1..7] OF POINT; cosrot,sinrot: REAL; x1,y1,i : INTEGER; BEGIN xradius:=round(1.3333*FLOAT(xradius)); cosrot:=cos(FLOAT(rot)*Rad); sinrot:=sin(FLOAT(rot)*Rad); pt[1].x:=0; pt[1].y:=-INT(yradius); pt[2].x:= xradius; pt[2].y:=-INT(yradius); pt[3].x:= xradius; pt[3].y:= (yradius); pt[4].x:=0; pt[4].y:= (yradius); pt[5].x:=-INT(xradius); pt[5].y:= (yradius); pt[6].x:=-INT(xradius); pt[6].y:=-INT(yradius); pt[7].x:=0; pt[7].y:=-INT(yradius); FOR i:=1 TO 7 DO x1:=pt[i].x; y1:=pt[i].y; (*perform rotation*) pt[i].x:=x+round(FLOAT( x1)*cosrot+FLOAT(y1)*sinrot); pt[i].y:=y+round(FLOAT(-x1)*sinrot+FLOAT(y1)*cosrot); END; DrawBezier(7,pt); END RotEllipse; PROCEDURE SetLineStyle(linestyle,pattern,thickness:CARDINAL); VAR lgpn : LOGPEN; lstyle: CARDINAL; old : HGDIOBJ; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; CASE linestyle OF SolidLn : lstyle:=PS_SOLID; |DashedLn : lstyle:=PS_DASH; |DottedLn : lstyle:=PS_DOT; |DashDotLn : lstyle:=PS_DASHDOT; |DashDotDotLn : lstyle:=PS_DASHDOTDOT; |UserBitLn,NullLn: lstyle:=PS_NULL; ELSE grResult:=grInvalidParam; RETURN; END; lineSettings.linestyle:=linestyle; lineSettings.pattern:=pattern; lineSettings.thickness:=thickness; WITH lgpn DO lopnStyle:=lstyle; lopnWidth.x:=thickness; lopnColor:=MapColor(frColor); END; EnterCriticalSection(protect_devices); grPen:=CreatePenIndirect(lgpn); (*on NT-based systems can be improved WITH ExtCreatePen*) old:=SelectObject(grWindow,grPen:HGDIOBJ); SelectObject(grMemory,grPen:HGDIOBJ); IF (old:HPEN # old_Pen) THEN DeleteObject(old:HGDIOBJ); END; LeaveCriticalSection(protect_devices); END SetLineStyle; (*filled drawings routines*) PROCEDURE Bar(x1,y1,x2,y2:INTEGER); VAR rc: RECT; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; INC(x1,origX); INC(y1,origY); INC(x2,origX); INC(y2,origY); SetRect(rc,x1,y1,x2+1,y2+1); EnterCriticalSection(protect_devices); IF grDirect THEN WINUSER.FillRect(grWindow,rc,grBrush); END; WINUSER.FillRect(grMemory,rc,grBrush); LeaveCriticalSection(protect_devices); END Bar; PROCEDURE Bar3D(x1,y1,x2,y2:INTEGER; depth:CARDINAL; top:BOOLEAN); VAR pt: ARRAY[1..4] OF POINT; BEGIN FillRect(x1,y1,x2,y2); IF (grResult # grOK) THEN RETURN; END; INC(x1,origX); INC(y1,origY); INC(x2,origX); INC(y2,origY); EnterCriticalSection(protect_devices); IF top THEN pt[1].x:=x1; pt[1].y:=y1; pt[2].x:=x1+INT(depth); pt[2].y:=y1-INT(depth); pt[3].x:=x2+INT(depth); pt[3].y:=y1-INT(depth); pt[4].x:=x2; pt[4].y:=y1; IF grDirect THEN Polyline(grWindow,pt,4); END; Polyline(grMemory,pt,4); END; IF (depth # 0) THEN pt[1].x:=x2+INT(depth); pt[1].y:=y1-INT(depth); pt[2].x:=x2+INT(depth); pt[2].y:=y2-INT(depth); pt[3].x:=x2; pt[3].y:=y2; IF grDirect THEN Polyline(grWindow,pt,3); END; Polyline(grMemory,pt,3); END; LeaveCriticalSection(protect_devices); END Bar3D; PROCEDURE Chord(x,y:INTEGER; start,stop,xradius,yradius:CARDINAL); VAR nXRadial1,nYRadial1,nXRadial2,nYRadial2: INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x,origX); INC(y,origY); nXRadial1:=round(FLOAT(xradius)*cos(FLOAT(start)*Rad)); nXRadial2:=round(FLOAT(xradius)*cos(FLOAT(stop)*Rad)); nYRadial1:=round(FLOAT(yradius)*sin(FLOAT(start)*Rad)); nYRadial2:=round(FLOAT(yradius)*sin(FLOAT(stop)*Rad)); IF NOT(defAspectRatio) THEN xradius:=10000*INT(xradius) DIV aspX; yradius:=10000*INT(yradius) DIV aspY; END; EnterCriticalSection(protect_devices); IF grDirect THEN WINGDI.Chord(grWindow,x:CARDINAL-xradius,y:CARDINAL-yradius,x:CARDINAL+xradius+1,y:CARDINAL+yradius+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2); END; WINGDI.Chord(grMemory,x:CARDINAL-xradius,y:CARDINAL-yradius,x:CARDINAL+xradius+1,y:CARDINAL+yradius+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2); LeaveCriticalSection(protect_devices); END Chord; PROCEDURE FillEllipse(x,y:INTEGER;xradius,yradius:CARDINAL); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x,origX); INC(y,origY); IF NOT(defAspectRatio) THEN xradius:=INT(10000*xradius) DIV aspX; yradius:=INT(10000*yradius) DIV aspY; END; EnterCriticalSection(protect_devices); IF grDirect THEN WINGDI.Ellipse(grWindow,x-INT(xradius),y-INT(yradius),x+INT(xradius)+1,y+INT(yradius)+1); END; WINGDI.Ellipse(grMemory,x-INT(xradius),y-INT(yradius),x+INT(xradius)+1,y+INT(yradius)+1); LeaveCriticalSection(protect_devices); END FillEllipse; PROCEDURE FillPoly(nrpoints:CARDINAL; VAR polypoints:ARRAY OF PointType); VAR size,i: INTEGER; points: POINTER TO ARRAY OF POINT; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; (*SetLength(points,nrpoints); size:=nrpoints*SIZE(PointType); Move(polypoints,points[0],size); FOR i:=0 TO nrpoints-1 DO WITH points[i] DO INC(x,origX); INC(y,origY); END; END;*) IF (nrpoints >= 2) THEN EnterCriticalSection(protect_devices); IF grDirect THEN Polygon(grWindow,(*points[0]*)polypoints,nrpoints); END; Polygon(grMemory,(*points[0]*)polypoints,nrpoints); LeaveCriticalSection(protect_devices); ELSE grResult:=grInvalidParam; END; (*SetLength(points,0);*) END FillPoly; PROCEDURE FillRect(x1,y1,x2,y2:INTEGER); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; INC(x1,origX); INC(y1,origY); INC(x2,origX+1); INC(y2,origY+1); EnterCriticalSection(protect_devices); IF grDirect THEN WINGDI.Rectangle(grWindow,x1,y1,x2,y2); END; WINGDI.Rectangle(grMemory,x1,y1,x2,y2); LeaveCriticalSection(protect_devices); END FillRect; PROCEDURE FloodFill(x,y:INTEGER; color:CARDINAL); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x,origX); INC(y,origY); color:=MapColor(color); EnterCriticalSection(protect_devices); IF grDirect THEN ExtFloodFill(grWindow,x,y,color,floodMode); END; ExtFloodFill(grMemory,x,y,color,floodMode); LeaveCriticalSection(protect_devices); END FloodFill; PROCEDURE GetFillPattern(VAR fillpattern:FillPatternType); BEGIN fillpattern:=(*wingraph.*)fillPattern; END GetFillPattern; PROCEDURE GetFillSettings(VAR fillinfo:FillSettingsType); BEGIN fillinfo:=fillSettings; END GetFillSettings; PROCEDURE InvertRect(x1,y1,x2,y2:INTEGER); VAR rc: RECT; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; INC(x1,origX); INC(y1,origY); INC(x2,origX); INC(y2,origY); SetRect(rc,x1,y1,x2+1,y2+1); EnterCriticalSection(protect_devices); IF grDirect THEN WINUSER.InvertRect(grWindow,rc); END; WINUSER.InvertRect(grMemory,rc); LeaveCriticalSection(protect_devices); END InvertRect; PROCEDURE PieSlice(x,y:INTEGER; start,stop,radius:CARDINAL); BEGIN Sector(x,y,start,stop,radius,radius); END PieSlice; PROCEDURE RoundRect(x1,y1,x2,y2,r:INTEGER); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; IF (x1 > x2) OR (y1 > y2) THEN grResult:=grInvalidParam; RETURN; END; INC(x1,origX); INC(y1,origY); INC(x2,origX); INC(y2,origY); EnterCriticalSection(protect_devices); IF grDirect THEN WINGDI.RoundRect(grWindow,x1,y1,x2+1,y2+1,r,r); END; WINGDI.RoundRect(grMemory,x1,y1,x2+1,y2+1,r,r); LeaveCriticalSection(protect_devices); END RoundRect; PROCEDURE Sector(x,y:INTEGER; start,stop,xradius,yradius:CARDINAL); VAR nXRadial1,nYRadial1,nXRadial2,nYRadial2: INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; INC(x,origX); INC(y,origY); nXRadial1:=round(FLOAT(xradius)*cos(FLOAT(start)*Rad)); nXRadial2:=round(FLOAT(xradius)*cos(FLOAT(stop)*Rad)); nYRadial1:=round(FLOAT(yradius)*sin(FLOAT(start)*Rad)); nYRadial2:=round(FLOAT(yradius)*sin(FLOAT(stop)*Rad)); IF NOT(defAspectRatio) THEN xradius:=INT(10000*xradius) DIV aspX; yradius:=INT(10000*yradius) DIV aspY; END; EnterCriticalSection(protect_devices); IF grDirect THEN Pie(grWindow,x-INT(xradius),y-INT(yradius),x+INT(xradius)+1,y+INT(yradius)+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2); END; Pie(grMemory,x-INT(xradius),y-INT(yradius),x+INT(xradius)+1,y+INT(yradius)+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2); LeaveCriticalSection(protect_devices); END Sector; PROCEDURE SetFillPattern(fillpattern:FillPatternType; color:CARDINAL); VAR i,j : INTEGER; col0,col1: COLORREF; b : CARDINAL8; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; fillPattern:=fillpattern; col1:=MapColor(color); col0:=MapColor(bkColor); EnterCriticalSection(protect_devices); IF (grPattern # NIL) THEN DeleteObject(grPattern:HGDIOBJ); END; grPattern:=CreateCompatibleBitmap(grMemory,8,8); SelectObject(grTemp,grPattern:HGDIOBJ); FOR i:=0 TO 7 DO b:=fillpattern[i+1]; FOR j:=7 TO 0 BY -1 DO IF (b BAND 01H) # 0 THEN SetPixelV(grTemp,j,i,col1) ELSE SetPixelV(grTemp,j,i,col0); END; b:=b SHR 1; END; END; SelectObject(grTemp,old_Bitmap:HGDIOBJ); LeaveCriticalSection(protect_devices); SetFillStyle(UserFill,color); END SetFillPattern; PROCEDURE SetFillStyle(pattern:CARDINAL; color:CARDINAL); VAR lplb: LOGBRUSH; old : HGDIOBJ; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; WITH lplb DO lbStyle:=BS_HATCHED; lbHatch:=0; CASE pattern OF SolidFill : lbStyle:=BS_SOLID; |EmptyFill : lbStyle:=BS_SOLID; color:=bkColor; |LineFill : lbHatch:=HS_HORIZONTAL; |ColFill : lbHatch:=HS_VERTICAL; |HatchFill : lbHatch:=HS_CROSS; |SlashFill : lbHatch:=HS_BDIAGONAL; |BkSlashFill: lbHatch:=HS_FDIAGONAL; |XHatchFill : lbHatch:=HS_DIAGCROSS; |UserFill : lbStyle:=BS_PATTERN; lbHatch:=(grPattern:ULONG_PTR); |NoFill : lbStyle:=BS_NULL; ELSE grResult:=grInvalidParam; RETURN; END; lbColor:=MapColor(color); END; fillSettings.pattern:=pattern; fillSettings.color:=color; EnterCriticalSection(protect_devices); grBrush:=CreateBrushIndirect(lplb); old:=SelectObject(grWindow,grBrush:HGDIOBJ); SelectObject(grMemory,grBrush:HGDIOBJ); IF (old # old_Brush:HGDIOBJ) THEN DeleteObject(old:HGDIOBJ); END; LeaveCriticalSection(protect_devices); END SetFillStyle; PROCEDURE SetFloodMode(floodmode:INTEGER); BEGIN CASE floodmode OF BorderFlood : floodMode:=FLOODFILLBORDER; |SurfaceFlood: floodMode:=FLOODFILLSURFACE; END; END SetFloodMode; (*text AND font handling routines*) PROCEDURE GetFontSettings(VAR fontname:ARRAY OF CHAR; VAR width,height:CARDINAL; VAR ttfont:BOOLEAN); VAR lptm: TEXTMETRIC; len : INTEGER; x:ARRAY[0..255] OF CHAR = ""; BEGIN len:=GetTextFace(grWindow,255,x); fontname[0]:=CHR(len-1); GetTextFace(grWindow,255,fontname[1]); GetTextMetrics(grWindow,lptm); WITH lptm DO width:=tmMaxCharWidth; height:=tmHeight; ttfont:=((tmPitchAndFamily BAND TMPF_TRUETYPE) # 0); END; END GetFontSettings; PROCEDURE GetTextSettings(VAR textinfo:TextSettingsType); BEGIN textinfo:=textSettings; END GetTextSettings; PROCEDURE InstallUserFont(fontname:ARRAY OF CHAR): INTEGER; VAR i,Result: INTEGER; famName: ARRAY[0..255] OF CHAR = ""; BEGIN Result:=-1; grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN Result; END; famName:=fontname; EnterCriticalSection(protect_devices); globalTemp:=0; EnumFontFamilies(grWindow,famName,EnumFontFamProc,0); IF (globalTemp = 1) THEN OuterLoop: FOR i:=0 TO NrMaxFonts-1 DO IF instFont[i]:CHAR = CHR(0) THEN instFont[i]:=fontname; (*+0H;*) Result:=i; BREAK OuterLoop; END; END; END; LeaveCriticalSection(protect_devices); IF (Result = -1) THEN grResult:=grInvalidFont; END; RETURN Result; END InstallUserFont; PROCEDURE OutText(textstring:ARRAY OF CHAR); VAR lpPoint: POINT; len : INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; len:=LENGTH(textstring); EnterCriticalSection(protect_devices); IF grDirect THEN TextOut(grWindow,0,0,textstring,len); END; TextOut(grMemory,0,0,textstring,len); LeaveCriticalSection(protect_devices); GetCurrentPositionEx(grMemory,lpPoint); MoveTo(lpPoint.x-origX,lpPoint.y-origY); END OutText; PROCEDURE OutTextXY(x,y:INTEGER; textstring:ARRAY OF CHAR); BEGIN MoveTo(x,y); OutText(textstring); END OutTextXY; PROCEDURE SetTextJustify(horiz,vert:CARDINAL); VAR htext,vtext: CARDINAL; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; CASE horiz OF LeftText : htext:=TA_LEFT; |CenterText: htext:=TA_CENTER; |RightText : htext:=TA_RIGHT; ELSE grResult:=grInvalidParam; RETURN; END; CASE vert OF TopText : vtext:=TA_TOP; |BottomText : vtext:=TA_BOTTOM; |BaselineText: vtext:=TA_BASELINE; ELSE grResult:=grInvalidParam; RETURN; END; textSettings.horiz:=horiz; textSettings.vert:=vert; SetTextAlign(grWindow,htext BOR vtext BOR TA_UPDATECP); SetTextAlign(grMemory,htext BOR vtext BOR TA_UPDATECP); END SetTextJustify; PROCEDURE SetTextStyle(font,direction,charsize:CARDINAL); VAR loByte,hiByte: BYTE; nrfont : BYTE; fontname : TFontString; lplf : LOGFONT; old : HGDIOBJ; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; loByte:=WINUSER.LOBYTE(WINUSER.LOWORD(font)); hiByte:=WINUSER.HIBYTE(WINUSER.HIWORD(font)); nrfont:=loByte MOD 10H; IF (nrfont>=0) AND (nrfont <= NrMaxFonts-1) THEN fontname:=instFont[nrfont] ELSE fontname:=''; END; IF NOT Equal(fontname, '') THEN textSettings.font:=font; textSettings.direction:=direction; textSettings.charsize:=charsize; IF (charsize <= 5) THEN charsize:=charsize * MinCharSize; END; WITH lplf DO lfHeight:=charsize; lfWidth:=0; lfEscapement:=10*direction; lfOrientation:=10*direction; lfItalic:=FALSE; lfWeight:=(FW_BOLD - FW_NORMAL)*VAL(INTEGER, (loByte DIV 10H)) + FW_NORMAL; IF (hiByte DIV 10H) > 0 THEN lfItalic:=TRUE; END; lfUnderline:=FALSE; IF (hiByte MOD 10H) > 0 THEN lfUnderline:=TRUE; END; lfStrikeOut:=FALSE; lfCharSet:=DEFAULT_CHARSET; lfOutPrecision:=OUT_DEFAULT_PRECIS; lfClipPrecision:=CLIP_DEFAULT_PRECIS; lfQuality:=DEFAULT_QUALITY; lfPitchAndFamily:=DEFAULT_PITCH BOR FF_DONTCARE; lfFaceName:=fontname; END; EnterCriticalSection(protect_devices); grFont:=CreateFontIndirect(lplf); old:=SelectObject(grWindow,grFont:HGDIOBJ); SelectObject(grMemory,grFont:HGDIOBJ); IF (old # old_Font:HGDIOBJ) THEN DeleteObject(old:HGDIOBJ); END; LeaveCriticalSection(protect_devices); ELSE grResult:=grInvalidFontNum; END; END SetTextStyle; PROCEDURE SetUserCharSize(nCharExtra,nBreakExtra,dummy1,dummy2:CARDINAL); BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN; END; SetTextCharacterExtra(grWindow,nCharExtra); SetTextCharacterExtra(grMemory,nCharExtra); SetTextJustification(grWindow,nBreakExtra,1); SetTextJustification(grMemory,nBreakExtra,1); END SetUserCharSize; PROCEDURE TextHeight(textstring:ARRAY OF CHAR): CARDINAL; VAR lpSize: WSIZE; len : INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN 0; END; len:=LENGTH(textstring); GetTextExtentPoint32(grMemory,textstring,len,lpSize); RETURN lpSize.cy; END TextHeight; PROCEDURE TextWidth(textstring:ARRAY OF CHAR): CARDINAL; VAR lpSize: WSIZE; len : INTEGER; BEGIN grResult:=grOK; IF NOT(grEnabled) THEN grResult:=grNoInitGraph; RETURN 0; END; len:=LENGTH(textstring); GetTextExtentPoint32(grMemory,textstring,len,lpSize); RETURN lpSize.cx; END TextWidth; PROCEDURE THREEDto2DAll(coords, pan, centre, position: ThreeDPointType; zoom: REAL; VAR sx,sy: REAL); VAR new: ThreeDPointType; BEGIN coords.x := coords.x + position.x; coords.y := coords.y + position.y; coords.z := coords.z + position.z; new.x := coords.x*cos(pan.x) - coords.z*sin(pan.x); new.z := coords.x*sin(pan.x) + coords.z*cos(pan.x); new.y := coords.y*cos(pan.y) - new.z*sin(pan.y); coords.z := new.y*cos(pan.y) - new.z*sin(pan.y); coords.x := new.x*cos(pan.z) - new.y*sin(pan.z); coords.y := new.x*sin(pan.z) + new.y*cos(pan.z); IF coords.z > 0.0 THEN sx := coords.x / coords.z * zoom + centre.x; sy := coords.y / coords.z * zoom + centre.y; ELSE sx := coords.x * zoom + centre.x; sy := coords.y * zoom + centre.y; END; END THREEDto2DAll; PROCEDURE THREEDto2D(coords: ThreeDPointType; zoom: REAL; VAR sx,sy: REAL); BEGIN sx := coords.x / coords.z * zoom; sy := coords.y / coords.z * zoom; END THREEDto2D; CONST KeyBufSize = 32; VAR protect_keyboard : CRITICAL_SECTION; nr_readkey,nr_inputkey : INTEGER; KeyBuf : ARRAY[1..KeyBufSize] OF CHAR; old_TextSettings : TextSettingsType; textX,textY,textW,textH : INTEGER; (*internal routines*) PROCEDURE InitKeyBuf; BEGIN nr_readkey:=1; nr_inputkey:=1; END InitKeyBuf; PROCEDURE IncKeyCyclic(VAR nr: INTEGER); BEGIN INC(nr); IF (nr > KeyBufSize) THEN nr:=1; END; END IncKeyCyclic; PROCEDURE AddKey(c:CHAR); BEGIN EnterCriticalSection(protect_keyboard); KeyBuf[nr_inputkey]:=c; IncKeyCyclic(nr_inputkey); IF (nr_readkey = nr_inputkey) THEN IF (KeyBuf[nr_readkey]:CHAR) = CHR(0) THEN IncKeyCyclic(nr_readkey); END; IncKeyCyclic(nr_readkey); END; LeaveCriticalSection(protect_keyboard); END AddKey; PROCEDURE AddExtKey(c:CARDINAL8); BEGIN AddKey(CHR(0)); AddKey(c:CHAR); END AddExtKey; PROCEDURE TranslateKeys(code:WPARAM); VAR shift_key,ctrl_key,alt_key: BOOLEAN; BEGIN shift_key:=(GetKeyState(VK_SHIFT) < 0); ctrl_key:=(GetKeyState(VK_CONTROL) < 0); alt_key:=(GetKeyState(VK_MENU) < 0); CASE code OF VK_SPACE: IF alt_key THEN AddExtKey(11); END; |VK_TAB: IF ctrl_key THEN AddKey(VAL(CHAR,30)); END; |VK_BACK: IF alt_key THEN AddExtKey(14); END; |VK_RETURN: IF alt_key THEN AddExtKey(166); END; |VK_APPS: AddExtKey(151); |VK_INSERT: IF ctrl_key THEN AddExtKey(146) ELSE IF alt_key THEN AddExtKey(162) ELSE AddExtKey(82); END; END; |VK_DELETE: IF ctrl_key THEN AddExtKey(147) ELSE IF alt_key THEN AddExtKey(163) ELSE AddExtKey(83); END; END; |VK_HOME: IF ctrl_key THEN AddExtKey(119) ELSE IF alt_key THEN AddExtKey(164) ELSE AddExtKey(71); END; END; |VK_END: IF ctrl_key THEN AddExtKey(117) ELSE IF alt_key THEN AddExtKey(165) ELSE AddExtKey(79); END; END; |VK_NEXT: IF ctrl_key THEN AddExtKey(118) ELSE IF alt_key THEN AddExtKey(161) ELSE AddExtKey(81); END; END; |VK_PRIOR: IF ctrl_key THEN AddExtKey(132) ELSE IF alt_key THEN AddExtKey(153) ELSE AddExtKey(73); END; END; |VK_UP: IF ctrl_key THEN AddExtKey(141) ELSE IF alt_key THEN AddExtKey(152) ELSE AddExtKey(72); END; END; |VK_DOWN: IF ctrl_key THEN AddExtKey(145) ELSE IF alt_key THEN AddExtKey(160) ELSE AddExtKey(80); END; END; |VK_LEFT: IF ctrl_key THEN AddExtKey(115) ELSE IF alt_key THEN AddExtKey(155) ELSE AddExtKey(75); END; END; |VK_RIGHT: IF ctrl_key THEN AddExtKey(116) ELSE IF alt_key THEN AddExtKey(157) ELSE AddExtKey(77); END; END; |VK_F1..VK_F10: IF shift_key THEN AddExtKey(INT(CHR(code-28))) ELSIF ctrl_key THEN AddExtKey(INT(CHR(code-18))) ELSIF alt_key THEN AddExtKey(INT(CHR(code-8))) ELSE AddExtKey(INT(CHR(code-53))); END; |VK_F11,VK_F12: IF shift_key THEN AddExtKey(INT(CHR(code+13))) ELSIF ctrl_key THEN AddExtKey(INT(CHR(code+15))) ELSIF alt_key THEN AddExtKey(INT(CHR(code+17))) ELSE AddExtKey(INT(CHR(code+11))); END; |VK_PAUSE: IF alt_key THEN AddExtKey(169) ELSE IF NOT(ctrl_key) THEN AddExtKey(12); END; END; |VK_CLEAR: IF ctrl_key THEN AddExtKey(143) ELSE AddExtKey(76); (*this is numpad 5 + numlock off*) END; |VK_DIVIDE: IF ctrl_key THEN AddExtKey(148) ELSE IF alt_key THEN AddExtKey(69); END; END; |VK_MULTIPLY: IF ctrl_key THEN AddExtKey(149) ELSE IF alt_key THEN AddExtKey(70); END; END; |VK_SUBTRACT: IF ctrl_key THEN AddExtKey(142) ELSE IF alt_key THEN AddExtKey(74); END; END; |VK_ADD: IF ctrl_key THEN AddExtKey(144) ELSE IF alt_key THEN AddExtKey(78); END; END; |VK_DECIMAL: IF ctrl_key THEN AddExtKey(150) ELSE IF alt_key THEN AddExtKey(114); END; END; ELSE IF ctrl_key THEN CASE code OF ORD('0') : AddExtKey(10); |ORD('1')..ORD('9'): AddExtKey(INT(CHR(code-48))); END; END; IF alt_key THEN CASE code OF ORD('A'): AddExtKey(30); |ORD('B'): AddExtKey(48); |ORD('C'): AddExtKey(46); |ORD('D'): AddExtKey(32); |ORD('E'): AddExtKey(18); |ORD('F'): AddExtKey(33); |ORD('G'): AddExtKey(34); |ORD('H'): AddExtKey(35); |ORD('I'): AddExtKey(23); |ORD('J'): AddExtKey(36); |ORD('K'): AddExtKey(37); |ORD('L'): AddExtKey(38); |ORD('M'): AddExtKey(50); |ORD('N'): AddExtKey(49); |ORD('O'): AddExtKey(24); |ORD('P'): AddExtKey(25); |ORD('Q'): AddExtKey(16); |ORD('R'): AddExtKey(19); |ORD('S'): AddExtKey(31); |ORD('T'): AddExtKey(20); |ORD('U'): AddExtKey(22); |ORD('V'): AddExtKey(47); |ORD('W'): AddExtKey(17); |ORD('X'): AddExtKey(45); |ORD('Y'): AddExtKey(21); |ORD('Z'): AddExtKey(44); |ORD('0'): AddExtKey(129); |ORD('1')..ORD('9'): AddExtKey(INT(CHR(code+71))); ELSE END; END; END; END TranslateKeys; PROCEDURE WinCrtProc(grHandle:HWND; mess:UINT; wParam:WPARAM;lParam:LPARAM): LRESULT [EXPORT, OScall]; BEGIN CASE mess OF WM_CREATE: InitializeCriticalSection(protect_keyboard); InitKeyBuf; |WM_CHAR: AddKey(CHR(wParam)); |WM_KEYDOWN: IF (wParam # VK_SHIFT) AND (wParam # VK_CONTROL) THEN TranslateKeys(wParam); END; |WM_SYSKEYDOWN: IF (wParam # VK_MENU) THEN TranslateKeys(wParam); END; |WM_CLOSE: AddExtKey(107); |WM_DESTROY: DeleteCriticalSection(protect_keyboard); ELSE END; RETURN 0; END WinCrtProc; PROCEDURE CheckNewLine; VAR size : CARDINAL; screen: IMAGE; BEGIN IF (textX+textW > maxX) THEN textX:=0; INC(textY,textH); END; IF (textY+textH > maxY) THEN (*scroll entire text upwards*) REPEAT DEC(textY,textH); UNTIL (textY+textH <= maxY); size:=ImageSize(0,textH,maxX,maxY); NEW(screen.bmiBits,size); GetImage(0,textH,maxX,maxY,screen); ClearViewPort; PutImage(0,0,screen,CopyPut); DISPOSE(screen.bmiBits); END; END CheckNewLine; PROCEDURE DrawCaret(nr:INTEGER); BEGIN CASE nr OF 0: SetFillStyle(SolidFill,GetBkColor()); |1: SetFillStyle(SolidFill,GetColor()); END; IF CaretBlock OR (nr = 0) THEN Bar(textX,textY,textX+textW,textY+textH) ELSE Bar(textX,textY+textH-1,textX+textW,textY+textH); END; END DrawCaret; PROCEDURE TextSettings; VAR viewport: ViewPortType; BEGIN WITH old_TextSettings DO SetTextStyle(DefaultFont BOR (font DIV 10H) SHL 4,0,charsize); (*keep font format*) SetTextJustify(LeftText,TopText); END; textX:=GetX(); textY:=GetY(); textW:=TextWidth('W'); textH:=TextHeight('H'); GetViewSettings(viewport); WITH viewport DO maxX:=x2-x1; maxY:=y2-y1; END; END TextSettings; (*keyboard routines*) PROCEDURE Delay(ms:CARDINAL); BEGIN Sleep(ms); END Delay; PROCEDURE KeyPressed(): BOOLEAN; BEGIN RETURN (nr_readkey # nr_inputkey); END KeyPressed; PROCEDURE ReadBuf(VAR buf:ARRAY OF CHAR; maxchar:BYTE); VAR old_FillSettings : FillSettingsType; nrpass,nrchar,nrcaret: INTEGER; ch : CHAR; BEGIN IF GraphEnabled() THEN GetTextSettings(old_TextSettings); GetFillSettings(old_FillSettings); TextSettings; CheckNewLine; nrpass:=0; nrcaret:=0; nrchar:=0; ch:=CHR(0); IF (maxchar <= 0) THEN maxchar:=255; END; REPEAT IF (nrpass = 0) THEN nrcaret:=1-nrcaret; DrawCaret(nrcaret); nrpass:=10*BlinkRate; ELSE DEC(nrpass); END; IF KeyPressed() THEN ch:=ReadKey(); CASE ch OF CHR(32)..CHR(126): IF (nrcaret = 1) THEN DrawCaret(0); nrcaret:=0; END; INC(nrchar); buf[nrchar]:=ch; OutTextXY(textX,textY,ch); INC(textX,textW); CheckNewLine; nrpass:=0; |CHR(8): IF (nrchar > 0) AND (textX > 0) THEN IF (nrcaret = 1) THEN DrawCaret(0); nrcaret:=0; END; DEC(nrchar); DEC(textX,textW); nrpass:=0; END; |CHR(0): ReadKey(); ELSE END; END; Sleep(10); UNTIL (ch = CHR(13)) OR (nrchar = INT(maxchar)) OR CloseGraphRequest(); IF (nrcaret = 1) THEN DrawCaret(0); END; buf[0]:=CHR(nrchar); MoveTo(0,textY+textH); WITH old_TextSettings DO SetTextStyle(font,direction,charsize); SetTextJustify(horiz,vert); END; WITH old_FillSettings DO SetFillStyle(pattern,color); END; END; END ReadBuf; PROCEDURE ReadKey(): CHAR; VAR Result: CHAR; BEGIN IF GraphEnabled() THEN WHILE (nr_readkey = nr_inputkey) DO Sleep(10); END; EnterCriticalSection(protect_keyboard); Result:=KeyBuf[nr_readkey]; IncKeyCyclic(nr_readkey); LeaveCriticalSection(protect_keyboard); ELSE Result:=CHR(0); END; RETURN Result; END ReadKey; PROCEDURE Sound(hz,dur:CARDINAL); BEGIN Beep(hz,dur); END Sound; PROCEDURE WriteBuf(buf:ARRAY OF CHAR); VAR old_FillSettings: FillSettingsType; nrchar : CARDINAL; ch : CHAR; BEGIN IF GraphEnabled() THEN GetTextSettings(old_TextSettings); GetFillSettings(old_FillSettings); TextSettings; CheckNewLine; FOR nrchar:=1 TO LENGTH(buf) DO ch:=buf[nrchar]; CASE ch OF CHR(32)..CHR(126): DrawCaret(0); OutTextXY(textX,textY,ch); INC(textX,textW); CheckNewLine; |CHR(13): textX:=maxX; CheckNewLine; ELSE END; END; MoveTo(textX,textY); WITH old_TextSettings DO SetTextStyle(font,direction,charsize); SetTextJustify(horiz,vert); END; WITH old_FillSettings DO SetFillStyle(pattern,color); END; END; END WriteBuf; CONST MouseBufSize = 16; VAR graphHandle : HWND; protect_mouse : CRITICAL_SECTION; nr_readmouse,nr_inputmouse: INTEGER; mouseButtons,mouseX,mouseY: CARDINAL; mouseWheel : INTEGER; mouseBuf : ARRAY[1..MouseBufSize] OF MouseEventType; (*internal routines*) PROCEDURE InitMouseBuf; BEGIN nr_readmouse:=1; nr_inputmouse:=1; END InitMouseBuf; PROCEDURE IncMouseCyclic(VAR nr: INTEGER); BEGIN INC(nr); IF (nr > MouseBufSize) THEN nr:=1; END; END IncMouseCyclic; PROCEDURE AddMouseEvent(act:CARDINAL; wParam:WPARAM; lParam:LPARAM); BEGIN EnterCriticalSection(protect_mouse); WITH mouseBuf[nr_inputmouse] DO action:=act; buttons:=0; IF (wParam BAND MK_LBUTTON # 0) THEN buttons:=buttons BOR MouseLeftButton; END; IF (wParam BAND MK_RBUTTON # 0) THEN buttons:=buttons BOR MouseRightButton; END; IF (wParam BAND MK_MBUTTON # 0) THEN buttons:=buttons BOR MouseMiddleButton; END; IF (wParam BAND MK_SHIFT # 0) THEN buttons:=buttons BOR MouseShiftKey; END; IF (wParam BAND MK_CONTROL # 0) THEN buttons:=buttons BOR MouseCtrlKey; END; mouseButtons:=buttons; x:=LOWORD(lParam); y:=HIWORD(lParam); mouseX:=x; mouseY:=y; IF (act = MouseActionWheel) THEN wParam:=HIWORD(wParam); IF (wParam < 32768) THEN wheel:=wParam ELSE wheel:=wParam-65536; END; ELSE wheel:=0; END; mouseWheel:=wheel; END; IncMouseCyclic(nr_inputmouse); IF (nr_readmouse = nr_inputmouse) THEN IncMouseCyclic(nr_readmouse); END; LeaveCriticalSection(protect_mouse); END AddMouseEvent; PROCEDURE WinMouseProc(grHandle:HWND; mess:UINT; wParam:WPARAM; lParam:LPARAM): LRESULT [EXPORT, OScall]; BEGIN CASE mess OF WM_CREATE: graphHandle:=grHandle; InitializeCriticalSection(protect_mouse); InitMouseBuf; |WM_MOUSEMOVE: AddMouseEvent(MouseActionMove,wParam,lParam); |WM_LBUTTONDOWN: AddMouseEvent(MouseActionDown,wParam,lParam); |WM_RBUTTONDOWN: AddMouseEvent(MouseActionDown,wParam,lParam); |WM_MBUTTONDOWN: AddMouseEvent(MouseActionDown,wParam,lParam); |WM_LBUTTONUP: AddMouseEvent(MouseActionUp,wParam,lParam); |WM_RBUTTONUP: AddMouseEvent(MouseActionUp,wParam,lParam); |WM_MBUTTONUP: AddMouseEvent(MouseActionUp,wParam,lParam); |WM_MOUSEWHEEL: AddMouseEvent(MouseActionWheel,wParam,lParam); |WM_DESTROY: DeleteCriticalSection(protect_mouse); ELSE END; RETURN 0; END WinMouseProc; (*mouse routines*) PROCEDURE GetMouseButtons(): CARDINAL; BEGIN RETURN mouseButtons; END GetMouseButtons; PROCEDURE GetMouseEvent(VAR mouseEvent:MouseEventType); BEGIN WHILE (nr_readmouse = nr_inputmouse) DO Sleep(10); END; EnterCriticalSection(protect_mouse); PollMouseEvent(mouseEvent); IncMouseCyclic(nr_readmouse); LeaveCriticalSection(protect_mouse); END GetMouseEvent; PROCEDURE GetMouseX(): CARDINAL; BEGIN RETURN mouseX; END GetMouseX; PROCEDURE GetMouseY(): CARDINAL; BEGIN RETURN mouseY; END GetMouseY; PROCEDURE GetMouseWheel(): INTEGER; VAR Result: INTEGER; BEGIN EnterCriticalSection(protect_mouse); Result:=mouseWheel; mouseWheel:=0; LeaveCriticalSection(protect_mouse); RETURN Result; END GetMouseWheel; PROCEDURE PollMouseEvent(VAR mouseEvent:MouseEventType): BOOLEAN; BEGIN IF (nr_readmouse = nr_inputmouse) THEN RETURN FALSE ELSE mouseEvent:=mouseBuf[nr_readmouse]; RETURN TRUE; END; END PollMouseEvent; PROCEDURE PutMouseEvent(CONST mouseEvent:MouseEventType); BEGIN EnterCriticalSection(protect_mouse); mouseBuf[nr_inputmouse]:=mouseEvent; IncMouseCyclic(nr_inputmouse); IF (nr_readmouse = nr_inputmouse) THEN IncMouseCyclic(nr_readmouse); END; LeaveCriticalSection(protect_mouse); END PutMouseEvent; PROCEDURE SetMouseXY(x,y:INTEGER); VAR lpRect: RECT; BEGIN IF GraphEnabled() THEN GetWindowRect(graphHandle,lpRect); IF (graphHandle = GetForegroundWindow()) THEN WITH lpRect DO SetCursorPos(x+GetSystemMetrics(SM_CXFIXEDFRAME)+left,y+GetSystemMetrics(SM_CYFIXEDFRAME)+GetSystemMetrics(SM_CYCAPTION)+top); END; END; END; END SetMouseXY; (* var simple_colors = { aliceblue: 'f0f8ff', antiquewhite: 'faebd7', aqua: '00ffff', aquamarine: '7fffd4', azure: 'f0ffff', beige: 'f5f5dc', bisque: 'ffe4c4', black: '000000', blanchedalmond: 'ffebcd', blue: '0000ff', blueviolet: '8a2be2', brown: 'a52a2a', burlywood: 'deb887', cadetblue: '5f9ea0', chartreuse: '7fff00', chocolate: 'd2691e', coral: 'ff7f50', cornflowerblue: '6495ed', cornsilk: 'fff8dc', crimson: 'dc143c', cyan: '00ffff', darkblue: '00008b', darkcyan: '008b8b', darkgoldenrod: 'b8860b', darkgray: 'a9a9a9', darkgreen: '006400', darkkhaki: 'bdb76b', darkmagenta: '8b008b', darkolivegreen: '556b2f', darkorange: 'ff8c00', darkorchid: '9932cc', darkred: '8b0000', darksalmon: 'e9967a', darkseagreen: '8fbc8f', darkslateblue: '483d8b', darkslategray: '2f4f4f', darkturquoise: '00ced1', darkviolet: '9400d3', deeppink: 'ff1493', deepskyblue: '00bfff', dimgray: '696969', dodgerblue: '1e90ff', feldspar: 'd19275', firebrick: 'b22222', floralwhite: 'fffaf0', forestgreen: '228b22', fuchsia: 'ff00ff', gainsboro: 'dcdcdc', ghostwhite: 'f8f8ff', gold: 'ffd700', goldenrod: 'daa520', gray: '808080', green: '008000', greenyellow: 'adff2f', honeydew: 'f0fff0', hotpink: 'ff69b4', indianred : 'cd5c5c', indigo : '4b0082', ivory: 'fffff0', khaki: 'f0e68c', lavender: 'e6e6fa', lavenderblush: 'fff0f5', lawngreen: '7cfc00', lemonchiffon: 'fffacd', lightblue: 'add8e6', lightcoral: 'f08080', lightcyan: 'e0ffff', lightgoldenrodyellow: 'fafad2', lightgrey: 'd3d3d3', lightgreen: '90ee90', lightpink: 'ffb6c1', lightsalmon: 'ffa07a', lightseagreen: '20b2aa', lightskyblue: '87cefa', lightslateblue: '8470ff', lightslategray: '778899', lightsteelblue: 'b0c4de', lightyellow: 'ffffe0', lime: '00ff00', limegreen: '32cd32', linen: 'faf0e6', magenta: 'ff00ff', maroon: '800000', mediumaquamarine: '66cdaa', mediumblue: '0000cd', mediumorchid: 'ba55d3', mediumpurple: '9370d8', mediumseagreen: '3cb371', mediumslateblue: '7b68ee', mediumspringgreen: '00fa9a', mediumturquoise: '48d1cc', mediumvioletred: 'c71585', midnightblue: '191970', mintcream: 'f5fffa', mistyrose: 'ffe4e1', moccasin: 'ffe4b5', navajowhite: 'ffdead', navy: '000080', oldlace: 'fdf5e6', olive: '808000', olivedrab: '6b8e23', orange: 'ffa500', orangered: 'ff4500', orchid: 'da70d6', palegoldenrod: 'eee8aa', palegreen: '98fb98', paleturquoise: 'afeeee', palevioletred: 'd87093', papayawhip: 'ffefd5', peachpuff: 'ffdab9', peru: 'cd853f', pink: 'ffc0cb', plum: 'dda0dd', powderblue: 'b0e0e6', purple: '800080', red: 'ff0000', rosybrown: 'bc8f8f', royalblue: '4169e1', saddlebrown: '8b4513', salmon: 'fa8072', sandybrown: 'f4a460', seagreen: '2e8b57', seashell: 'fff5ee', sienna: 'a0522d', silver: 'c0c0c0', skyblue: '87ceeb', slateblue: '6a5acd', slategray: '708090', snow: 'fffafa', springgreen: '00ff7f', steelblue: '4682b4', tan: 'd2b48c', teal: '008080', thistle: 'd8bfd8', tomato: 'ff6347', turquoise: '40e0d0', violet: 'ee82ee', violetred: 'd02090', wheat: 'f5deb3', white: 'ffffff', whitesmoke: 'f5f5f5', yellow: 'ffff00', yellowgreen: '9acd32' }; for (var key in simple_colors) { if (color_string == key) { color_string = simple_colors[key]; } } *) BEGIN grEnabled:=FALSE; palExist:=FALSE; grDriver:=-1; KeyboardHook:=NILPROC; MouseHook:=NILPROC; screenWidth:=GetSystemMetrics(WINUSER.SM_CXSCREEN); screenHeight:=GetSystemMetrics(WINUSER.SM_CYSCREEN); SetInternColors; KeyboardHook:=WinCrtProc; MouseHook:=WinMouseProc; FINALLY IF grEnabled THEN CloseGraph; END; IF colTable # NIL THEN DISPOSE(colTable); END; END wingraphics.