123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821 |
- 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
- SetAspectRatio
- (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;
- const
- { Error codes }
- grOK = 0;
- grNoInitGraph = -1;
- grNotDetected = -2;
- grFileNotFound = -3;
- grInvalidDriver = -4;
- grNoLOadMem = -5;
- grNoScanMem = -6;
- grNoFloodMem = -7;
- grFontNotFound = -8;
- grNoFontMem = -9;
- grInvalidmode = -10;
- grError = -11;
- grIOerror = -12;
- grInvalidFont = -13;
- grInvalidFontNum = -14;
-
-
- { ---------------------------------------------------------------------
- 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);
- Function GetBkColor : Word;
- Function GetColor : Word;
- function GetMaxColor : Word;
- Procedure GetDefaultPalette (Var Palette : PaletteType);
- Procedure GetPalette (Var Palette : PaletteType);
- Function GetPaletteSize : Word;
- Procedure SetAllPalette (Var Palette);
- Procedure SetPalette (ColorNr : Word; NewColor : ShortInt);
- { Filling/linestyle utilities }
- Procedure GetFillSettings (Var FillSettings : FillSettingsType);
- Procedure GetFillPattern (Var FillPattern : FillPatternType);
- Procedure GetLineSettings (Var LineInfo : LineSettingsType);
- { 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);
- procedure GetTextSettings (Var TextInfo : TextSettingsType);
- { Graph clipping method }
- Procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
- Procedure ClearViewPort;
- Procedure GetViewSettings (Var ViewPort : ViewPortType);
- { Init/Done }
- procedure InitVideo;
- procedure DoneVideo;
- { Other }
- function GetResX: Integer;
- function GetResY: Integer;
- function GetAspect: Real;
- Procedure GetAspectRatio (Var x,y : Word);
- function GetMaxX : Integer;
- function GetMAxY : Integer;
- { For compatibility }
- Procedure DetectGraph (Var Driver,Mode : Integer);
- Procedure InitGraph (Var Driver,Mode : Integer;DriverPath : String);
- Procedure CloseGraph;
- Function GraphResult : Integer;
- Procedure GraphDefaults ;
- Function GraphErrorMsg (Errcode : Integer) : String;
- Procedure ClearDevice;
- Function GetDriverName : String;
- Function GetGraphMode : Integer;
- Function GetMaxMode : Word;
- Function GetModeName (Var Modus : INteger) : String;
- Procedure GetModeRange (Driver : Integer; Var loModus,HiModus : Integer);
- Function InstallUserDriver (DriverPat :String; AutodetectPtr : Pointer) : Integer;
- Function InstallUserFont (FontPath : String) : Integer;
- Function RegisterBGIDriver (Driver : Pointer) : Integer;
- Function RegisterBGIFont (Font : Pointer) : Integer;
- Procedure RestoreCRTmode;
- Procedure SetActivePage (Page : Word);
- Procedure SetGraphBufSize (BufSize : Word);
- Procedure SetGraphMode (Mode :Integer);
- Procedure SetVisualPage (Page : Word);
- const
- NoGraphics: Boolean = false;
- { VGA modes }
- GTEXT = 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;
- implementation
- uses Objects, Linux;
- { ---------------------------------------------------------------------
- SVGA bindings.
- ---------------------------------------------------------------------}
- { Link with VGA, gl and c libraries }
- {$linklib vga}
- {$linklib vgagl}
- {$linklib c}
- Const
- { 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;
- Function vga_getxdim : Longint; cdecl;external;
- Function vga_getydim : 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;
- TheFillPattern : FillPatternType;
- TheLineSettings : LineSettingsType;
- ThePalette : PaletteType;
- TheTextSettings : TextSettingsType;
- TheFillSettings : FillSettingsType;
-
- 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;
- { Not used
- 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(GTEXT)
- 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 GetAspectRatio (Var x,y : Word);
- begin
- X:=GetMaxX;
- Y:=GetMaxY
- end; { GetAspect }
- Var LastViewPort : ViewPortType;
- procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
- begin
- LastViewPort.X1:=X1;
- LastViewPort.Y1:=Y1;
- LastViewPort.X2:=X2;
- LastViewPort.Y2:=Y2;
- LastViewPort.Clip:=Clip;
- SetDrawOrigin(x1, y1);
- if Clip then SetClipRect(x1, y1, x2+1, y2+1)
- else SetClipRect(0, 0, SizeX, SizeY)
- end;
- Procedure ClearViewPort;
- begin
- With LastViewPort do
- gl_fillbox(X1,Y1,X2-X1,Y2-Y1,BackColor);
- end;
- Procedure GetViewSettings (Var ViewPort : ViewPortType);
- begin
- ViewPort:=LastViewPort;
- 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;
- 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
- DrawPoly (NumPoints,PolyPoints);
- end;
- procedure SetFillStyle(Pattern: Word; Color: Word);
- begin
- TheFillColor := ColorTable[Color]
- end;
- procedure FloodFill(X, Y: Integer; Border: Word);
- begin
- end;
- { Nonlinearly bounded primitives
- }
- Var LastArcCoords : ArcCoordsType;
- procedure SetArcCoords (X,y,xradius,yradius,Stangle,endangle : integer);
- begin
- LastArcCoords.X:=X;
- LastArccOords.y:=y;
- Lastarccoords.xstart:=x+round(xradius*cos(stangle*pi/180));
- Lastarccoords.ystart:=y-round(yradius*sin(stangle*pi/180));
- LastArccoords.xend:=x+round(xradius*cos(endangle*pi/180));
- LastArccoords.yend:=y-round(yradius*sin(endangle*pi/180));
- end;
- procedure GetArcCoords(var ArcCoords: ArcCoordsType);
- begin
- ArcCoords:=LastArcCoords;
- end;
- procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
- begin
- Ellipse (X,y,stangle,endangle,Radius,radius);
- 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);
- Var I : longint;
- tmpang : real;
-
- begin
- SetArcCoords (X,Y,xradius,yradius,Stangle,EndAngle);
- For i:= StAngle To EndAngle Do
- Begin
- tmpAng:= i*Pi/180;
- curX:= X + Round (xRadius*Cos (tmpAng));
- curY:= Y - Round (YRadius*Sin (tmpAng));
- PutPixel (curX, curY, TheColor);
- End;
- end;
- procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
- Var I,tmpcolor : longint;
- tmpang : real;
- tmpx,tmpy : Integer;
-
- begin
- tmpcolor:=Thecolor;
- SetColor(TheFillColor);
- For i:= 0 to 180 Do
- Begin
- tmpAng:= i*Pi/180;
- curX:= Round (xRadius*Cos (tmpAng));
- curY:= Round (YRadius*Sin (tmpAng));
- tmpX:= X - curx;
- tmpy:= Y + cury;
- curx:=x+curx;
- cury:=y-cury;
- Line (curX, curY,tmpx,tmpy);
- PutPixel (curx,cury,tmpcolor);
- PutPixel (tmpx,tmpy,tmpcolor);
- End;
- SetColor(tmpcolor);
- end;
- procedure SetAspectRatio(Xasp, Yasp: Word);
- begin
- //!! Needs implementing.
- end;
- procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
- Begin
- sector (x,y,stangle,endangle,radius,radius);
- end;
- procedure Sector(X, Y: Integer;
- StAngle, EndAngle, XRadius, YRadius: Word);
- Var I,tmpcolor : longint;
- tmpang : real;
- ac : arccoordstype;
-
- begin
- tmpcolor:=Thecolor;
- SetColor(TheFillColor);
- For i:= stangle to endangle Do
- Begin
- tmpAng:= i*Pi/180;
- curX:= x+Round (xRadius*Cos (tmpAng));
- curY:= y-Round (YRadius*Sin (tmpAng));
- Line (x,y,curX, curY);
- PutPixel (curx,cury,tmpcolor);
- End;
- SetColor(tmpcolor);
- getarccoords(ac);
- Line (x,y,ac.xstart,ac.ystart);
- Line (x,y,ac.xend,ac.yend);
- end;
- { Color routines
- }
- procedure SetBkColor(ColorNum: Word);
- begin
- BackColor := ColorTable[ColorNum];
- end;
- Function GetBkColor : Word;
- begin
- GetBkColor:=BackColor;
- end;
- procedure SetColor(Color: Word);
- begin
- TheColor := ColorTable[Color];
- end;
- Function GetColor : Word;
- begin
- GetColor:=TheColor;
- end;
- function GetMaxColor : Word;
- begin
- getmaxcolor:=16;
- 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;
- function GetMaxX : Integer;
- begin
- GetMaxX:=vga_getxdim;
- end;
- function GetMAxY : Integer;
- begin
- GetMaxY:=vga_getydim;
- end;
- Procedure DetectGraph (Var Driver,Mode : Integer);
- begin
- Driver:=9;
- Mode:=vga_getdefaultmode;
- If Mode=-1 then mode:=0;
- end;
- Var VgaMode : Integer;
- Procedure InitGraph (Var Driver,Mode : Integer;DriverPath : String);
- var
- ModeInfo: pvga_modeinfo;
- begin
- If Mode=0 then
- VgaMode := vga_getdefaultmode
- else
- VGAMode :=Mode;
- 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;
- Procedure CloseGraph;
- begin
- DoneVideo;
- end;
- Function GraphResult : Integer;
- begin
- GraphResult:=0;
- end;
- Procedure GraphDefaults ;
- begin
- end;
- Function GraphErrorMsg (Errcode : Integer) : String;
- begin
- GraphErrorMsg:='';
- end;
- Procedure ClearDevice;
- begin
- SetViewPort (0,0,GetMaxX,GetMaxY,False);
- ClearViewPort;
- MoveTo(0,0);
- end;
- Procedure GetDefaultPalette (Var Palette : Palettetype);
- begin
- //!! Not yet implemented.
- end;
- Function GetDriverName : String;
- begin
- GetDriverName:='libvga';
- end;
- Function GetGraphMode : Integer;
- begin
- GetGraphMode:=VgaMode;
- end;
- Procedure GetFillPattern (Var FillPattern : FillPatternType);
- begin
- FillPattern:=TheFillPattern;
- end;
- Procedure GetFillSettings (Var FillSettings : FillSettingsType);
- begin
- FillSettings:=TheFillSettings;
- end;
- Procedure GetLineSettings (Var LineInfo : LineSettingsType);
- begin
- LineInfo:=TheLineSettings;
- end;
- Function GetMaxMode : Word;
- begin
- GetMaxMode:=GLastMode;
- end;
- Function GetModeName (Var Modus : INteger) : String;
- begin
- GetModeName:='VGA'
- end;
- Procedure GetModeRange (Driver : Integer; Var loModus,HiModus : Integer);
- begin
- LoModus:=1;
- HiModus:=GLASTMODE;
- end;
- Procedure GetPalette (Var Palette : PaletteType);
- begin
- Palette:=ThePalette;
- end;
- Procedure SetAllPalette (Var Palette);
- begin
- ThePalette:=PaletteType(Palette);
- end;
- Procedure SetPalette (ColorNr : Word; NewColor : ShortInt);
- begin
- //!! not implemented.
- end;
- Function GetPaletteSize : Word;
- begin
- GetPaletteSize:=16;
- end;
- Procedure GetTextSettings (Var TextInfo : TextSettingsType);
- begin
- TextInfo:=TheTextSettings;
- end;
- Function InstallUserDriver (DriverPat :String; AutodetectPtr : Pointer) : Integer;
- begin
- InstallUserDriver:=grError;
- end;
- Function InstallUserFont (FontPath : String) : Integer;
- begin
- InstallUserFont:=0;
- end;
- Function RegisterBGIDriver (Driver : Pointer) : Integer;
- begin
- RegisterBGIDriver:=grError;
- end;
- Function RegisterBGIFont (Font : Pointer) : Integer;
- begin
- RegisterBGIFont:=grError;
- end;
- Procedure RestoreCRTmode;
- begin
- vga_setmode(GTEXT);
- end;
- Procedure SetActivePage (Page : Word);
- begin
- //!! Not implemented
- end;
- Procedure SetVisualPage (Page : Word);
- begin
- //!! Not implemented
- end;
- Procedure SetGraphBufSize (BufSize : Word);
- begin
- end;
- Procedure SetGraphMode (Mode :Integer);
- begin
- vga_setmode(Mode);
- VgaMode:=Mode;
- end;
- begin
- { Give up root permissions if we are root. }
- if geteuid = 0 then vga_init;
- end.
- {
- $Log$
- Revision 1.9 1998-09-13 19:22:06 michael
- + Implemented dummies for all missing functions
- Revision 1.8 1998/09/11 09:24:55 michael
- Added missing functions so mandel compiles and runs
- Revision 1.7 1998/08/24 08:23:47 michael
- Better initgraph handling.
- Revision 1.6 1998/08/14 09:20:36 michael
- Typo fixed. linklib gl to linklib vgagl
- Revision 1.5 1998/08/12 14:01:08 michael
- small fix in sector, pieslice replaced by call to sector
- Revision 1.4 1998/08/12 13:25:33 michael
- + added arc,ellipse,fillelipse,sector,pieslice
- Revision 1.3 1998/08/10 09:01:58 michael
- + Added some functions to improve compatibility
- Revision 1.2 1998/05/12 10:42:47 peter
- * moved getopts to inc/, all supported OS's need argc,argv exported
- + strpas, strlen are now exported in the systemunit
- * removed logs
- * removed $ifdef ver_above
- Revision 1.1 1998/04/15 13:40:11 michael
- + Initial implementation of graph unit
- }
|