12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364 |
- unit Graph;
- { *********************************************************************
- $Id$
- Copyright 1997,1998 Matthias K"oppe <[email protected]>
- This library is free software in the sense of the GNU Library GPL;
- see `License Conditions' below.
- Info:
- This unit provides the functions of Borland's Graph unit for linux,
- it uses the SVGAlib to do the actual work, so you must have svgalib
- on your system
- This version requires Free Pascal 0.99.5 or higher.
- Large parts have not yet been implemented or tested.
- History:
- Date Version Who Comments
- ---------- -------- ------- -------------------------------------
- 25-Sep-97 0.1 mkoeppe Initial multi-target version.
- 05-Oct-97 0.1.1 mkoeppe Linux: Added mouse use. Improved clipping.
- Added bitmap functions.
- ??-Oct-97 0.1.2 mkoeppe Fixed screenbuf functions.
- 07-Feb-98 0.1.3 mkoeppe Fixed a clipping bug in DOS target.
- 12-Apr-98 0.1.4 mkoeppe Linux: Using Michael's re-worked SVGALIB
- interface; prepared for FPC 0.99.5; removed
- dependencies.
- 15-Apr-98 0.1.5 michael Renamed to graph, inserted needed SVGlib
- declarations here so it can be used independently
- of the svgalib unit. Removed things that are NOT
- part of Borland's Graph from the unit interface.
-
- License Conditions:
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Library General Public
- License as published by the Free Software Foundation; either
- version 2 of the License, or (at your option) any later version.
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Library General Public License for more details.
- You should have received a copy of the GNU Library General Public
- License along with this library; if not, write to the Free
- Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- *********************************************************************}
- {
- Functions not currently implemented :
- -------------------------------------
- SetWriteMode
- SetLineStyle
- SetFillPattern
- SetUserCharSize
- SetTextStyle
- FillPoly
- FloodFill
- GetArcCoords
- Arc
- SetAspectRatio
- PieSlice
- Sector
-
- (please remove what you implement fom this list)
- }
- interface
- { ---------------------------------------------------------------------
- Constants
- ---------------------------------------------------------------------}
- const
- NormalPut = 0;
- CopyPut = 0;
- XORPut = 1;
- ORPut = 2;
- ANDPut = 3;
- NotPut = 4;
- BackPut = 8;
- Black = 0;
- Blue = 1;
- Green = 2;
- Cyan = 3;
- Red = 4;
- Magenta = 5;
- Brown = 6;
- LightGray = 7;
- DarkGray = 8;
- LightBlue = 9;
- LightGreen = 10;
- LightCyan = 11;
- LightRed = 12;
- LightMagenta = 13;
- Yellow = 14;
- White = 15;
- Border = 16;
- SolidLn = 0;
- DottedLn = 1;
- CenterLn = 2;
- DashedLn = 3;
- UserBitLn = 4;
- EmptyFill = 0;
- SolidFill = 1;
- LineFill = 2;
- LtSlashFill = 3;
- SlashFill = 4;
- BkSlashFill = 5;
- LtBkSlashFill = 6;
- HatchFill = 7;
- XHatchFill = 8;
- InterleaveFill = 9;
- WideDotFill = 10;
- CloseDotFill = 11;
- UserFill = 12;
- NormWidth = 1;
- ThickWidth = 3;
- const
- LeftText = 0;
- CenterText = 1;
- RightText = 2;
- BottomText = 0;
- TopText = 2;
- BaseLine = 3;
- LeadLine = 4;
- { ---------------------------------------------------------------------
- Types
- ---------------------------------------------------------------------}
- Type
- FillPatternType = array[1..8] of byte;
- ArcCoordsType = record
- x,y : integer;
- xstart,ystart : integer;
- xend,yend : integer;
- end;
- RGBColor = record
- r,g,b,i : byte;
- end;
-
- PaletteType = record
- Size : integer;
- Colors : array[0..767]of Byte;
- end;
-
- LineSettingsType = record
- linestyle : word;
- pattern : word;
- thickness : word;
- end;
- TextSettingsType = record
- font : word;
- direction : word;
- charsize : word;
- horiz : word;
- vert : word;
- end;
- FillSettingsType = record
- pattern : word;
- color : longint;
- end;
- PointType = record
- x,y : integer;
- end;
- ViewPortType = record
- x1,y1,x2,y2 : integer;
- Clip : boolean;
- end;
-
- const
- fillpattern : array[0..12] of FillPatternType = (
- ($00,$00,$00,$00,$00,$00,$00,$00), { Hintergrundfarbe }
- ($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff), { Vordergrundfarbe }
- ($ff,$ff,$00,$00,$ff,$ff,$00,$00), { === }
- ($01,$02,$04,$08,$10,$20,$40,$80), { /// }
- ($07,$0e,$1c,$38,$70,$e0,$c1,$83), { /// als dicke Linien }
- ($07,$83,$c1,$e0,$70,$38,$1c,$0e), { \\\ als dicke Linien }
- ($5a,$2d,$96,$4b,$a5,$d2,$69,$b4), { \ \\ \ }
- ($ff,$88,$88,$88,$ff,$88,$88,$88), { K„stchen }
- ($18,$24,$42,$81,$81,$42,$24,$18), { Rauten }
- ($cc,$33,$cc,$33,$cc,$33,$cc,$33), { "Mauermuster" }
- ($80,$00,$08,$00,$80,$00,$08,$00), { weit auseinanderliegende Punkte }
- ($88,$00,$22,$00,$88,$00,$22,$00), { dichte Punkte}
- (0,0,0,0,0,0,0,0) { benutzerdefiniert }
- );
-
- { ---------------------------------------------------------------------
- Function Declarations
- ---------------------------------------------------------------------}
- { Retrieving coordinates }
- function GetX: Integer;
- function GetY: Integer;
- { Pixel-oriented routines }
- procedure PutPixel(X, Y: Integer; Pixel: Word);
- function GetPixel(X, Y: Integer): Word;
- { Line-oriented primitives }
- procedure SetWriteMode(WriteMode: Integer);
- procedure LineTo(X, Y: Integer);
- procedure LineRel(Dx, Dy: Integer);
- procedure MoveTo(X, Y: Integer);
- procedure MoveRel(Dx, Dy: Integer);
- procedure Line(x1, y1, x2, y2: Integer);
- procedure SetLineStyle(LineStyle: Word; Pattern: Word; Thickness: Word);
- { Linearly bounded primitives }
- procedure Rectangle(x1, y1, x2, y2: Integer);
- procedure Bar(x1, y1, x2, y2: Integer);
- procedure Bar3D(x1, y1, x2, y2: Integer; Depth: Word; Top: Boolean);
- procedure DrawPoly(NumPoints: Word; var PolyPoints);
- procedure FillPoly(NumPoints: Word; var PolyPoints);
- procedure SetFillStyle(Pattern: Word; Color: Word);
- procedure SetFillPattern(Pattern: FillPatternType; Color: Word);
- procedure FloodFill(X, Y: Integer; Border: Word);
- { Nonlinearly bounded primitives }
- procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
- procedure GetArcCoords(var ArcCoords: ArcCoordsType);
- procedure Circle(X, Y: Integer; Radius: Word);
- procedure Ellipse(X, Y: Integer; StAngle, EndAngle: Word; XRadius, YRadius : Word);
- procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
- procedure SetAspectRatio(Xasp, Yasp: Word);
- procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
- procedure Sector(X, Y: Integer; StAngle, EndAngle, XRadius, YRadius: Word);
- { Color routines }
- procedure SetBkColor(ColorNum: Word);
- procedure SetColor(Color: Word);
- { Bitmap utilities }
- procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
- procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);
- function ImageSize(x1, y1, x2, y2: Integer): LongInt;
- { Text routines}
- procedure OutText(TextString: string);
- procedure OutTextXY(X, Y: Integer; TextString: string);
- procedure SetTextJustify(Horiz, Vert: Word);
- procedure SetTextStyle(Font, Direction: Word; CharSize: Word);
- procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word);
- { Graph clipping method }
- procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
- { Init/Done }
- procedure InitVideo;
- procedure DoneVideo;
- { Other }
- function GetResX: Integer;
- function GetResY: Integer;
- function GetAspect: Real;
- const
- NoGraphics: Boolean = false;
- implementation
- uses Objects, Linux;
- { ---------------------------------------------------------------------
- SVGA bindings.
- ---------------------------------------------------------------------}
- { Link with VGA, gl and c libraries }
- {$linklib vga}
- {$linklib gl}
- {$linklib c}
- { Constants }
- const
- { VGA modes }
- TEXT = 0; { Compatible with VGAlib v1.2 }
- G320x200x16 = 1;
- G640x200x16 = 2;
- G640x350x16 = 3;
- G640x480x16 = 4;
- G320x200x256 = 5;
- G320x240x256 = 6;
- G320x400x256 = 7;
- G360x480x256 = 8;
- G640x480x2 = 9;
- G640x480x256 = 10;
- G800x600x256 = 11;
- G1024x768x256 = 12;
- G1280x1024x256 = 13; { Additional modes. }
- G320x200x32K = 14;
- G320x200x64K = 15;
- G320x200x16M = 16;
- G640x480x32K = 17;
- G640x480x64K = 18;
- G640x480x16M = 19;
- G800x600x32K = 20;
- G800x600x64K = 21;
- G800x600x16M = 22;
- G1024x768x32K = 23;
- G1024x768x64K = 24;
- G1024x768x16M = 25;
- G1280x1024x32K = 26;
- G1280x1024x64K = 27;
- G1280x1024x16M = 28;
- G800x600x16 = 29;
- G1024x768x16 = 30;
- G1280x1024x16 = 31;
- G720x348x2 = 32; { Hercules emulation mode }
- G320x200x16M32 = 33; { 32-bit per pixel modes. }
- G640x480x16M32 = 34;
- G800x600x16M32 = 35;
- G1024x768x16M32 = 36;
- G1280x1024x16M32 = 37;
- { additional resolutions }
- G1152x864x16 = 38;
- G1152x864x256 = 39;
- G1152x864x32K = 40;
- G1152x864x64K = 41;
- G1152x864x16M = 42;
- G1152x864x16M32 = 43;
- G1600x1200x16 = 44;
- G1600x1200x256 = 45;
- G1600x1200x32K = 46;
- G1600x1200x64K = 47;
- G1600x1200x16M = 48;
- G1600x1200x16M32 = 49;
- GLASTMODE = 49;
- { Text }
-
- WRITEMODE_OVERWRITE = 0;
- WRITEMODE_MASKED = 1;
- FONT_EXPANDED = 0;
- FONT_COMPRESSED = 2;
- { Types }
- type
- pvga_modeinfo = ^vga_modeinfo;
- vga_modeinfo = record
- width,
- height,
- bytesperpixel,
- colors,
- linewidth, { scanline width in bytes }
- maxlogicalwidth, { maximum logical scanline width }
- startaddressrange, { changeable bits set }
- maxpixels, { video memory / bytesperpixel }
- haveblit, { mask of blit functions available }
- flags: Longint; { other flags }
- { Extended fields: }
- chiptype, { Chiptype detected }
- memory, { videomemory in KB }
- linewidth_unit: Longint; { Use only a multiple of this as parameter for
- set_displaystart }
- linear_aperture: PChar; { points to mmap secondary mem aperture of card }
- aperture_size: Longint; { size of aperture in KB if size>=videomemory.}
- set_aperture_page: procedure (page: Longint);
- { if aperture_size<videomemory select a memory page }
- extensions: Pointer; { points to copy of eeprom for mach32 }
- { depends from actual driver/chiptype.. etc. }
- end;
- PGraphicsContext = ^TGraphicsContext;
- TGraphicsContext = record
- ModeType: Byte;
- ModeFlags: Byte;
- Dummy: Byte;
- FlipPage: Byte;
- Width: LongInt;
- Height: LongInt;
- BytesPerPixel: LongInt;
- Colors: LongInt;
- BitsPerPixel: LongInt;
- ByteWidth: LongInt;
- VBuf: pointer;
- Clip: LongInt;
- ClipX1: LongInt;
- ClipY1: LongInt;
- ClipX2: LongInt;
- ClipY2: LongInt;
- ff: pointer;
- end;
-
- { vga functions }
- function vga_init: Longint; Cdecl; External;
- function vga_getdefaultmode: Longint; Cdecl; External;
- function vga_hasmode(mode: Longint): Boolean; Cdecl; External;
- function vga_getmodeinfo(mode: Longint): pvga_modeinfo; Cdecl; External;
- function vga_setmode(mode: Longint): Longint; Cdecl; External;
- { gl functions }
- procedure gl_setpixel(x, y, c: LongInt); Cdecl; External;
- function gl_getpixel(x, y: LongInt): LongInt; cdecl; external;
- procedure gl_line(x1, y1, x2, y2, c: LongInt); Cdecl; External;
- procedure gl_fillbox(x, y, w, h, c: LongInt); Cdecl; External;
- procedure gl_circle(x, y, r, c: LongInt ); Cdecl; External;
- procedure gl_getbox(x, y, w, h: LongInt; dp: pointer); Cdecl; External;
- procedure gl_putbox(x, y, w, h: LongInt; dp: pointer); Cdecl; External;
- procedure gl_disableclipping; Cdecl; External;
- procedure gl_enableclipping; Cdecl; External;
- procedure gl_putboxpart(x, y, w, h, bw, bh: LongInt; b: pointer; xo, yo: LongInt); Cdecl; External;
- function gl_rgbcolor(r, g, b: LongInt): LongInt; Cdecl; External;
- function gl_setcontextvga(m: LongInt): LongInt; Cdecl; External;
- function gl_allocatecontext: PGraphicsContext; Cdecl; External;
- procedure gl_getcontext(gc: PGraphicsContext); Cdecl; External;
- procedure gl_setrgbpalette; Cdecl; External;
- procedure gl_freecontext(gc: PGraphicsContext); Cdecl; External;
- procedure gl_setclippingwindow(x1, y1, x2, y2: LongInt); Cdecl; External;
- procedure gl_setwritemode(wm: LongInt); Cdecl; External;
- procedure gl_setfontcolors(bg, fg: LongInt); Cdecl; External;
- procedure gl_writen(x, y, n: LongInt; s: PChar); Cdecl; External;
- procedure gl_setfont(fw, fh: LongInt; fdp: pointer); Cdecl; External;
- procedure gl_copyboxfromcontext(var gc: TGraphicsContext; x1, y1, w, h, x2, y2: LongInt); Cdecl; External;
- procedure gl_setcontext(gc: PGraphicsContext); Cdecl; External;
- function gl_setcontextvgavirtual(m: LongInt): LongInt; cdecl; external;
- procedure gl_font8x8; Cdecl; External;
- { ---------------------------------------------------------------------
- Types, constants and variables
- ---------------------------------------------------------------------}
- var
- DrawDelta: TPoint;
- CurX, CurY: Integer;
- TheColor, TheFillColor: LongInt;
- IsVirtual: Boolean;
- PhysicalScreen, BackScreen: PGraphicsContext;
- ColorTable: array[0..15] of LongInt;
- const
- BgiColors: array[0..15] of LongInt
- = ($000000, $000080, $008000, $008080,
- $800000, $800080, $808000, $C0C0C0,
- $808080, $0000FF, $00FF00, $00FFFF,
- $FF0000, $FF00FF, $FFFF00, $FFFFFF);
- const
- DoUseMarker: Boolean = true;
- TheMarker: Char = '~';
- TextColor: LongInt = 15;
- MarkColor: LongInt = 15;
- BackColor: LongInt = 0;
- FontWidth: Integer = 8;
- FontHeight: Integer = 8;
- var
- sHoriz, sVert: Word;
- { initialisierte Variablen }
- const
- SourcePage: Word = 0;
- DestPage: Word = 0;
- { Retrieves the capabilities for the current mode }
- const
- vmcImage = 1;
- vmcCopy = 2;
- vmcSaveRestore = 4;
- vmcBuffer = 8;
- vmcBackPut = 16;
- { ---------------------------------------------------------------------
- Graphics Vision Layer
- ---------------------------------------------------------------------}
- { Types and constants }
- var
- SizeX, SizeY: Word;
- { Draw origin and clipping rectangle }
- var
- DrawOrigin: TPoint;
- ClipRect: TRect;
- MetaClipRect: TRect;
- MetaOrigin: TPoint;
- { Font attributes }
- const
- ftNormal = 0;
- ftBold = 1;
- ftThin = 2;
- ftItalic = 4;
- var
- sFont, sColor:Word;
- sCharSpace: Integer;
- sMarker: Char;
- sAttr: Word;
- { Windows-style text metric }
- type
- PTextMetric = ^TTextMetric;
- TTextMetric = record
- tmHeight: Integer;
- tmAscent: Integer;
- tmDescent: Integer;
- tmInternalLeading: Integer;
- tmExternalLeading: Integer;
- tmAveCharWidth: Integer;
- tmMaxCharWidth: Integer;
- tmWeight: Integer;
- tmItalic: Byte;
- tmUnderlined: Byte;
- tmStruckOut: Byte;
- tmFirstChar: Byte;
- tmLastChar: Byte;
- tmDefaultChar: Byte;
- tmBreakChar: Byte;
- tmPitchAndFamily: Byte;
- tmCharSet: Byte;
- tmOverhang: Integer;
- tmDigitizedAspectX: Integer;
- tmDigitizedAspectY: Integer;
- end;
- { Bitmap utilities }
- type
- PBitmap = ^TBitmap;
- TBitmap = record
- Width, Height: Integer;
- Data: record end;
- end;
-
- { Storing screen regions }
- type
- TVgaBuf = record
- Bounds: TRect;
- Mem: Word;
- Size: Word;
- end;
- const
- pbNone = 0;
- pbCopy = 1;
- pbClear = 2;
- type
- PScreenBuf = ^TScreenBuf;
- TScreenBuf = record
- Mode: Word;
- Rect: TRect;
- Size: LongInt;
- Info: LongInt
- end;
- { Procedures and functions }
-
- procedure SetColors;
- var
- i: Integer;
- begin
- for i:=0 to 15 do
- ColorTable[i] := gl_rgbcolor(BgiColors[i] shr 16,
- (BgiColors[i] shr 8) and 255,
- BgiColors[i] and 255)
- end;
- procedure InitVideo;
- var
- VgaMode: Integer;
- ModeInfo: pvga_modeinfo;
- begin
- if NoGraphics
- then begin
- SizeX := 640;
- SizeY := 480
- end
- else begin
- VgaMode := vga_getdefaultmode;
- if (VgaMode = -1) then VgaMode := G320X200X256;
- if (not vga_hasmode(VgaMode))
- then begin
- WriteLn('BGI: Mode not available.');
- Halt(1)
- end;
- ModeInfo := vga_getmodeinfo(VgaMode);
- {IsVirtual := (ModeInfo^.colors = 16) or (ModeInfo^.flags and IS_MODEX <> 0);}
- IsVirtual := true;
- { We always want a back screen (for buffering). }
- if IsVirtual
- then begin
- { Create virtual screen }
- gl_setcontextvgavirtual(VgaMode);
- BackScreen := gl_allocatecontext;
- gl_getcontext(BackScreen)
- end;
- vga_setmode(VgaMode);
- gl_setcontextvga(VgaMode); { Physical screen context. }
- PhysicalScreen := gl_allocatecontext;
- gl_getcontext(PhysicalScreen);
- if (PhysicalScreen^.colors = 256) then gl_setrgbpalette;
- SetColors;
- SizeX := PhysicalScreen^.Width;
- SizeY := PhysicalScreen^.Height
- end
- end;
- procedure DoneVideo;
- begin
- if not NoGraphics
- then begin
- if IsVirtual then gl_freecontext(BackScreen);
- vga_setmode(TEXT)
- end
- end;
- procedure SetDelta;
- begin
- if ClipRect.Empty
- then begin
- DrawDelta.X := 10000;
- DrawDelta.Y := 10000;
- end
- else begin
- DrawDelta.X := DrawOrigin.X;
- DrawDelta.y := DrawOrigin.y
- end
- end;
- procedure SetDrawOrigin(x, y: Integer);
- begin
- DrawOrigin.x := x;
- DrawOrigin.y := y;
- SetDelta;
- end;
- procedure SetDrawOriginP(var P: TPoint);
- begin
- SetDrawOrigin(P.x, P.y)
- end;
- procedure SetClipRect(x1, y1, x2, y2: Integer);
- begin
- Cliprect.Assign(x1, y1, x2, y2);
- if not NoGraphics
- then begin
- if ClipRect.Empty
- then gl_setclippingwindow(0, 0, 0, 0)
- else gl_setclippingwindow(x1, y1, x2 - 1, y2 - 1);
- {gl_enableclipping(0);}
- end;
- SetDelta
- end;
- procedure SetClipRectR(var R: TRect);
- begin
- SetClipRect(R.A.X, R.A.Y, R.B.X, R.B.Y);
- end;
- procedure SetMetaOrigin(x, y: Integer);
- begin
- MetaOrigin.x := x;
- MetaOrigin.y := y
- end;
- procedure SetMetaOriginP(P: TPoint);
- begin
- SetMetaOrigin(P.x, P.y)
- end;
- procedure SetMetaClipRect(x1, y1, x2, y2: Integer);
- begin
- MetaCliprect.Assign(x1, y1, x2, y2)
- end;
- procedure SetMetaClipRectR(var R: TRect);
- begin
- MetaCliprect := R
- end;
- function GetBuffer(Size: Word): pointer;
- begin
- { No metafiling available. }
- GetBuffer := nil
- end;
- Procedure HoriLine(x1,y1,x2: Integer);
- begin
- Line(x1, y1, x2, y1)
- end;
- Procedure VertLine(x1,y1,y2: Integer);
- begin
- Line(x1, y1, x1, y2)
- end;
- procedure FillCircle(xm, ym, r: Integer);
- begin
- FillEllipse(xm, ym, r, r)
- end;
- { Text routines }
- function TextWidth(s: string): Integer;
- var
- i: Integer;
- begin
- if DoUseMarker
- then begin
- For i := Length(s) downto 1 do
- If s[i] = TheMarker then Delete(s, i, 1);
- If s = ''
- then TextWidth := 0
- else TextWidth := Length(s) * FontWidth
- end
- else TextWidth := Length(s) * FontWidth
- end;
- function TextHeight(s: string): Integer;
- begin
- TextHeight := FontHeight
- end;
- procedure OutText(TextString: string);
- begin
- OutTextXY(GetX, GetY, TextString)
- end;
- procedure OutTextXY(X, Y: Integer; TextString: string);
- var
- P, Q: PChar;
- i: Integer;
- col: Boolean;
- begin
- if NoGraphics or (TextString='') then Exit;
- gl_setwritemode(FONT_COMPRESSED + WRITEMODE_MASKED);
- case sHoriz of
- CenterText : Dec(x, TextWidth(TextString) div 2);
- RightText : Dec(x, TextWidth(TextString));
- end; { case }
- case sVert of
- CenterText : Dec(y, TextHeight(TextString) div 2);
- BottomText, BaseLine : Dec(y, TextHeight(TextString));
- end; { case }
- MoveTo(X, Y);
- P := @TextString[1]; Q := P;
- col := false;
- gl_setfontcolors(BackColor, TextColor);
- For i := 1 to Length(TextString) do
- begin
- If (Q[0] = TheMarker) and DoUseMarker
- then begin
- If col then gl_setfontcolors(BackColor, MarkColor)
- else gl_setfontcolors(BackColor, TextColor);
- If Q <> P then begin
- gl_writen(CurX, CurY, Q-P, P);
- MoveRel(FontWidth * (Q-P), 0)
- end;
- col := not col;
- P := Q + 1
- end;
- {Inc(Q)} Q := Q + 1
- end;
- If col then gl_setfontcolors(BackColor, MarkColor)
- else gl_setfontcolors(BackColor, TextColor);
- If Q <> P then begin
- gl_writen(CurX, CurY, Q-P, P);
- MoveRel(FontWidth * (Q-P), 0)
- end
- end;
- procedure SetTextJustify(Horiz, Vert: Word);
- begin
- sHoriz := Horiz; sVert := Vert;
- end;
- procedure SetTextStyle(Font, Direction: Word; CharSize: Word);
- begin
- end;
- procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word);
- begin
- end;
- procedure SetKern(Enable: Boolean);
- begin
- end;
- procedure SetMarker(Marker: Char);
- begin
- TheMarker := Marker
- end;
- procedure SetTextParams(Font: Word; CharSpace: Integer; Color: Word;
- UseMarker: Boolean);
- type
- pp = ^pointer;
- function FixCol(Col: Byte): Byte;
- { SVGALIB cannot write black characters... }
- begin
- if Col=0 then FixCol := 1 else FixCol := Col
- end; { FixCol }
- begin
- sColor := Color; sCharSpace := CharSpace; sFont := Font;
- if not NoGraphics then begin
- TextColor := ColorTable[FixCol(Color and 15)];
- MarkColor := ColorTable[FixCol((Color shr 8) and 15)];
- DoUseMarker := UseMarker;
- gl_setfont(8, 8, (pp(@gl_font8x8))^);
- end
- end;
- function GetResX: Integer;
- begin
- GetResX := 96;
- end; { GetResX }
- function GetResY: Integer;
- begin
- GetResY := 96
- end; { GetResY }
- function GetAspect: Real;
- begin
- GetAspect := 1.0
- end; { GetAspect }
- procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
- begin
- SetDrawOrigin(x1, y1);
- if Clip then SetClipRect(x1, y1, x2+1, y2+1)
- else SetClipRect(0, 0, SizeX, SizeY)
- end;
- { VGAMEM }
- type
- TImage = record
- end;
- procedure CopyScreen(x1, y1, x2, y2, x3, y3: Integer);
- begin
- if not NoGraphics and (x2 > x1) and (y2 > y1)
- then gl_copyboxfromcontext(PhysicalScreen^, x1, y1, x2 - x1, y2 - y1, x3, y3);
- end;
- { BGI-like Image routines
- }
- function CopyImage(Image: pointer): pointer;
- begin
- CopyImage := nil
- end;
- function CutImage(x1, y1, x2, y2: Integer): pointer;
- var
- Image: PBitmap;
- begin
- GetMem(Image, ImageSize(x1, y1, x2, y2));
- if Image <> nil
- then GetImage(x1, y1, x2, y2, Image^);
- CutImage := Image;
- end;
- procedure GetImageExtent(Image: pointer; var Extent: Objects.TPoint);
- begin
- if Image = nil
- then begin
- Extent.X := 0;
- Extent.Y := 0
- end
- else begin
- Extent.X := PBitmap(Image)^.Width;
- Extent.Y := PBitmap(Image)^.Height
- end;
- end;
- procedure FreeImage(Image: pointer);
- var
- P: TPoint;
- begin
- if Image <> nil
- then begin
- GetImageExtent(Image, P);
- FreeMem(Image, ImageSize(0, 0, P.x - 1, P.y - 1));
- end;
- end;
- function LoadImage(var S: TStream): pointer;
- begin
- LoadImage := nil
- end;
- function MaskedImage(Image: pointer): pointer;
- begin
- MaskedImage := nil;
- end;
- procedure PasteImage(X, Y: Integer; Image: pointer; BitBlt: Word);
- begin
- if Image <> nil then PutImage(X, Y, Image^, BitBlt)
- end;
- procedure StoreImage(var S: TStream; Image: pointer);
- begin
- end;
- { Storing screen regions }
- function PrepBuf(var R: Objects.TRect; Action: Word; var Buf: TVgaBuf): Boolean;
- begin
- if BackScreen <> nil
- then begin
- Buf.Bounds := R;
- gl_setcontext(BackScreen);
- gl_disableclipping;
- case Action of
- pbCopy : gl_copyboxfromcontext(PhysicalScreen^,
- R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y,
- R.A.X, R.A.Y);
- pbClear : gl_fillbox(R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y, 0);
- end;
- PrepBuf := true;
- SetDrawOrigin(0, 0);
- SetClipRectR(R);
- end
- else PrepBuf := false
- end; { PrepBuf }
- procedure EndBufDraw;
- begin
- if not NoGraphics
- then gl_setcontext(PhysicalScreen);
- end; { EndBufDraw }
- procedure ReleaseBuf(var Buf: TVgaBuf);
- begin
- end; { ReleaseBuf }
- procedure PasteRectAt(var R: Objects.TRect; P: Objects.TPoint; var Buf: TVgaBuf);
- begin
- if not NoGraphics and (BackScreen <> nil)
- then gl_copyboxfromcontext(BackScreen^,
- R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y,
- P.X, P.Y);
- end;
- procedure PasteRect(var R: Objects.TRect; var Buf: TVgaBuf);
- begin
- PasteRectAt(R, R.A, Buf);
- end; { PasteRect }
- function StoreScreen(x1, y1, x2, y2: Integer): PScreenBuf;
- var
- s: LongInt;
- Handle: Word;
- p: pointer;
- SaveOrigin: TPoint;
- function NewScreenBuf(AMode: Word; AnInfo: LongInt): PScreenBuf;
- var
- p: PScreenBuf;
- Begin
- New(p);
- p^.Mode := AMode;
- p^.Size := s;
- p^.Rect.Assign(x1, y1, x2, y2);
- p^.Info := AnInfo;
- NewScreenBuf := p
- End;
- Begin
- { General Images }
- s := 0;
- SaveOrigin := DrawOrigin;
- SetDrawOrigin(0, 0);
- p := CutImage(x1, y1, x2-1, y2-1);
- SetDrawOriginP(SaveOrigin);
- If p <> nil
- then StoreScreen := NewScreenBuf(2, LongInt(p))
- else StoreScreen := nil
- End;
- procedure FreeScreenBuf(Buf: PScreenBuf);
- Begin
- If Buf <> nil then Begin
- case Buf^.Mode of
- 2 : FreeImage(pointer(Buf^.Info));
- end;
- Dispose(Buf)
- End
- End;
- procedure DrawScreenBufAt(Buf: PScreenBuf; x3, y3: Integer);
- var
- SaveOrigin: TPoint;
- Begin
- If Buf <> nil then
- case Buf^.Mode of
- 2 :
- begin
- SaveOrigin := DrawOrigin;
- SetDrawOrigin(0, 0);
- PasteImage(x3, y3, pointer(Buf^.Info), NormalPut);
- SetDrawOriginP(SaveOrigin);
- end
- end
- End;
- procedure DrawScreenBuf(Buf: PScreenBuf);
- Begin
- If Buf <> nil then
- DrawScreenBufAt(Buf, Buf^.Rect.A.x, Buf^.Rect.A.y)
- End;
- function GetVgaMemCaps: Word;
- begin
- GetVgaMemCaps := vmcCopy
- end;
- procedure GetTextMetrics(var Metrics: TTextMetric);
- begin
- with Metrics do
- begin
- tmHeight := 8;
- tmAscent := 8;
- tmDescent := 0;
- tmInternalLeading := 0;
- tmExternalLeading := 0;
- tmAveCharWidth := 8;
- tmMaxCharWidth := 8;
- tmWeight := 700;
- tmItalic := 0;
- tmUnderlined := 0;
- tmStruckOut := 0;
- tmFirstChar := 0;
- tmLastChar := 255;
- tmDefaultChar := 32;
- tmBreakChar := 32;
- tmPitchAndFamily := 0;
- tmCharSet := 0;
- tmOverhang := 0;
- tmDigitizedAspectX := 100;
- tmDigitizedAspectY := 100
- end;
- end;
- { ---------------------------------------------------------------------
- Real graph implementation
- ---------------------------------------------------------------------}
- function GetX: Integer;
- begin
- GetX := CurX - DrawDelta.X
- end;
- function GetY: Integer;
- begin
- GetY := CurY - DrawDelta.Y
- end;
- { Pixel-oriented routines }
- procedure PutPixel(X, Y: Integer; Pixel: Word);
- begin
- if not NoGraphics
- then gl_setpixel(X + DrawDelta.X, Y + DrawDelta.Y, Pixel)
- end;
- function GetPixel(X, Y: Integer): Word;
- begin
- if NoGraphics
- then GetPixel := 0
- else GetPixel := gl_getpixel(X + DrawDelta.X, Y + DrawDelta.Y)
- end;
- { Line-oriented primitives }
- procedure SetWriteMode(WriteMode: Integer);
- begin
- { Graph.SetWriteMode(WriteMode) }
- end;
- procedure LineTo(X, Y: Integer);
- begin
- if not NoGraphics
- then gl_line(CurX, CurY, X + DrawDelta.X, Y + DrawDelta.Y, TheColor);
- CurX := X + DrawDelta.X;
- CurY := Y + DrawDelta.Y
- end;
- procedure LineRel(Dx, Dy: Integer);
- begin
- if not NoGraphics
- then gl_line(CurX, CurY, CurX + Dx, CurY + Dy, TheColor);
- CurX := CurX + Dx;
- CurY := CurY + Dy
- end;
- procedure MoveTo(X, Y: Integer);
- begin
- CurX := X + DrawDelta.X;
- CurY := Y + DrawDelta.Y
- end;
- procedure MoveRel(Dx, Dy: Integer);
- begin
- CurX := CurX + Dx;
- CurY := CurY + Dy
- end;
- procedure Line(x1, y1, x2, y2: Integer);
- begin
- if not NoGraphics
- then gl_line(x1 + DrawDelta.X, y1 + DrawDelta.Y,
- x2 + DrawDelta.X, y2 + DrawDelta.Y, TheColor)
- end;
- procedure SetLineStyle(LineStyle: Word; Pattern: Word; Thickness: Word);
- begin
- end;
- procedure SetFillPattern(Pattern: FillPatternType; Color: Word);
- begin
- end;
- { Linearly bounded primitives }
- procedure Rectangle(x1, y1, x2, y2: Integer);
- begin
- MoveTo(x1, y1);
- LineTo(x2, y1);
- LineTo(x2, y2);
- LineTo(x1, y2);
- LineTo(x1, y1)
- end;
- procedure Bar(x1, y1, x2, y2: Integer);
- var
- R: TRect;
- begin
- if not NoGraphics
- then begin
- R.Assign(x1 + DrawDelta.X, y1 + DrawDelta.Y,
- x2 + DrawDelta.X + 1, y2 + DrawDelta.Y + 1);
- R.Intersect(ClipRect);
- if not R.Empty
- then gl_fillbox(R.A.X, R.A.Y,
- R.B.X - R.A.X, R.B.Y - R.A.Y, TheFillColor)
- end;
- end;
- procedure Bar3D(x1, y1, x2, y2: Integer; Depth: Word; Top: Boolean);
- begin
- Bar(x1,y1,x2,y2);
- Rectangle(x1,y1,x2,y2);
- if top then begin
- Moveto(x1,y1);
- Lineto(x1+depth,y1-depth);
- Lineto(x2+depth,y1-depth);
- Lineto(x2,y1);
- end;
- Moveto(x2+depth,y1-depth);
- Lineto(x2+depth,y2-depth);
- Lineto(x2,y2);
- end;
- procedure DrawPoly(NumPoints: Word; var PolyPoints);
- type
- ppointtype = ^pointtype;
- var
- i : longint;
- begin
- line(ppointtype(@polypoints)[NumPoints-1].x,
- ppointtype(@polypoints)[NumPoints-1].y,
- ppointtype(@polypoints)[0].x,
- ppointtype(@polypoints)[0].y);
- for i:=0 to NumPoints-2 do
- line(ppointtype(@polypoints)[i].x,
- ppointtype(@polypoints)[i].y,
- ppointtype(@polypoints)[i+1].x,
- ppointtype(@polypoints)[i+1].y);
- end;
- procedure FillPoly(NumPoints: Word; var PolyPoints);
- begin
- end;
- procedure SetFillStyle(Pattern: Word; Color: Word);
- begin
- TheFillColor := ColorTable[Color]
- end;
- procedure FloodFill(X, Y: Integer; Border: Word);
- begin
- end;
- { Nonlinearly bounded primitives
- }
- procedure GetArcCoords(var ArcCoords: ArcCoordsType);
- begin
- end;
- procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
- begin
- end;
- procedure Circle(X, Y: Integer; Radius: Word);
- begin
- if not NoGraphics
- then gl_circle(X + DrawDelta.X, Y + DrawDelta.Y, Radius, TheColor)
- end;
- procedure Ellipse(X, Y: Integer;
- StAngle, EndAngle: Word; XRadius, YRadius : Word);
- begin
- end;
- procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
- begin
- Bar(X - XRadius, Y - YRadius, X + XRadius, Y + YRadius);
- end;
- procedure SetAspectRatio(Xasp, Yasp: Word);
- begin
- end;
- procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
- begin
- end;
- procedure Sector(X, Y: Integer;
- StAngle, EndAngle, XRadius, YRadius: Word);
- begin
- end;
- { Color routines
- }
- procedure SetBkColor(ColorNum: Word);
- begin
- BackColor := ColorTable[ColorNum];
- end;
- procedure SetColor(Color: Word);
- begin
- TheColor := ColorTable[Color];
- end;
- procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
- var
- SaveClipRect: TRect;
- begin
- with TBitmap(Bitmap) do
- begin
- Width := x2 - x1 + 1;
- Height := y2 - y1 + 1;
- if not NoGraphics
- then begin
- {gl_disableclipping(0);}
- SaveClipRect := ClipRect;
- SetClipRect(0, 0, SizeX, SizeY);
- gl_getbox(x1 + DrawDelta.X, y1 + DrawDelta.Y,
- x2 - x1 + 1, y2 - y1 + 1, @Data);
- SetClipRectR(SaveClipRect)
- end;
- end;
- end;
- procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);
- var
- R: TRect;
- SaveClipRect: TRect;
- begin
- if not NoGraphics then
- with TBitmap(Bitmap) do
- begin
- {gl_putbox(x + DrawDelta.X, y + DrawDelta.Y, Width, Height, @Data)}
- R.Assign(X + DrawDelta.X, Y + DrawDelta.Y,
- X + DrawDelta.X + Width, Y + DrawDelta.Y + Height);
- R.Intersect(ClipRect);
- if not R.Empty
- then begin
- {gl_disableclipping(0);}
- SaveClipRect := ClipRect;
- SetClipRect(0, 0, SizeX, SizeY);
- gl_putboxpart(R.A.X, R.A.Y,
- R.B.X - R.A.X, R.B.Y - R.A.Y,
- Width, Height,
- @Data,
- R.A.X - X, R.A.Y - Y);
- SetClipRectR(SaveClipRect);
- end;
- end;
- end; { PutImage }
- function ImageSize(x1, y1, x2, y2: Integer): LongInt;
- begin
- if NoGraphics
- then ImageSize := SizeOf(TBitmap)
- else ImageSize := SizeOf(TBitmap)
- + LongInt(x2 - x1 + 1) * LongInt(y2 - y1 + 1) * PhysicalScreen^.BytesPerPixel;
- end;
- begin
- { Give up root permissions if we are root. }
- if geteuid = 0 then vga_init;
- end.
- {
- $Log$
- Revision 1.1 1998-04-15 13:40:11 michael
- + Initial implementation of graph unit
- }
|