graph.pp 42 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821
  1. unit Graph;
  2. { *********************************************************************
  3. $Id$
  4. Copyright 1997,1998 Matthias K"oppe <[email protected]>
  5. This library is free software in the sense of the GNU Library GPL;
  6. see `License Conditions' below.
  7. Info:
  8. This unit provides the functions of Borland's Graph unit for linux,
  9. it uses the SVGAlib to do the actual work, so you must have svgalib
  10. on your system
  11. This version requires Free Pascal 0.99.5 or higher.
  12. Large parts have not yet been implemented or tested.
  13. History:
  14. Date Version Who Comments
  15. ---------- -------- ------- -------------------------------------
  16. 25-Sep-97 0.1 mkoeppe Initial multi-target version.
  17. 05-Oct-97 0.1.1 mkoeppe Linux: Added mouse use. Improved clipping.
  18. Added bitmap functions.
  19. ??-Oct-97 0.1.2 mkoeppe Fixed screenbuf functions.
  20. 07-Feb-98 0.1.3 mkoeppe Fixed a clipping bug in DOS target.
  21. 12-Apr-98 0.1.4 mkoeppe Linux: Using Michael's re-worked SVGALIB
  22. interface; prepared for FPC 0.99.5; removed
  23. dependencies.
  24. 15-Apr-98 0.1.5 michael Renamed to graph, inserted needed SVGlib
  25. declarations here so it can be used independently
  26. of the svgalib unit. Removed things that are NOT
  27. part of Borland's Graph from the unit interface.
  28. License Conditions:
  29. This library is free software; you can redistribute it and/or
  30. modify it under the terms of the GNU Library General Public
  31. License as published by the Free Software Foundation; either
  32. version 2 of the License, or (at your option) any later version.
  33. This library is distributed in the hope that it will be useful,
  34. but WITHOUT ANY WARRANTY; without even the implied warranty of
  35. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  36. Library General Public License for more details.
  37. You should have received a copy of the GNU Library General Public
  38. License along with this library; if not, write to the Free
  39. Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  40. *********************************************************************}
  41. {
  42. Functions not currently implemented :
  43. -------------------------------------
  44. SetWriteMode
  45. SetLineStyle
  46. SetFillPattern
  47. SetUserCharSize
  48. SetTextStyle
  49. FillPoly
  50. FloodFill
  51. SetAspectRatio
  52. (please remove what you implement fom this list)
  53. }
  54. interface
  55. { ---------------------------------------------------------------------
  56. Constants
  57. ---------------------------------------------------------------------}
  58. const
  59. NormalPut = 0;
  60. CopyPut = 0;
  61. XORPut = 1;
  62. ORPut = 2;
  63. ANDPut = 3;
  64. NotPut = 4;
  65. BackPut = 8;
  66. Black = 0;
  67. Blue = 1;
  68. Green = 2;
  69. Cyan = 3;
  70. Red = 4;
  71. Magenta = 5;
  72. Brown = 6;
  73. LightGray = 7;
  74. DarkGray = 8;
  75. LightBlue = 9;
  76. LightGreen = 10;
  77. LightCyan = 11;
  78. LightRed = 12;
  79. LightMagenta = 13;
  80. Yellow = 14;
  81. White = 15;
  82. Border = 16;
  83. SolidLn = 0;
  84. DottedLn = 1;
  85. CenterLn = 2;
  86. DashedLn = 3;
  87. UserBitLn = 4;
  88. EmptyFill = 0;
  89. SolidFill = 1;
  90. LineFill = 2;
  91. LtSlashFill = 3;
  92. SlashFill = 4;
  93. BkSlashFill = 5;
  94. LtBkSlashFill = 6;
  95. HatchFill = 7;
  96. XHatchFill = 8;
  97. InterleaveFill = 9;
  98. WideDotFill = 10;
  99. CloseDotFill = 11;
  100. UserFill = 12;
  101. NormWidth = 1;
  102. ThickWidth = 3;
  103. const
  104. LeftText = 0;
  105. CenterText = 1;
  106. RightText = 2;
  107. BottomText = 0;
  108. TopText = 2;
  109. BaseLine = 3;
  110. LeadLine = 4;
  111. const
  112. { Error codes }
  113. grOK = 0;
  114. grNoInitGraph = -1;
  115. grNotDetected = -2;
  116. grFileNotFound = -3;
  117. grInvalidDriver = -4;
  118. grNoLOadMem = -5;
  119. grNoScanMem = -6;
  120. grNoFloodMem = -7;
  121. grFontNotFound = -8;
  122. grNoFontMem = -9;
  123. grInvalidmode = -10;
  124. grError = -11;
  125. grIOerror = -12;
  126. grInvalidFont = -13;
  127. grInvalidFontNum = -14;
  128. { ---------------------------------------------------------------------
  129. Types
  130. ---------------------------------------------------------------------}
  131. Type
  132. FillPatternType = array[1..8] of byte;
  133. ArcCoordsType = record
  134. x,y : integer;
  135. xstart,ystart : integer;
  136. xend,yend : integer;
  137. end;
  138. RGBColor = record
  139. r,g,b,i : byte;
  140. end;
  141. PaletteType = record
  142. Size : integer;
  143. Colors : array[0..767]of Byte;
  144. end;
  145. LineSettingsType = record
  146. linestyle : word;
  147. pattern : word;
  148. thickness : word;
  149. end;
  150. TextSettingsType = record
  151. font : word;
  152. direction : word;
  153. charsize : word;
  154. horiz : word;
  155. vert : word;
  156. end;
  157. FillSettingsType = record
  158. pattern : word;
  159. color : longint;
  160. end;
  161. PointType = record
  162. x,y : integer;
  163. end;
  164. ViewPortType = record
  165. x1,y1,x2,y2 : integer;
  166. Clip : boolean;
  167. end;
  168. const
  169. fillpattern : array[0..12] of FillPatternType = (
  170. ($00,$00,$00,$00,$00,$00,$00,$00), { Hintergrundfarbe }
  171. ($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff), { Vordergrundfarbe }
  172. ($ff,$ff,$00,$00,$ff,$ff,$00,$00), { === }
  173. ($01,$02,$04,$08,$10,$20,$40,$80), { /// }
  174. ($07,$0e,$1c,$38,$70,$e0,$c1,$83), { /// als dicke Linien }
  175. ($07,$83,$c1,$e0,$70,$38,$1c,$0e), { \\\ als dicke Linien }
  176. ($5a,$2d,$96,$4b,$a5,$d2,$69,$b4), { \ \\ \ }
  177. ($ff,$88,$88,$88,$ff,$88,$88,$88), { K„stchen }
  178. ($18,$24,$42,$81,$81,$42,$24,$18), { Rauten }
  179. ($cc,$33,$cc,$33,$cc,$33,$cc,$33), { "Mauermuster" }
  180. ($80,$00,$08,$00,$80,$00,$08,$00), { weit auseinanderliegende Punkte }
  181. ($88,$00,$22,$00,$88,$00,$22,$00), { dichte Punkte}
  182. (0,0,0,0,0,0,0,0) { benutzerdefiniert }
  183. );
  184. { ---------------------------------------------------------------------
  185. Function Declarations
  186. ---------------------------------------------------------------------}
  187. { Retrieving coordinates }
  188. function GetX: Integer;
  189. function GetY: Integer;
  190. { Pixel-oriented routines }
  191. procedure PutPixel(X, Y: Integer; Pixel: Word);
  192. function GetPixel(X, Y: Integer): Word;
  193. { Line-oriented primitives }
  194. procedure SetWriteMode(WriteMode: Integer);
  195. procedure LineTo(X, Y: Integer);
  196. procedure LineRel(Dx, Dy: Integer);
  197. procedure MoveTo(X, Y: Integer);
  198. procedure MoveRel(Dx, Dy: Integer);
  199. procedure Line(x1, y1, x2, y2: Integer);
  200. procedure SetLineStyle(LineStyle: Word; Pattern: Word; Thickness: Word);
  201. { Linearly bounded primitives }
  202. procedure Rectangle(x1, y1, x2, y2: Integer);
  203. procedure Bar(x1, y1, x2, y2: Integer);
  204. procedure Bar3D(x1, y1, x2, y2: Integer; Depth: Word; Top: Boolean);
  205. procedure DrawPoly(NumPoints: Word; var PolyPoints);
  206. procedure FillPoly(NumPoints: Word; var PolyPoints);
  207. procedure SetFillStyle(Pattern: Word; Color: Word);
  208. procedure SetFillPattern(Pattern: FillPatternType; Color: Word);
  209. procedure FloodFill(X, Y: Integer; Border: Word);
  210. { Nonlinearly bounded primitives }
  211. procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
  212. procedure GetArcCoords(var ArcCoords: ArcCoordsType);
  213. procedure Circle(X, Y: Integer; Radius: Word);
  214. procedure Ellipse(X, Y: Integer; StAngle, EndAngle: Word; XRadius, YRadius : Word);
  215. procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
  216. procedure SetAspectRatio(Xasp, Yasp: Word);
  217. procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
  218. procedure Sector(X, Y: Integer; StAngle, EndAngle, XRadius, YRadius: Word);
  219. { Color routines }
  220. procedure SetBkColor(ColorNum: Word);
  221. procedure SetColor(Color: Word);
  222. Function GetBkColor : Word;
  223. Function GetColor : Word;
  224. function GetMaxColor : Word;
  225. Procedure GetDefaultPalette (Var Palette : PaletteType);
  226. Procedure GetPalette (Var Palette : PaletteType);
  227. Function GetPaletteSize : Word;
  228. Procedure SetAllPalette (Var Palette);
  229. Procedure SetPalette (ColorNr : Word; NewColor : ShortInt);
  230. { Filling/linestyle utilities }
  231. Procedure GetFillSettings (Var FillSettings : FillSettingsType);
  232. Procedure GetFillPattern (Var FillPattern : FillPatternType);
  233. Procedure GetLineSettings (Var LineInfo : LineSettingsType);
  234. { Bitmap utilities }
  235. procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
  236. procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);
  237. function ImageSize(x1, y1, x2, y2: Integer): LongInt;
  238. { Text routines}
  239. procedure OutText(TextString: string);
  240. procedure OutTextXY(X, Y: Integer; TextString: string);
  241. procedure SetTextJustify(Horiz, Vert: Word);
  242. procedure SetTextStyle(Font, Direction: Word; CharSize: Word);
  243. procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word);
  244. procedure GetTextSettings (Var TextInfo : TextSettingsType);
  245. { Graph clipping method }
  246. Procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
  247. Procedure ClearViewPort;
  248. Procedure GetViewSettings (Var ViewPort : ViewPortType);
  249. { Init/Done }
  250. procedure InitVideo;
  251. procedure DoneVideo;
  252. { Other }
  253. function GetResX: Integer;
  254. function GetResY: Integer;
  255. function GetAspect: Real;
  256. Procedure GetAspectRatio (Var x,y : Word);
  257. function GetMaxX : Integer;
  258. function GetMAxY : Integer;
  259. { For compatibility }
  260. Procedure DetectGraph (Var Driver,Mode : Integer);
  261. Procedure InitGraph (Var Driver,Mode : Integer;DriverPath : String);
  262. Procedure CloseGraph;
  263. Function GraphResult : Integer;
  264. Procedure GraphDefaults ;
  265. Function GraphErrorMsg (Errcode : Integer) : String;
  266. Procedure ClearDevice;
  267. Function GetDriverName : String;
  268. Function GetGraphMode : Integer;
  269. Function GetMaxMode : Word;
  270. Function GetModeName (Var Modus : INteger) : String;
  271. Procedure GetModeRange (Driver : Integer; Var loModus,HiModus : Integer);
  272. Function InstallUserDriver (DriverPat :String; AutodetectPtr : Pointer) : Integer;
  273. Function InstallUserFont (FontPath : String) : Integer;
  274. Function RegisterBGIDriver (Driver : Pointer) : Integer;
  275. Function RegisterBGIFont (Font : Pointer) : Integer;
  276. Procedure RestoreCRTmode;
  277. Procedure SetActivePage (Page : Word);
  278. Procedure SetGraphBufSize (BufSize : Word);
  279. Procedure SetGraphMode (Mode :Integer);
  280. Procedure SetVisualPage (Page : Word);
  281. const
  282. NoGraphics: Boolean = false;
  283. { VGA modes }
  284. GTEXT = 0; { Compatible with VGAlib v1.2 }
  285. G320x200x16 = 1;
  286. G640x200x16 = 2;
  287. G640x350x16 = 3;
  288. G640x480x16 = 4;
  289. G320x200x256 = 5;
  290. G320x240x256 = 6;
  291. G320x400x256 = 7;
  292. G360x480x256 = 8;
  293. G640x480x2 = 9;
  294. G640x480x256 = 10;
  295. G800x600x256 = 11;
  296. G1024x768x256 = 12;
  297. G1280x1024x256 = 13; { Additional modes. }
  298. G320x200x32K = 14;
  299. G320x200x64K = 15;
  300. G320x200x16M = 16;
  301. G640x480x32K = 17;
  302. G640x480x64K = 18;
  303. G640x480x16M = 19;
  304. G800x600x32K = 20;
  305. G800x600x64K = 21;
  306. G800x600x16M = 22;
  307. G1024x768x32K = 23;
  308. G1024x768x64K = 24;
  309. G1024x768x16M = 25;
  310. G1280x1024x32K = 26;
  311. G1280x1024x64K = 27;
  312. G1280x1024x16M = 28;
  313. G800x600x16 = 29;
  314. G1024x768x16 = 30;
  315. G1280x1024x16 = 31;
  316. G720x348x2 = 32; { Hercules emulation mode }
  317. G320x200x16M32 = 33; { 32-bit per pixel modes. }
  318. G640x480x16M32 = 34;
  319. G800x600x16M32 = 35;
  320. G1024x768x16M32 = 36;
  321. G1280x1024x16M32 = 37;
  322. { additional resolutions }
  323. G1152x864x16 = 38;
  324. G1152x864x256 = 39;
  325. G1152x864x32K = 40;
  326. G1152x864x64K = 41;
  327. G1152x864x16M = 42;
  328. G1152x864x16M32 = 43;
  329. G1600x1200x16 = 44;
  330. G1600x1200x256 = 45;
  331. G1600x1200x32K = 46;
  332. G1600x1200x64K = 47;
  333. G1600x1200x16M = 48;
  334. G1600x1200x16M32 = 49;
  335. GLASTMODE = 49;
  336. implementation
  337. uses Objects, Linux;
  338. { ---------------------------------------------------------------------
  339. SVGA bindings.
  340. ---------------------------------------------------------------------}
  341. { Link with VGA, gl and c libraries }
  342. {$linklib vga}
  343. {$linklib vgagl}
  344. {$linklib c}
  345. Const
  346. { Text }
  347. WRITEMODE_OVERWRITE = 0;
  348. WRITEMODE_MASKED = 1;
  349. FONT_EXPANDED = 0;
  350. FONT_COMPRESSED = 2;
  351. { Types }
  352. type
  353. pvga_modeinfo = ^vga_modeinfo;
  354. vga_modeinfo = record
  355. width,
  356. height,
  357. bytesperpixel,
  358. colors,
  359. linewidth, { scanline width in bytes }
  360. maxlogicalwidth, { maximum logical scanline width }
  361. startaddressrange, { changeable bits set }
  362. maxpixels, { video memory / bytesperpixel }
  363. haveblit, { mask of blit functions available }
  364. flags: Longint; { other flags }
  365. { Extended fields: }
  366. chiptype, { Chiptype detected }
  367. memory, { videomemory in KB }
  368. linewidth_unit: Longint; { Use only a multiple of this as parameter for set_displaystart }
  369. linear_aperture: PChar; { points to mmap secondary mem aperture of card }
  370. aperture_size: Longint; { size of aperture in KB if size>=videomemory.}
  371. set_aperture_page: procedure (page: Longint);
  372. { if aperture_size<videomemory select a memory page }
  373. extensions: Pointer; { points to copy of eeprom for mach32 }
  374. { depends from actual driver/chiptype.. etc. }
  375. end;
  376. PGraphicsContext = ^TGraphicsContext;
  377. TGraphicsContext = record
  378. ModeType: Byte;
  379. ModeFlags: Byte;
  380. Dummy: Byte;
  381. FlipPage: Byte;
  382. Width: LongInt;
  383. Height: LongInt;
  384. BytesPerPixel: LongInt;
  385. Colors: LongInt;
  386. BitsPerPixel: LongInt;
  387. ByteWidth: LongInt;
  388. VBuf: pointer;
  389. Clip: LongInt;
  390. ClipX1: LongInt;
  391. ClipY1: LongInt;
  392. ClipX2: LongInt;
  393. ClipY2: LongInt;
  394. ff: pointer;
  395. end;
  396. { vga functions }
  397. Function vga_init: Longint; Cdecl; External;
  398. Function vga_getdefaultmode: Longint; Cdecl; External;
  399. Function vga_hasmode(mode: Longint): Boolean; Cdecl; External;
  400. Function vga_getmodeinfo(mode: Longint): pvga_modeinfo; Cdecl; External;
  401. Function vga_setmode(mode: Longint): Longint; Cdecl; External;
  402. Function vga_getxdim : Longint; cdecl;external;
  403. Function vga_getydim : longint; cdecl;external;
  404. { gl functions }
  405. procedure gl_setpixel(x, y, c: LongInt); Cdecl; External;
  406. function gl_getpixel(x, y: LongInt): LongInt; cdecl; external;
  407. procedure gl_line(x1, y1, x2, y2, c: LongInt); Cdecl; External;
  408. procedure gl_fillbox(x, y, w, h, c: LongInt); Cdecl; External;
  409. procedure gl_circle(x, y, r, c: LongInt ); Cdecl; External;
  410. procedure gl_getbox(x, y, w, h: LongInt; dp: pointer); Cdecl; External;
  411. procedure gl_putbox(x, y, w, h: LongInt; dp: pointer); Cdecl; External;
  412. procedure gl_disableclipping; Cdecl; External;
  413. procedure gl_enableclipping; Cdecl; External;
  414. procedure gl_putboxpart(x, y, w, h, bw, bh: LongInt; b: pointer; xo, yo: LongInt); Cdecl; External;
  415. function gl_rgbcolor(r, g, b: LongInt): LongInt; Cdecl; External;
  416. function gl_setcontextvga(m: LongInt): LongInt; Cdecl; External;
  417. function gl_allocatecontext: PGraphicsContext; Cdecl; External;
  418. procedure gl_getcontext(gc: PGraphicsContext); Cdecl; External;
  419. procedure gl_setrgbpalette; Cdecl; External;
  420. procedure gl_freecontext(gc: PGraphicsContext); Cdecl; External;
  421. procedure gl_setclippingwindow(x1, y1, x2, y2: LongInt); Cdecl; External;
  422. procedure gl_setwritemode(wm: LongInt); Cdecl; External;
  423. procedure gl_setfontcolors(bg, fg: LongInt); Cdecl; External;
  424. procedure gl_writen(x, y, n: LongInt; s: PChar); Cdecl; External;
  425. procedure gl_setfont(fw, fh: LongInt; fdp: pointer); Cdecl; External;
  426. procedure gl_copyboxfromcontext(var gc: TGraphicsContext; x1, y1, w, h, x2, y2: LongInt); Cdecl; External;
  427. procedure gl_setcontext(gc: PGraphicsContext); Cdecl; External;
  428. function gl_setcontextvgavirtual(m: LongInt): LongInt; cdecl; external;
  429. procedure gl_font8x8; Cdecl; External;
  430. { ---------------------------------------------------------------------
  431. Types, constants and variables
  432. ---------------------------------------------------------------------}
  433. var
  434. DrawDelta: TPoint;
  435. CurX, CurY: Integer;
  436. TheColor, TheFillColor: LongInt;
  437. IsVirtual: Boolean;
  438. PhysicalScreen, BackScreen: PGraphicsContext;
  439. ColorTable: array[0..15] of LongInt;
  440. TheFillPattern : FillPatternType;
  441. TheLineSettings : LineSettingsType;
  442. ThePalette : PaletteType;
  443. TheTextSettings : TextSettingsType;
  444. TheFillSettings : FillSettingsType;
  445. const
  446. BgiColors: array[0..15] of LongInt
  447. = ($000000, $000080, $008000, $008080,
  448. $800000, $800080, $808000, $C0C0C0,
  449. $808080, $0000FF, $00FF00, $00FFFF,
  450. $FF0000, $FF00FF, $FFFF00, $FFFFFF);
  451. const
  452. DoUseMarker: Boolean = true;
  453. TheMarker: Char = '~';
  454. TextColor: LongInt = 15;
  455. MarkColor: LongInt = 15;
  456. BackColor: LongInt = 0;
  457. FontWidth: Integer = 8;
  458. FontHeight: Integer = 8;
  459. var
  460. sHoriz, sVert: Word;
  461. { initialisierte Variablen }
  462. const
  463. SourcePage: Word = 0;
  464. DestPage: Word = 0;
  465. { Retrieves the capabilities for the current mode }
  466. const
  467. vmcImage = 1;
  468. vmcCopy = 2;
  469. vmcSaveRestore = 4;
  470. vmcBuffer = 8;
  471. vmcBackPut = 16;
  472. { ---------------------------------------------------------------------
  473. Graphics Vision Layer
  474. ---------------------------------------------------------------------}
  475. { Types and constants }
  476. var
  477. SizeX, SizeY: Word;
  478. { Draw origin and clipping rectangle }
  479. var
  480. DrawOrigin: TPoint;
  481. ClipRect: TRect;
  482. MetaClipRect: TRect;
  483. MetaOrigin: TPoint;
  484. { Font attributes }
  485. const
  486. ftNormal = 0;
  487. ftBold = 1;
  488. ftThin = 2;
  489. ftItalic = 4;
  490. var
  491. sFont, sColor:Word;
  492. sCharSpace: Integer;
  493. { Not used
  494. sMarker: Char;
  495. sAttr: Word; }
  496. { Windows-style text metric }
  497. type
  498. PTextMetric = ^TTextMetric;
  499. TTextMetric = record
  500. tmHeight: Integer;
  501. tmAscent: Integer;
  502. tmDescent: Integer;
  503. tmInternalLeading: Integer;
  504. tmExternalLeading: Integer;
  505. tmAveCharWidth: Integer;
  506. tmMaxCharWidth: Integer;
  507. tmWeight: Integer;
  508. tmItalic: Byte;
  509. tmUnderlined: Byte;
  510. tmStruckOut: Byte;
  511. tmFirstChar: Byte;
  512. tmLastChar: Byte;
  513. tmDefaultChar: Byte;
  514. tmBreakChar: Byte;
  515. tmPitchAndFamily: Byte;
  516. tmCharSet: Byte;
  517. tmOverhang: Integer;
  518. tmDigitizedAspectX: Integer;
  519. tmDigitizedAspectY: Integer;
  520. end;
  521. { Bitmap utilities }
  522. type
  523. PBitmap = ^TBitmap;
  524. TBitmap = record
  525. Width, Height: Integer;
  526. Data: record end;
  527. end;
  528. { Storing screen regions }
  529. type
  530. TVgaBuf = record
  531. Bounds: TRect;
  532. Mem: Word;
  533. Size: Word;
  534. end;
  535. const
  536. pbNone = 0;
  537. pbCopy = 1;
  538. pbClear = 2;
  539. type
  540. PScreenBuf = ^TScreenBuf;
  541. TScreenBuf = record
  542. Mode: Word;
  543. Rect: TRect;
  544. Size: LongInt;
  545. Info: LongInt
  546. end;
  547. { Procedures and functions }
  548. procedure SetColors;
  549. var
  550. i: Integer;
  551. begin
  552. for i:=0 to 15 do
  553. ColorTable[i] := gl_rgbcolor(BgiColors[i] shr 16,
  554. (BgiColors[i] shr 8) and 255,
  555. BgiColors[i] and 255)
  556. end;
  557. procedure InitVideo;
  558. var
  559. VgaMode: Integer;
  560. ModeInfo: pvga_modeinfo;
  561. begin
  562. if NoGraphics
  563. then begin
  564. SizeX := 640;
  565. SizeY := 480
  566. end
  567. else begin
  568. VgaMode := vga_getdefaultmode;
  569. if (VgaMode = -1) then VgaMode := G320X200X256;
  570. if (not vga_hasmode(VgaMode))
  571. then begin
  572. WriteLn('BGI: Mode not available.');
  573. Halt(1)
  574. end;
  575. ModeInfo := vga_getmodeinfo(VgaMode);
  576. {IsVirtual := (ModeInfo^.colors = 16) or (ModeInfo^.flags and IS_MODEX <> 0);}
  577. IsVirtual := true;
  578. { We always want a back screen (for buffering). }
  579. if IsVirtual
  580. then begin
  581. { Create virtual screen }
  582. gl_setcontextvgavirtual(VgaMode);
  583. BackScreen := gl_allocatecontext;
  584. gl_getcontext(BackScreen)
  585. end;
  586. vga_setmode(VgaMode);
  587. gl_setcontextvga(VgaMode); { Physical screen context. }
  588. PhysicalScreen := gl_allocatecontext;
  589. gl_getcontext(PhysicalScreen);
  590. if (PhysicalScreen^.colors = 256) then gl_setrgbpalette;
  591. SetColors;
  592. SizeX := PhysicalScreen^.Width;
  593. SizeY := PhysicalScreen^.Height
  594. end
  595. end;
  596. procedure DoneVideo;
  597. begin
  598. if not NoGraphics
  599. then begin
  600. if IsVirtual then gl_freecontext(BackScreen);
  601. vga_setmode(GTEXT)
  602. end
  603. end;
  604. procedure SetDelta;
  605. begin
  606. if ClipRect.Empty
  607. then begin
  608. DrawDelta.X := 10000;
  609. DrawDelta.Y := 10000;
  610. end
  611. else begin
  612. DrawDelta.X := DrawOrigin.X;
  613. DrawDelta.y := DrawOrigin.y
  614. end
  615. end;
  616. procedure SetDrawOrigin(x, y: Integer);
  617. begin
  618. DrawOrigin.x := x;
  619. DrawOrigin.y := y;
  620. SetDelta;
  621. end;
  622. procedure SetDrawOriginP(var P: TPoint);
  623. begin
  624. SetDrawOrigin(P.x, P.y)
  625. end;
  626. procedure SetClipRect(x1, y1, x2, y2: Integer);
  627. begin
  628. Cliprect.Assign(x1, y1, x2, y2);
  629. if not NoGraphics
  630. then begin
  631. if ClipRect.Empty
  632. then gl_setclippingwindow(0, 0, 0, 0)
  633. else gl_setclippingwindow(x1, y1, x2 - 1, y2 - 1);
  634. {gl_enableclipping(0);}
  635. end;
  636. SetDelta
  637. end;
  638. procedure SetClipRectR(var R: TRect);
  639. begin
  640. SetClipRect(R.A.X, R.A.Y, R.B.X, R.B.Y);
  641. end;
  642. procedure SetMetaOrigin(x, y: Integer);
  643. begin
  644. MetaOrigin.x := x;
  645. MetaOrigin.y := y
  646. end;
  647. procedure SetMetaOriginP(P: TPoint);
  648. begin
  649. SetMetaOrigin(P.x, P.y)
  650. end;
  651. procedure SetMetaClipRect(x1, y1, x2, y2: Integer);
  652. begin
  653. MetaCliprect.Assign(x1, y1, x2, y2)
  654. end;
  655. procedure SetMetaClipRectR(var R: TRect);
  656. begin
  657. MetaCliprect := R
  658. end;
  659. function GetBuffer(Size: Word): pointer;
  660. begin
  661. { No metafiling available. }
  662. GetBuffer := nil
  663. end;
  664. Procedure HoriLine(x1,y1,x2: Integer);
  665. begin
  666. Line(x1, y1, x2, y1)
  667. end;
  668. Procedure VertLine(x1,y1,y2: Integer);
  669. begin
  670. Line(x1, y1, x1, y2)
  671. end;
  672. procedure FillCircle(xm, ym, r: Integer);
  673. begin
  674. FillEllipse(xm, ym, r, r)
  675. end;
  676. { Text routines }
  677. function TextWidth(s: string): Integer;
  678. var
  679. i: Integer;
  680. begin
  681. if DoUseMarker
  682. then begin
  683. For i := Length(s) downto 1 do
  684. If s[i] = TheMarker then Delete(s, i, 1);
  685. If s = ''
  686. then TextWidth := 0
  687. else TextWidth := Length(s) * FontWidth
  688. end
  689. else TextWidth := Length(s) * FontWidth
  690. end;
  691. function TextHeight(s: string): Integer;
  692. begin
  693. TextHeight := FontHeight
  694. end;
  695. procedure OutText(TextString: string);
  696. begin
  697. OutTextXY(GetX, GetY, TextString)
  698. end;
  699. procedure OutTextXY(X, Y: Integer; TextString: string);
  700. var
  701. P, Q: PChar;
  702. i: Integer;
  703. col: Boolean;
  704. begin
  705. if NoGraphics or (TextString='') then Exit;
  706. gl_setwritemode(FONT_COMPRESSED + WRITEMODE_MASKED);
  707. case sHoriz of
  708. CenterText : Dec(x, TextWidth(TextString) div 2);
  709. RightText : Dec(x, TextWidth(TextString));
  710. end; { case }
  711. case sVert of
  712. CenterText : Dec(y, TextHeight(TextString) div 2);
  713. BottomText, BaseLine : Dec(y, TextHeight(TextString));
  714. end; { case }
  715. MoveTo(X, Y);
  716. P := @TextString[1]; Q := P;
  717. col := false;
  718. gl_setfontcolors(BackColor, TextColor);
  719. For i := 1 to Length(TextString) do
  720. begin
  721. If (Q[0] = TheMarker) and DoUseMarker
  722. then begin
  723. If col then gl_setfontcolors(BackColor, MarkColor)
  724. else gl_setfontcolors(BackColor, TextColor);
  725. If Q <> P then begin
  726. gl_writen(CurX, CurY, Q-P, P);
  727. MoveRel(FontWidth * (Q-P), 0)
  728. end;
  729. col := not col;
  730. P := Q + 1
  731. end;
  732. {Inc(Q)} Q := Q + 1
  733. end;
  734. If col then gl_setfontcolors(BackColor, MarkColor)
  735. else gl_setfontcolors(BackColor, TextColor);
  736. If Q <> P then begin
  737. gl_writen(CurX, CurY, Q-P, P);
  738. MoveRel(FontWidth * (Q-P), 0)
  739. end
  740. end;
  741. procedure SetTextJustify(Horiz, Vert: Word);
  742. begin
  743. sHoriz := Horiz; sVert := Vert;
  744. end;
  745. procedure SetTextStyle(Font, Direction: Word; CharSize: Word);
  746. begin
  747. end;
  748. procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word);
  749. begin
  750. end;
  751. procedure SetKern(Enable: Boolean);
  752. begin
  753. end;
  754. procedure SetMarker(Marker: Char);
  755. begin
  756. TheMarker := Marker
  757. end;
  758. procedure SetTextParams(Font: Word; CharSpace: Integer; Color: Word;
  759. UseMarker: Boolean);
  760. type
  761. pp = ^pointer;
  762. function FixCol(Col: Byte): Byte;
  763. { SVGALIB cannot write black characters... }
  764. begin
  765. if Col=0 then FixCol := 1 else FixCol := Col
  766. end; { FixCol }
  767. begin
  768. sColor := Color; sCharSpace := CharSpace; sFont := Font;
  769. if not NoGraphics then begin
  770. TextColor := ColorTable[FixCol(Color and 15)];
  771. MarkColor := ColorTable[FixCol((Color shr 8) and 15)];
  772. DoUseMarker := UseMarker;
  773. gl_setfont(8, 8, (pp(@gl_font8x8))^);
  774. end
  775. end;
  776. function GetResX: Integer;
  777. begin
  778. GetResX := 96;
  779. end; { GetResX }
  780. function GetResY: Integer;
  781. begin
  782. GetResY := 96
  783. end; { GetResY }
  784. function GetAspect: Real;
  785. begin
  786. GetAspect := 1.0
  787. end; { GetAspect }
  788. Procedure GetAspectRatio (Var x,y : Word);
  789. begin
  790. X:=GetMaxX;
  791. Y:=GetMaxY
  792. end; { GetAspect }
  793. Var LastViewPort : ViewPortType;
  794. procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
  795. begin
  796. LastViewPort.X1:=X1;
  797. LastViewPort.Y1:=Y1;
  798. LastViewPort.X2:=X2;
  799. LastViewPort.Y2:=Y2;
  800. LastViewPort.Clip:=Clip;
  801. SetDrawOrigin(x1, y1);
  802. if Clip then SetClipRect(x1, y1, x2+1, y2+1)
  803. else SetClipRect(0, 0, SizeX, SizeY)
  804. end;
  805. Procedure ClearViewPort;
  806. begin
  807. With LastViewPort do
  808. gl_fillbox(X1,Y1,X2-X1,Y2-Y1,BackColor);
  809. end;
  810. Procedure GetViewSettings (Var ViewPort : ViewPortType);
  811. begin
  812. ViewPort:=LastViewPort;
  813. end;
  814. { VGAMEM }
  815. type
  816. TImage = record
  817. end;
  818. procedure CopyScreen(x1, y1, x2, y2, x3, y3: Integer);
  819. begin
  820. if not NoGraphics and (x2 > x1) and (y2 > y1)
  821. then gl_copyboxfromcontext(PhysicalScreen^, x1, y1, x2 - x1, y2 - y1, x3, y3);
  822. end;
  823. { BGI-like Image routines
  824. }
  825. function CopyImage(Image: pointer): pointer;
  826. begin
  827. CopyImage := nil
  828. end;
  829. function CutImage(x1, y1, x2, y2: Integer): pointer;
  830. var
  831. Image: PBitmap;
  832. begin
  833. GetMem(Image, ImageSize(x1, y1, x2, y2));
  834. if Image <> nil
  835. then GetImage(x1, y1, x2, y2, Image^);
  836. CutImage := Image;
  837. end;
  838. procedure GetImageExtent(Image: pointer; var Extent: Objects.TPoint);
  839. begin
  840. if Image = nil
  841. then begin
  842. Extent.X := 0;
  843. Extent.Y := 0
  844. end
  845. else begin
  846. Extent.X := PBitmap(Image)^.Width;
  847. Extent.Y := PBitmap(Image)^.Height
  848. end;
  849. end;
  850. procedure FreeImage(Image: pointer);
  851. var
  852. P: TPoint;
  853. begin
  854. if Image <> nil
  855. then begin
  856. GetImageExtent(Image, P);
  857. FreeMem(Image, ImageSize(0, 0, P.x - 1, P.y - 1));
  858. end;
  859. end;
  860. function LoadImage(var S: TStream): pointer;
  861. begin
  862. LoadImage := nil
  863. end;
  864. function MaskedImage(Image: pointer): pointer;
  865. begin
  866. MaskedImage := nil;
  867. end;
  868. procedure PasteImage(X, Y: Integer; Image: pointer; BitBlt: Word);
  869. begin
  870. if Image <> nil then PutImage(X, Y, Image^, BitBlt)
  871. end;
  872. procedure StoreImage(var S: TStream; Image: pointer);
  873. begin
  874. end;
  875. { Storing screen regions }
  876. function PrepBuf(var R: Objects.TRect; Action: Word; var Buf: TVgaBuf): Boolean;
  877. begin
  878. if BackScreen <> nil
  879. then begin
  880. Buf.Bounds := R;
  881. gl_setcontext(BackScreen);
  882. gl_disableclipping;
  883. case Action of
  884. pbCopy : gl_copyboxfromcontext(PhysicalScreen^,
  885. R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y,
  886. R.A.X, R.A.Y);
  887. pbClear : gl_fillbox(R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y, 0);
  888. end;
  889. PrepBuf := true;
  890. SetDrawOrigin(0, 0);
  891. SetClipRectR(R);
  892. end
  893. else PrepBuf := false
  894. end; { PrepBuf }
  895. procedure EndBufDraw;
  896. begin
  897. if not NoGraphics
  898. then gl_setcontext(PhysicalScreen);
  899. end; { EndBufDraw }
  900. procedure ReleaseBuf(var Buf: TVgaBuf);
  901. begin
  902. end; { ReleaseBuf }
  903. procedure PasteRectAt(var R: Objects.TRect; P: Objects.TPoint; var Buf: TVgaBuf);
  904. begin
  905. if not NoGraphics and (BackScreen <> nil)
  906. then gl_copyboxfromcontext(BackScreen^,
  907. R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y,
  908. P.X, P.Y);
  909. end;
  910. procedure PasteRect(var R: Objects.TRect; var Buf: TVgaBuf);
  911. begin
  912. PasteRectAt(R, R.A, Buf);
  913. end; { PasteRect }
  914. function StoreScreen(x1, y1, x2, y2: Integer): PScreenBuf;
  915. var
  916. s: LongInt;
  917. p: pointer;
  918. SaveOrigin: TPoint;
  919. function NewScreenBuf(AMode: Word; AnInfo: LongInt): PScreenBuf;
  920. var
  921. p: PScreenBuf;
  922. Begin
  923. New(p);
  924. p^.Mode := AMode;
  925. p^.Size := s;
  926. p^.Rect.Assign(x1, y1, x2, y2);
  927. p^.Info := AnInfo;
  928. NewScreenBuf := p
  929. End;
  930. Begin
  931. { General Images }
  932. s := 0;
  933. SaveOrigin := DrawOrigin;
  934. SetDrawOrigin(0, 0);
  935. p := CutImage(x1, y1, x2-1, y2-1);
  936. SetDrawOriginP(SaveOrigin);
  937. If p <> nil
  938. then StoreScreen := NewScreenBuf(2, LongInt(p))
  939. else StoreScreen := nil
  940. End;
  941. procedure FreeScreenBuf(Buf: PScreenBuf);
  942. Begin
  943. If Buf <> nil then Begin
  944. case Buf^.Mode of
  945. 2 : FreeImage(pointer(Buf^.Info));
  946. end;
  947. Dispose(Buf)
  948. End
  949. End;
  950. procedure DrawScreenBufAt(Buf: PScreenBuf; x3, y3: Integer);
  951. var
  952. SaveOrigin: TPoint;
  953. Begin
  954. If Buf <> nil then
  955. case Buf^.Mode of
  956. 2 :
  957. begin
  958. SaveOrigin := DrawOrigin;
  959. SetDrawOrigin(0, 0);
  960. PasteImage(x3, y3, pointer(Buf^.Info), NormalPut);
  961. SetDrawOriginP(SaveOrigin);
  962. end
  963. end
  964. End;
  965. procedure DrawScreenBuf(Buf: PScreenBuf);
  966. Begin
  967. If Buf <> nil then
  968. DrawScreenBufAt(Buf, Buf^.Rect.A.x, Buf^.Rect.A.y)
  969. End;
  970. function GetVgaMemCaps: Word;
  971. begin
  972. GetVgaMemCaps := vmcCopy
  973. end;
  974. procedure GetTextMetrics(var Metrics: TTextMetric);
  975. begin
  976. with Metrics do
  977. begin
  978. tmHeight := 8;
  979. tmAscent := 8;
  980. tmDescent := 0;
  981. tmInternalLeading := 0;
  982. tmExternalLeading := 0;
  983. tmAveCharWidth := 8;
  984. tmMaxCharWidth := 8;
  985. tmWeight := 700;
  986. tmItalic := 0;
  987. tmUnderlined := 0;
  988. tmStruckOut := 0;
  989. tmFirstChar := 0;
  990. tmLastChar := 255;
  991. tmDefaultChar := 32;
  992. tmBreakChar := 32;
  993. tmPitchAndFamily := 0;
  994. tmCharSet := 0;
  995. tmOverhang := 0;
  996. tmDigitizedAspectX := 100;
  997. tmDigitizedAspectY := 100
  998. end;
  999. end;
  1000. { ---------------------------------------------------------------------
  1001. Real graph implementation
  1002. ---------------------------------------------------------------------}
  1003. function GetX: Integer;
  1004. begin
  1005. GetX := CurX - DrawDelta.X
  1006. end;
  1007. function GetY: Integer;
  1008. begin
  1009. GetY := CurY - DrawDelta.Y
  1010. end;
  1011. { Pixel-oriented routines }
  1012. procedure PutPixel(X, Y: Integer; Pixel: Word);
  1013. begin
  1014. if not NoGraphics
  1015. then gl_setpixel(X + DrawDelta.X, Y + DrawDelta.Y, Pixel)
  1016. end;
  1017. function GetPixel(X, Y: Integer): Word;
  1018. begin
  1019. if NoGraphics
  1020. then GetPixel := 0
  1021. else GetPixel := gl_getpixel(X + DrawDelta.X, Y + DrawDelta.Y)
  1022. end;
  1023. { Line-oriented primitives }
  1024. procedure SetWriteMode(WriteMode: Integer);
  1025. begin
  1026. { Graph.SetWriteMode(WriteMode) }
  1027. end;
  1028. procedure LineTo(X, Y: Integer);
  1029. begin
  1030. if not NoGraphics
  1031. then gl_line(CurX, CurY, X + DrawDelta.X, Y + DrawDelta.Y, TheColor);
  1032. CurX := X + DrawDelta.X;
  1033. CurY := Y + DrawDelta.Y
  1034. end;
  1035. procedure LineRel(Dx, Dy: Integer);
  1036. begin
  1037. if not NoGraphics
  1038. then gl_line(CurX, CurY, CurX + Dx, CurY + Dy, TheColor);
  1039. CurX := CurX + Dx;
  1040. CurY := CurY + Dy
  1041. end;
  1042. procedure MoveTo(X, Y: Integer);
  1043. begin
  1044. CurX := X + DrawDelta.X;
  1045. CurY := Y + DrawDelta.Y
  1046. end;
  1047. procedure MoveRel(Dx, Dy: Integer);
  1048. begin
  1049. CurX := CurX + Dx;
  1050. CurY := CurY + Dy
  1051. end;
  1052. procedure Line(x1, y1, x2, y2: Integer);
  1053. begin
  1054. if not NoGraphics
  1055. then gl_line(x1 + DrawDelta.X, y1 + DrawDelta.Y,
  1056. x2 + DrawDelta.X, y2 + DrawDelta.Y, TheColor)
  1057. end;
  1058. procedure SetLineStyle(LineStyle: Word; Pattern: Word; Thickness: Word);
  1059. begin
  1060. end;
  1061. procedure SetFillPattern(Pattern: FillPatternType; Color: Word);
  1062. begin
  1063. end;
  1064. { Linearly bounded primitives }
  1065. procedure Rectangle(x1, y1, x2, y2: Integer);
  1066. begin
  1067. MoveTo(x1, y1);
  1068. LineTo(x2, y1);
  1069. LineTo(x2, y2);
  1070. LineTo(x1, y2);
  1071. LineTo(x1, y1)
  1072. end;
  1073. procedure Bar(x1, y1, x2, y2: Integer);
  1074. var
  1075. R: TRect;
  1076. begin
  1077. if not NoGraphics
  1078. then begin
  1079. R.Assign(x1 + DrawDelta.X, y1 + DrawDelta.Y,
  1080. x2 + DrawDelta.X + 1, y2 + DrawDelta.Y + 1);
  1081. R.Intersect(ClipRect);
  1082. if not R.Empty
  1083. then gl_fillbox(R.A.X, R.A.Y,
  1084. R.B.X - R.A.X, R.B.Y - R.A.Y, TheFillColor)
  1085. end;
  1086. end;
  1087. procedure Bar3D(x1, y1, x2, y2: Integer; Depth: Word; Top: Boolean);
  1088. begin
  1089. Bar(x1,y1,x2,y2);
  1090. Rectangle(x1,y1,x2,y2);
  1091. if top then begin
  1092. Moveto(x1,y1);
  1093. Lineto(x1+depth,y1-depth);
  1094. Lineto(x2+depth,y1-depth);
  1095. Lineto(x2,y1);
  1096. end;
  1097. Moveto(x2+depth,y1-depth);
  1098. Lineto(x2+depth,y2-depth);
  1099. Lineto(x2,y2);
  1100. end;
  1101. procedure DrawPoly(NumPoints: Word; var PolyPoints);
  1102. type
  1103. ppointtype = ^pointtype;
  1104. var
  1105. i : longint;
  1106. begin
  1107. line(ppointtype(@polypoints)[NumPoints-1].x,
  1108. ppointtype(@polypoints)[NumPoints-1].y,
  1109. ppointtype(@polypoints)[0].x,
  1110. ppointtype(@polypoints)[0].y);
  1111. for i:=0 to NumPoints-2 do
  1112. line(ppointtype(@polypoints)[i].x,
  1113. ppointtype(@polypoints)[i].y,
  1114. ppointtype(@polypoints)[i+1].x,
  1115. ppointtype(@polypoints)[i+1].y);
  1116. end;
  1117. procedure FillPoly(NumPoints: Word; var PolyPoints);
  1118. begin
  1119. DrawPoly (NumPoints,PolyPoints);
  1120. end;
  1121. procedure SetFillStyle(Pattern: Word; Color: Word);
  1122. begin
  1123. TheFillColor := ColorTable[Color]
  1124. end;
  1125. procedure FloodFill(X, Y: Integer; Border: Word);
  1126. begin
  1127. end;
  1128. { Nonlinearly bounded primitives
  1129. }
  1130. Var LastArcCoords : ArcCoordsType;
  1131. procedure SetArcCoords (X,y,xradius,yradius,Stangle,endangle : integer);
  1132. begin
  1133. LastArcCoords.X:=X;
  1134. LastArccOords.y:=y;
  1135. Lastarccoords.xstart:=x+round(xradius*cos(stangle*pi/180));
  1136. Lastarccoords.ystart:=y-round(yradius*sin(stangle*pi/180));
  1137. LastArccoords.xend:=x+round(xradius*cos(endangle*pi/180));
  1138. LastArccoords.yend:=y-round(yradius*sin(endangle*pi/180));
  1139. end;
  1140. procedure GetArcCoords(var ArcCoords: ArcCoordsType);
  1141. begin
  1142. ArcCoords:=LastArcCoords;
  1143. end;
  1144. procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
  1145. begin
  1146. Ellipse (X,y,stangle,endangle,Radius,radius);
  1147. end;
  1148. procedure Circle(X, Y: Integer; Radius: Word);
  1149. begin
  1150. if not NoGraphics
  1151. then gl_circle(X + DrawDelta.X, Y + DrawDelta.Y, Radius, TheColor)
  1152. end;
  1153. procedure Ellipse(X, Y: Integer;
  1154. StAngle, EndAngle: Word; XRadius, YRadius : Word);
  1155. Var I : longint;
  1156. tmpang : real;
  1157. begin
  1158. SetArcCoords (X,Y,xradius,yradius,Stangle,EndAngle);
  1159. For i:= StAngle To EndAngle Do
  1160. Begin
  1161. tmpAng:= i*Pi/180;
  1162. curX:= X + Round (xRadius*Cos (tmpAng));
  1163. curY:= Y - Round (YRadius*Sin (tmpAng));
  1164. PutPixel (curX, curY, TheColor);
  1165. End;
  1166. end;
  1167. procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
  1168. Var I,tmpcolor : longint;
  1169. tmpang : real;
  1170. tmpx,tmpy : Integer;
  1171. begin
  1172. tmpcolor:=Thecolor;
  1173. SetColor(TheFillColor);
  1174. For i:= 0 to 180 Do
  1175. Begin
  1176. tmpAng:= i*Pi/180;
  1177. curX:= Round (xRadius*Cos (tmpAng));
  1178. curY:= Round (YRadius*Sin (tmpAng));
  1179. tmpX:= X - curx;
  1180. tmpy:= Y + cury;
  1181. curx:=x+curx;
  1182. cury:=y-cury;
  1183. Line (curX, curY,tmpx,tmpy);
  1184. PutPixel (curx,cury,tmpcolor);
  1185. PutPixel (tmpx,tmpy,tmpcolor);
  1186. End;
  1187. SetColor(tmpcolor);
  1188. end;
  1189. procedure SetAspectRatio(Xasp, Yasp: Word);
  1190. begin
  1191. //!! Needs implementing.
  1192. end;
  1193. procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
  1194. Begin
  1195. sector (x,y,stangle,endangle,radius,radius);
  1196. end;
  1197. procedure Sector(X, Y: Integer;
  1198. StAngle, EndAngle, XRadius, YRadius: Word);
  1199. Var I,tmpcolor : longint;
  1200. tmpang : real;
  1201. ac : arccoordstype;
  1202. begin
  1203. tmpcolor:=Thecolor;
  1204. SetColor(TheFillColor);
  1205. For i:= stangle to endangle Do
  1206. Begin
  1207. tmpAng:= i*Pi/180;
  1208. curX:= x+Round (xRadius*Cos (tmpAng));
  1209. curY:= y-Round (YRadius*Sin (tmpAng));
  1210. Line (x,y,curX, curY);
  1211. PutPixel (curx,cury,tmpcolor);
  1212. End;
  1213. SetColor(tmpcolor);
  1214. getarccoords(ac);
  1215. Line (x,y,ac.xstart,ac.ystart);
  1216. Line (x,y,ac.xend,ac.yend);
  1217. end;
  1218. { Color routines
  1219. }
  1220. procedure SetBkColor(ColorNum: Word);
  1221. begin
  1222. BackColor := ColorTable[ColorNum];
  1223. end;
  1224. Function GetBkColor : Word;
  1225. begin
  1226. GetBkColor:=BackColor;
  1227. end;
  1228. procedure SetColor(Color: Word);
  1229. begin
  1230. TheColor := ColorTable[Color];
  1231. end;
  1232. Function GetColor : Word;
  1233. begin
  1234. GetColor:=TheColor;
  1235. end;
  1236. function GetMaxColor : Word;
  1237. begin
  1238. getmaxcolor:=16;
  1239. end;
  1240. procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
  1241. var
  1242. SaveClipRect: TRect;
  1243. begin
  1244. with TBitmap(Bitmap) do
  1245. begin
  1246. Width := x2 - x1 + 1;
  1247. Height := y2 - y1 + 1;
  1248. if not NoGraphics
  1249. then begin
  1250. {gl_disableclipping(0);}
  1251. SaveClipRect := ClipRect;
  1252. SetClipRect(0, 0, SizeX, SizeY);
  1253. gl_getbox(x1 + DrawDelta.X, y1 + DrawDelta.Y,
  1254. x2 - x1 + 1, y2 - y1 + 1, @Data);
  1255. SetClipRectR(SaveClipRect)
  1256. end;
  1257. end;
  1258. end;
  1259. procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);
  1260. var
  1261. R: TRect;
  1262. SaveClipRect: TRect;
  1263. begin
  1264. if not NoGraphics then
  1265. with TBitmap(Bitmap) do
  1266. begin
  1267. {gl_putbox(x + DrawDelta.X, y + DrawDelta.Y, Width, Height, @Data)}
  1268. R.Assign(X + DrawDelta.X, Y + DrawDelta.Y,
  1269. X + DrawDelta.X + Width, Y + DrawDelta.Y + Height);
  1270. R.Intersect(ClipRect);
  1271. if not R.Empty
  1272. then begin
  1273. {gl_disableclipping(0);}
  1274. SaveClipRect := ClipRect;
  1275. SetClipRect(0, 0, SizeX, SizeY);
  1276. gl_putboxpart(R.A.X, R.A.Y,
  1277. R.B.X - R.A.X, R.B.Y - R.A.Y,
  1278. Width, Height,
  1279. @Data,
  1280. R.A.X - X, R.A.Y - Y);
  1281. SetClipRectR(SaveClipRect);
  1282. end;
  1283. end;
  1284. end; { PutImage }
  1285. function ImageSize(x1, y1, x2, y2: Integer): LongInt;
  1286. begin
  1287. if NoGraphics
  1288. then ImageSize := SizeOf(TBitmap)
  1289. else ImageSize := SizeOf(TBitmap)
  1290. + LongInt(x2 - x1 + 1) * LongInt(y2 - y1 + 1) * PhysicalScreen^.BytesPerPixel;
  1291. end;
  1292. function GetMaxX : Integer;
  1293. begin
  1294. GetMaxX:=vga_getxdim;
  1295. end;
  1296. function GetMAxY : Integer;
  1297. begin
  1298. GetMaxY:=vga_getydim;
  1299. end;
  1300. Procedure DetectGraph (Var Driver,Mode : Integer);
  1301. begin
  1302. Driver:=9;
  1303. Mode:=vga_getdefaultmode;
  1304. If Mode=-1 then mode:=0;
  1305. end;
  1306. Var VgaMode : Integer;
  1307. Procedure InitGraph (Var Driver,Mode : Integer;DriverPath : String);
  1308. var
  1309. ModeInfo: pvga_modeinfo;
  1310. begin
  1311. If Mode=0 then
  1312. VgaMode := vga_getdefaultmode
  1313. else
  1314. VGAMode :=Mode;
  1315. if (VgaMode = -1) then VgaMode := G320X200X256;
  1316. if (not vga_hasmode(VgaMode))
  1317. then begin
  1318. WriteLn('BGI: Mode not available.');
  1319. Halt(1)
  1320. end;
  1321. ModeInfo := vga_getmodeinfo(VgaMode);
  1322. {IsVirtual := (ModeInfo^.colors = 16) or (ModeInfo^.flags and IS_MODEX <> 0);}
  1323. IsVirtual := true;
  1324. { We always want a back screen (for buffering). }
  1325. if IsVirtual
  1326. then begin
  1327. { Create virtual screen }
  1328. gl_setcontextvgavirtual(VgaMode);
  1329. BackScreen := gl_allocatecontext;
  1330. gl_getcontext(BackScreen)
  1331. end;
  1332. vga_setmode(VgaMode);
  1333. gl_setcontextvga(VgaMode); { Physical screen context. }
  1334. PhysicalScreen := gl_allocatecontext;
  1335. gl_getcontext(PhysicalScreen);
  1336. if (PhysicalScreen^.colors = 256) then gl_setrgbpalette;
  1337. SetColors;
  1338. SizeX := PhysicalScreen^.Width;
  1339. SizeY := PhysicalScreen^.Height
  1340. end;
  1341. Procedure CloseGraph;
  1342. begin
  1343. DoneVideo;
  1344. end;
  1345. Function GraphResult : Integer;
  1346. begin
  1347. GraphResult:=0;
  1348. end;
  1349. Procedure GraphDefaults ;
  1350. begin
  1351. end;
  1352. Function GraphErrorMsg (Errcode : Integer) : String;
  1353. begin
  1354. GraphErrorMsg:='';
  1355. end;
  1356. Procedure ClearDevice;
  1357. begin
  1358. SetViewPort (0,0,GetMaxX,GetMaxY,False);
  1359. ClearViewPort;
  1360. MoveTo(0,0);
  1361. end;
  1362. Procedure GetDefaultPalette (Var Palette : Palettetype);
  1363. begin
  1364. //!! Not yet implemented.
  1365. end;
  1366. Function GetDriverName : String;
  1367. begin
  1368. GetDriverName:='libvga';
  1369. end;
  1370. Function GetGraphMode : Integer;
  1371. begin
  1372. GetGraphMode:=VgaMode;
  1373. end;
  1374. Procedure GetFillPattern (Var FillPattern : FillPatternType);
  1375. begin
  1376. FillPattern:=TheFillPattern;
  1377. end;
  1378. Procedure GetFillSettings (Var FillSettings : FillSettingsType);
  1379. begin
  1380. FillSettings:=TheFillSettings;
  1381. end;
  1382. Procedure GetLineSettings (Var LineInfo : LineSettingsType);
  1383. begin
  1384. LineInfo:=TheLineSettings;
  1385. end;
  1386. Function GetMaxMode : Word;
  1387. begin
  1388. GetMaxMode:=GLastMode;
  1389. end;
  1390. Function GetModeName (Var Modus : INteger) : String;
  1391. begin
  1392. GetModeName:='VGA'
  1393. end;
  1394. Procedure GetModeRange (Driver : Integer; Var loModus,HiModus : Integer);
  1395. begin
  1396. LoModus:=1;
  1397. HiModus:=GLASTMODE;
  1398. end;
  1399. Procedure GetPalette (Var Palette : PaletteType);
  1400. begin
  1401. Palette:=ThePalette;
  1402. end;
  1403. Procedure SetAllPalette (Var Palette);
  1404. begin
  1405. ThePalette:=PaletteType(Palette);
  1406. end;
  1407. Procedure SetPalette (ColorNr : Word; NewColor : ShortInt);
  1408. begin
  1409. //!! not implemented.
  1410. end;
  1411. Function GetPaletteSize : Word;
  1412. begin
  1413. GetPaletteSize:=16;
  1414. end;
  1415. Procedure GetTextSettings (Var TextInfo : TextSettingsType);
  1416. begin
  1417. TextInfo:=TheTextSettings;
  1418. end;
  1419. Function InstallUserDriver (DriverPat :String; AutodetectPtr : Pointer) : Integer;
  1420. begin
  1421. InstallUserDriver:=grError;
  1422. end;
  1423. Function InstallUserFont (FontPath : String) : Integer;
  1424. begin
  1425. InstallUserFont:=0;
  1426. end;
  1427. Function RegisterBGIDriver (Driver : Pointer) : Integer;
  1428. begin
  1429. RegisterBGIDriver:=grError;
  1430. end;
  1431. Function RegisterBGIFont (Font : Pointer) : Integer;
  1432. begin
  1433. RegisterBGIFont:=grError;
  1434. end;
  1435. Procedure RestoreCRTmode;
  1436. begin
  1437. vga_setmode(GTEXT);
  1438. end;
  1439. Procedure SetActivePage (Page : Word);
  1440. begin
  1441. //!! Not implemented
  1442. end;
  1443. Procedure SetVisualPage (Page : Word);
  1444. begin
  1445. //!! Not implemented
  1446. end;
  1447. Procedure SetGraphBufSize (BufSize : Word);
  1448. begin
  1449. end;
  1450. Procedure SetGraphMode (Mode :Integer);
  1451. begin
  1452. vga_setmode(Mode);
  1453. VgaMode:=Mode;
  1454. end;
  1455. begin
  1456. { Give up root permissions if we are root. }
  1457. if geteuid = 0 then vga_init;
  1458. end.
  1459. {
  1460. $Log$
  1461. Revision 1.9 1998-09-13 19:22:06 michael
  1462. + Implemented dummies for all missing functions
  1463. Revision 1.8 1998/09/11 09:24:55 michael
  1464. Added missing functions so mandel compiles and runs
  1465. Revision 1.7 1998/08/24 08:23:47 michael
  1466. Better initgraph handling.
  1467. Revision 1.6 1998/08/14 09:20:36 michael
  1468. Typo fixed. linklib gl to linklib vgagl
  1469. Revision 1.5 1998/08/12 14:01:08 michael
  1470. small fix in sector, pieslice replaced by call to sector
  1471. Revision 1.4 1998/08/12 13:25:33 michael
  1472. + added arc,ellipse,fillelipse,sector,pieslice
  1473. Revision 1.3 1998/08/10 09:01:58 michael
  1474. + Added some functions to improve compatibility
  1475. Revision 1.2 1998/05/12 10:42:47 peter
  1476. * moved getopts to inc/, all supported OS's need argc,argv exported
  1477. + strpas, strlen are now exported in the systemunit
  1478. * removed logs
  1479. * removed $ifdef ver_above
  1480. Revision 1.1 1998/04/15 13:40:11 michael
  1481. + Initial implementation of graph unit
  1482. }