graph.pp 42 KB

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