graph.pp 78 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1993,99 by the Free Pascal development team
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. Unit Graph2;
  11. {-------------------------------------------------------}
  12. { Differences with TP Graph unit: }
  13. { - default putimage and getimage only support a max. }
  14. { of 64K colors on screen, because all pixels are }
  15. { saved as words. }
  16. { - Set RGB Palette is not used, SetPalette must be }
  17. { used instead. }
  18. { - In the TP graph unit, Clipping is always performed }
  19. { on strings written with OutText, and this clipping }
  20. { is done on a character per character basis (for }
  21. { example, if ONE part of a character is outside the }
  22. { viewport , then that character is not written at }
  23. { all to the screen. In FPC Pascal, clipping is done }
  24. { on a PIXEL basis, not a character basis, so part of }
  25. { characters which are not entirely in the viewport }
  26. { may appear on the screen. }
  27. { - SetTextStyle only conforms to the TP version when }
  28. { the correct (and expected) values are used for }
  29. { CharSize for stroked fonts (4 = stroked fonts) }
  30. { - InstallUserDriver is not supported, so always }
  31. { returns an error. }
  32. { - RegisterBGIDriver is not supported, so always }
  33. { returns an error. }
  34. { - DrawPoly XORPut mode is not exactly the same as in }
  35. { the TP graph unit. }
  36. { - FillEllipse does not support XORPut mode with a }
  37. { bounded FloodFill. Mode is always CopyPut mode. }
  38. { - Imagesize returns a longint instead of a word }
  39. { - ImageSize cannot return an error value }
  40. {-------------------------------------------------------}
  41. { AUTHORS: }
  42. { Gernot Tenchio - original version }
  43. { Florian Klaempfl - major updates }
  44. { Pierre Mueller - major bugfixes }
  45. { Carl Eric Codere - complete rewrite }
  46. { Thomas Schatzl - optimizations,routines and }
  47. { Credits (external): suggestions. }
  48. { - Original FloodFill code by }
  49. { Menno Victor van der star }
  50. { (the code has been heavily modified) }
  51. {-------------------------------------------------------}
  52. {-------------------------------------------------------}
  53. { For significant speed improvements , is is recommended }
  54. { that these routines be hooked (otherwise the default, }
  55. { slower routines will be used) : }
  56. { HLine() }
  57. { VLine() }
  58. { PatternLine() }
  59. { ClearViewPort() }
  60. { PutImage() }
  61. { GetImage() - ImageSize() should also be changed }
  62. { InternalEllipse() }
  63. { Line() }
  64. { GetScanLine() }
  65. {--------------------------------------------------------}
  66. { FPC unit requirements: }
  67. { All modes should at least have 1 graphics page to }
  68. { make it possible to create animation on all supported }
  69. { systems , this can be done either by double-buffering }
  70. { yourself in the heap if no hardware is available to do}
  71. { it. }
  72. {--------------------------------------------------------}
  73. { COMPATIBILITY WARNING: Some of the compatibility tests }
  74. { were done using the CGA and other the VGA drivers. }
  75. { Within the BGI drivers themselves the BEHAVIOUR is not }
  76. { the same, so be warned!!! }
  77. {--------------------------------------------------------}
  78. { History log: }
  79. { 15th February 1999: }
  80. { + Added support for system font in vertical mode }
  81. { + system font is now available for all platforms }
  82. { * font support routines now compile }
  83. { * textHeight would not return correct size for system }
  84. { font }
  85. { * Alignment of fonts partly fixed }
  86. { 17th Feb. 1999: }
  87. { + First support for stroked fonts }
  88. { 18th Feb. 1999: }
  89. { * bugfix of line drawing which fixes stroked font }
  90. { displays. }
  91. { 23rd Feb. 1999: }
  92. { + Applied Pierre's patches to font }
  93. { + Added scaling of bitmapped fonts }
  94. { + Vertical stroked fonts }
  95. { 24th Feb. 1999: }
  96. { * Scaling of stroked fonts must be done using FPs }
  97. { to be 100% compatible with turbo pascal }
  98. { + Sped up by 40% stroked font scaling calculations }
  99. { + RegisterBGIFont }
  100. { 9th march 1999: }
  101. { + Starting implementing Fillpoly() }
  102. { 15th march 1999: }
  103. { + SetFillStyle() }
  104. { + patternLine() }
  105. { + Bar() }
  106. { * GraphDefaults would not make the Default color }
  107. { of the fill pattern to the Max. Palette entry. }
  108. { + SetFillPattern() }
  109. { 20th march 1999: }
  110. { * GraphDefaults would not reset to the text system }
  111. { * DefaultFont would write one character too much to }
  112. { the screen }
  113. { + Sloped thick lines in Line() }
  114. { + Sloped patterned lines in Line() }
  115. { * GraphDefaults would not reset the User Fill pattern}
  116. { to $ff }
  117. { + DirectPutPixel takes care of XOR mode writes }
  118. { improves speed by about 30% over old method of }
  119. { GetPixel XOR CurrentColor }
  120. { * Dashed LineStyle exactly like BP version now }
  121. { + Center LineStyle (checked against CGA driver) }
  122. { * GraphDefaults() now resets linepattern array }
  123. { 1st april 1999: }
  124. { + First implementation of FillPoly (incomplete) }
  125. { 2nd april 1999: }
  126. { * FillPoly did not Reset PatternLine index }
  127. { * FillPoly did not use correct color }
  128. { * PatternLine was writing modes in reverse direction }
  129. { * PatternLine would not work with non-rectangular }
  130. { shapes. }
  131. { * PatternLine must fill up the ENTIRE pattern, }
  132. { with either the foreground or background color. }
  133. { * GraphDefaults() would not call SetBkColor() }
  134. { * Fixed some memory leaks in FillPoly() }
  135. { 11th April 1999: }
  136. { * PatternLine() was drawing one pixel less then }
  137. { requested }
  138. { 12th April 1999: }
  139. { + FloodFill - first working implementation }
  140. { Horrbly slow even on very fast cpu's }
  141. { + Some suggestions of Thomas implemented }
  142. { 13th April 1999: }
  143. { * FloodFill() vertical index was off by one pixel }
  144. { * FloodFill() would never draw the last line in the }
  145. { list }
  146. { - Removed ClearViewPort320 which was wrong anyways, }
  147. { will need to be implemented later. }
  148. { * PatternLine() would not always restore write mode }
  149. { + Circle() uses NormalPut always with NormWidth lines}
  150. { + FillEllipse() initial version }
  151. { * InternalEllipse() - 0 to 360 now supported as }
  152. { angles. }
  153. { 14th April 1999: }
  154. { * mod x = and (x-1)(from Thomas Schatzl) gives a }
  155. { significant speed improvement. }
  156. { 15th april 1999: }
  157. { + Arc() ok except for Aspect Ratio, which does not }
  158. { give us the correct ratio on a 320x200 screen. }
  159. { + Added FillPoly() from Thomas Schatzl }
  160. { + More hookable routines }
  161. { 16th april 1999: }
  162. { + Line() checked ok. }
  163. { 17th april 1999: }
  164. { * GraphDefaults() would not reset CP }
  165. { + GetX(), GetY(), MoveTo() checked for viewports }
  166. { * OutTextXY() should not update the CP }
  167. { * ClearViewPort() would not update the CP }
  168. { * ClearDevice() would not update the CP }
  169. { * Sector() would update the CP by calling LineTo }
  170. { * Bar3D() would update the CP }
  171. { * PieSlice() would update the CP }
  172. { 18th april 1999: }
  173. { + Clipping algorithm }
  174. { 19th april 1999: }
  175. { + Adapterinfo structure }
  176. { 20th april 1999: }
  177. { + GetModeName }
  178. { + GetGraphMode }
  179. { + GetModeRange }
  180. {--------------------------------------------------------}
  181. { LEFT TO DO: }
  182. { - optimize scaling of stroked fonts }
  183. { - optimize InternalEllipse() }
  184. { using linear appx. of sine/cosine tables }
  185. { - justification for stroked fonts does not work }
  186. { - On Closegraph deallocate all font pointers }
  187. {--------------------------------------------------------}
  188. { text.inc will crash on aligned requirement machines. }
  189. { (packed record for fontrec) }
  190. {$G+}
  191. Interface
  192. const
  193. { error codes }
  194. grOk = 0;
  195. grNoInitGraph = -1;
  196. grNotDetected = -2;
  197. grFileNotFound = -3;
  198. grInvalidDriver = -4;
  199. grNoLoadMem = -5;
  200. grNoScanMem = -6;
  201. grNoFloodMem = -7;
  202. grFontNotFound = -8;
  203. grNoFontMem = -9;
  204. grInvalidMode = -10;
  205. grError = -11;
  206. grIOerror = -12;
  207. grInvalidFont = -13;
  208. grInvalidFontNum = -14;
  209. grInvalidVersion = -18;
  210. { Color constants for setpalette }
  211. black = 0;
  212. blue = 1;
  213. green = 2;
  214. cyan = 3;
  215. red = 4;
  216. magenta = 5;
  217. brown = 6;
  218. lightgray = 7;
  219. darkgray = 8;
  220. lightblue = 9;
  221. lightgreen = 10;
  222. lightcyan = 11;
  223. lightred = 12;
  224. lightmagenta = 13;
  225. yellow = 14;
  226. white = 15;
  227. EGABlack = 0;
  228. EGABlue = 1;
  229. EGAGreen = 2;
  230. EGACyan = 3;
  231. EGARed = 4;
  232. EGAMagenta = 5;
  233. EGALightgray= 7;
  234. EGABrown = 20;
  235. EGADarkgray = 56;
  236. EGALightblue = 57;
  237. EGALightgreen = 58;
  238. EGALightcyan = 59;
  239. EGALightred = 60;
  240. EGALightmagenta=61;
  241. EGAYellow = 62;
  242. EGAWhite = 63;
  243. { Line styles for GetLineStyle/SetLineStyle }
  244. SolidLn = 0;
  245. DottedLn = 1;
  246. CenterLn = 2;
  247. DashedLn = 3;
  248. UserBitLn = 4;
  249. NormWidth = 1;
  250. ThickWidth = 3;
  251. { Set/GetTextStyle Konstanten: }
  252. DefaultFont = 0;
  253. TriplexFont = 1;
  254. SmallFont = 2;
  255. SansSerifFont = 3;
  256. GothicFont = 4;
  257. ScriptFont = 5;
  258. SimpleFont = 6;
  259. TSCRFont = 7;
  260. LCOMFont = 8;
  261. EuroFont = 9;
  262. BoldFont = 10;
  263. HorizDir = 0;
  264. VertDir = 1;
  265. UserCharSize = 0;
  266. ClipOn = true;
  267. ClipOff = false;
  268. { Bar3D constants }
  269. TopOn = true;
  270. TopOff = false;
  271. { fill pattern for Get/SetFillStyle: }
  272. EmptyFill = 0;
  273. SolidFill = 1;
  274. LineFill = 2;
  275. LtSlashFill = 3;
  276. SlashFill = 4;
  277. BkSlashFill = 5;
  278. LtBkSlashFill = 6;
  279. HatchFill = 7;
  280. XHatchFill = 8;
  281. InterleaveFill = 9;
  282. WideDotFill = 10;
  283. CloseDotFill = 11;
  284. UserFill = 12;
  285. { bitblt operators }
  286. NormalPut = 0;
  287. CopyPut = 0;
  288. XORPut = 1;
  289. OrPut = 2;
  290. AndPut = 3;
  291. NotPut = 4;
  292. { SetTextJustify constants }
  293. LeftText = 0;
  294. CenterText = 1;
  295. RightText = 2;
  296. BottomText = 0;
  297. TopText = 2;
  298. { graphic drivers }
  299. CurrentDriver = -128;
  300. Detect = 0;
  301. LowRes = 1;
  302. HercMono = 7;
  303. VGA = 9;
  304. VESA = 10;
  305. { graph modes }
  306. Default = 0;
  307. { VGA Driver modes }
  308. VGALo = 0;
  309. VGAMed = 1;
  310. VGAHi = 2;
  311. { Hercules mono card }
  312. HercMonoHi = 0;
  313. MaxColors = 65535; { Maximum possible colors using a palette }
  314. { otherwise, direct color encoding }
  315. type
  316. RGBRec = packed record
  317. Red: integer;
  318. Green: integer;
  319. Blue : integer;
  320. end;
  321. {$ifndef FPC}
  322. PaletteType = record
  323. Size : longint;
  324. Colors : array[0..255] of RGBRec;
  325. end;
  326. {$else}
  327. PaletteType = record
  328. Size : longint;
  329. Colors : array[0..MaxColors] of RGBRec;
  330. end;
  331. {$endif}
  332. LineSettingsType = record
  333. linestyle : word;
  334. pattern : word;
  335. thickness : word;
  336. end;
  337. TextSettingsType = record
  338. font : word;
  339. direction : word;
  340. charsize : word;
  341. horiz : word;
  342. vert : word;
  343. end;
  344. FillSettingsType = record
  345. pattern : word;
  346. color : word;
  347. end;
  348. FillPatternType = array[1..8] of byte;
  349. PointType = record
  350. x,y : integer;
  351. end;
  352. ViewPortType = record
  353. x1,y1,x2,y2 : integer;
  354. Clip : boolean;
  355. end;
  356. ArcCoordsType = record
  357. x,y : integer;
  358. xstart,ystart : integer;
  359. xend,yend : integer;
  360. end;
  361. const
  362. fillpatternTable : array[0..12] of FillPatternType = (
  363. ($00,$00,$00,$00,$00,$00,$00,$00), { background color }
  364. ($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff), { foreground color }
  365. ($ff,$ff,$00,$00,$ff,$ff,$00,$00), { horizontal lines }
  366. ($01,$02,$04,$08,$10,$20,$40,$80), { slashes }
  367. ($07,$0e,$1c,$38,$70,$e0,$c1,$83), { thick slashes }
  368. ($07,$83,$c1,$e0,$70,$38,$1c,$0e), { thick backslashes }
  369. ($5a,$2d,$96,$4b,$a5,$d2,$69,$b4), { backslashes }
  370. ($ff,$88,$88,$88,$ff,$88,$88,$88), { small boxes }
  371. ($18,$24,$42,$81,$81,$42,$24,$18), { rhombus }
  372. ($cc,$33,$cc,$33,$cc,$33,$cc,$33), { wall pattern }
  373. ($80,$00,$08,$00,$80,$00,$08,$00), { wide points }
  374. ($88,$00,$22,$00,$88,$00,$22,$00), { dense points }
  375. (0,0,0,0,0,0,0,0) { user defined line style }
  376. );
  377. { ******************** PROCEDURAL VARIABLES ********************* }
  378. { * These are hooks which have device specific stuff in them, * }
  379. { * therefore to add new modes or to redirect these routines * }
  380. { * then declare variables of these types as shown below. * }
  381. {-----------------------------------------------------------------}
  382. TYPE
  383. { This is the standard putpixel routine used by all function }
  384. { drawing routines, it will use the viewport settings, as }
  385. { well as clip, and use the current foreground color to plot }
  386. { the desired pixel. }
  387. defpixelproc = procedure(X,Y: Integer);
  388. { standard plot and get pixel }
  389. getpixelproc = function(X,Y: Integer): word;
  390. putpixelproc = procedure(X,Y: Integer; Color: Word);
  391. { clears the viewport, also used to clear the device }
  392. clrviewproc = procedure;
  393. { putimage procedure, can be hooked to accomplish transparency }
  394. putimageproc = procedure (X,Y: Integer; var Bitmap; BitBlt: Word);
  395. getimageproc = procedure(X1,Y1,X2,Y2: Integer; Var Bitmap);
  396. imagesizeproc= function (X1,Y1,X2,Y2: Integer): longint;
  397. graphfreememprc = procedure (var P: Pointer; size: word);
  398. graphgetmemprc = procedure (var P: pointer; size: word);
  399. { internal routines -- can be hooked for much faster drawing }
  400. { draw filled horizontal lines using current color }
  401. { on entry coordinates are already clipped. }
  402. hlineproc = procedure (x, x2,y : integer);
  403. { on entry coordinates are already clipped. }
  404. { draw filled vertical line using current color }
  405. vlineproc = procedure (x,y,y2: integer);
  406. { this routine is used to draw filled patterns for all routines }
  407. { that require it. (FillPoly, FloodFill, Sector, etc... }
  408. { clipping is verified, uses current Fill settings for drawing }
  409. patternlineproc = procedure (x1,x2,y: integer);
  410. { this routine is used to draw all circles/ellipses/sectors }
  411. { more info... on this later... }
  412. ellipseproc = procedure (X,Y: Integer;XRadius: word;
  413. YRadius:word; stAngle,EndAngle: word);
  414. { Line routine - draws lines thick/norm widths with current }
  415. { color and line style - LINE must be clipped here. }
  416. lineproc = procedure (X1, Y1, X2, Y2 : Integer);
  417. { this routine is used for FloodFill - it returns an entire }
  418. { screen scan line with a word for each pixel in the scanline }
  419. getscanlineproc = procedure (Y : integer; var data);
  420. { changes the active display screen where we draw to... }
  421. setactivepageproc = procedure (page: word);
  422. { changes the active display screen which we see ... }
  423. setvisualpageproc = procedure (page: word);
  424. { this routine actually switches to the desired video mode. }
  425. initmodeproc = procedure;
  426. { this routine is called to save the sate just before a mode set }
  427. savestateproc = procedure;
  428. { this routine is called in closegraph to cleanup... }
  429. restorestateproc = procedure;
  430. { This routine is a hook for SetRGBPalette }
  431. setrgbpaletteproc =
  432. procedure(ColorNum, RedValue, GreenValue, BlueValue: Integer);
  433. { This routine is a hook for GetRGBPalette }
  434. getrgbpaletteproc =
  435. procedure(ColorNum: integer; var
  436. RedValue, GreenValue, BlueValue: Integer);
  437. TYPE
  438. {-----------------------------------}
  439. { Linked list for mode information }
  440. { This list is set up by one of the }
  441. { following routines: }
  442. { It lists all available resolutions}
  443. { on this display adapter. }
  444. {-----------------------------------}
  445. { QueryAdapter() }
  446. { DetectGraph() }
  447. { InitGraph() }
  448. {-----------------------------------}
  449. PModeInfo = ^TModeInfo;
  450. TModeInfo = record
  451. DriverNumber: Integer;
  452. ModeNumber: Integer;
  453. MaxColor: Longint; { Maximum colors on screen }
  454. PaletteSize : Longint; { Maximum palette entry we can change }
  455. XAspect : Integer; { XAspect ratio correction factor }
  456. YAspect : Integer; { YAspect ratio correction factor }
  457. MaxX: Integer; { Max-X row }
  458. MaxY: Integer; { Max. column. }
  459. DirectColor: boolean; { Is this a direct color mode?? }
  460. ModeName: String[18];
  461. { necessary hooks ... }
  462. DirectPutPixel : DefPixelProc;
  463. GetPixel : GetPixelProc;
  464. PutPixel : PutPixelProc;
  465. SetRGBPalette : SetRGBPaletteProc;
  466. GetRGBPalette : GetRGBPaletteProc;
  467. { defaults possible ... }
  468. SetVisualPage : SetVisualPageProc;
  469. SetActivePage : SetActivePageProc;
  470. ClearViewPort : ClrViewProc;
  471. PutImage : PutImageProc;
  472. GetImage : GetImageProc;
  473. ImageSize : ImageSizeProc;
  474. GetScanLine : GetScanLineProc;
  475. Line : LineProc;
  476. InternalEllipse: EllipseProc;
  477. PatternLine : PatternLineProc;
  478. HLine : HLineProc;
  479. VLine : VLineProc;
  480. InitMode : InitModeProc;
  481. next: PModeInfo;
  482. end;
  483. VAR
  484. DirectPutPixel : DefPixelProc;
  485. ClearViewPort : ClrViewProc;
  486. PutPixel : PutPixelProc;
  487. PutImage : PutImageProc;
  488. GetImage : GetImageProc;
  489. ImageSize : ImageSizeProc;
  490. GetPixel : GetPixelProc;
  491. SetVisualPage : SetVisualPageProc;
  492. SetActivePage : SetActivePageProc;
  493. SetRGBPalette : SetRGBPaletteProc;
  494. GetRGBPalette : GetRGBPaletteProc;
  495. GraphFreeMemPtr: graphfreememprc;
  496. GraphGetMemPtr : graphgetmemprc;
  497. GetScanLine : GetScanLineProc;
  498. Line : LineProc;
  499. InternalEllipse: EllipseProc;
  500. PatternLine : PatternLineProc;
  501. HLine : HLineProc;
  502. VLine : VLineProc;
  503. SaveVideoState : SaveStateProc;
  504. RestoreVideoState: RestoreStateProc;
  505. Procedure Closegraph;
  506. procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word);
  507. function GraphErrorMsg(ErrorCode: Integer): string;
  508. Function GetMaxX: Integer;
  509. Function GetMaxY: Integer;
  510. Procedure SetViewPort(X1, Y1, X2, Y2: Integer; Clip: Boolean);
  511. Function GraphResult: Integer;
  512. function GetModeName(ModeNumber: integer): string;
  513. procedure SetGraphMode(Mode: Integer);
  514. function GetGraphMode: Integer;
  515. function GetMaxMode: word;
  516. procedure RestoreCrtMode;
  517. procedure GetModeRange(GraphDriver: Integer; var LoMode, HiMode: Integer);
  518. Function GetX: Integer;
  519. Function GetY: Integer;
  520. procedure GraphDefaults;
  521. procedure ClearDevice;
  522. procedure GetViewSettings(var viewport : ViewPortType);
  523. procedure SetWriteMode(WriteMode : integer);
  524. procedure GetFillSettings(var Fillinfo:Fillsettingstype);
  525. procedure GetFillPattern(var FillPattern:FillPatternType);
  526. procedure GetLineSettings(var ActiveLineInfo : LineSettingsType);
  527. procedure InitGraph(var GraphDriver:Integer;var GraphMode:Integer;const PathToDriver:String);
  528. function InstallUserDriver(Name: string; AutoDetectPtr: Pointer): integer;
  529. function RegisterBGIDriver(driver: pointer): integer;
  530. procedure SetFillStyle(Pattern : word; Color: word);
  531. procedure SetFillPattern(Pattern: FillPatternType; Color: word);
  532. procedure MoveRel(Dx, Dy: Integer);
  533. procedure MoveTo(X,Y: Integer);
  534. procedure SetDirectVideo(DirectAccess: boolean);
  535. function GetDirectVideo: boolean;
  536. { -------------------- Color/Palette ------------------------------- }
  537. procedure SetBkColor(ColorNum: Word);
  538. function GetColor: Word;
  539. function GetBkColor: Word;
  540. procedure SetColor(Color: Word);
  541. function GetMaxColor: word;
  542. procedure SetAllPalette(var Palette:PaletteType);
  543. procedure SetPalette(ColorNum: word; Color: shortint);
  544. procedure GetPalette(var Palette: PaletteType);
  545. function GetPaletteSize: integer;
  546. procedure GetDefaultPalette(var Palette: PaletteType);
  547. { -------------------- Shapes/Lines -------------------------------- }
  548. procedure Rectangle(x1,y1,x2,y2:integer);
  549. procedure Bar(x1,y1,x2,y2:integer);
  550. procedure Bar3D(x1, y1, x2, y2 : integer;depth : word;top : boolean);
  551. procedure FillPoly(NumPoints: word; Var PolyPoints);
  552. procedure DrawPoly(NumPoints : word;var polypoints);
  553. procedure LineRel(Dx, Dy: Integer);
  554. procedure LineTo(X,Y : Integer);
  555. procedure FloodFill(x : integer; y : integer; Border: word);
  556. { -------------------- Circle related routines --------------------- }
  557. procedure GetAspectRatio(var Xasp,Yasp : word);
  558. procedure SetAspectRatio(Xasp, Yasp : word);
  559. procedure GetArcCoords(var ArcCoords: ArcCoordsType);
  560. procedure Arc(X,Y : Integer; StAngle,EndAngle,Radius: word);
  561. procedure PieSlice(X,Y,stangle,endAngle:integer;Radius: Word);
  562. procedure FillEllipse(X, Y: Integer; XRadius, YRadius: Word);
  563. procedure Circle(X, Y: Integer; Radius:Word);
  564. procedure Sector(x, y: Integer; StAngle,EndAngle, XRadius, YRadius: Word);
  565. procedure Ellipse(X,Y : Integer; stAngle, EndAngle: word; XRadius,
  566. YRadius: word);
  567. { --------------------- Text related routines --------------------- }
  568. function InstallUserFont(const FontFileName : string) : integer;
  569. function RegisterBGIfont(font : pointer) : integer;
  570. procedure GetTextSettings(var TextInfo : TextSettingsType);
  571. function TextHeight(const TextString : string) : word;
  572. function TextWidth(const TextString : string) : word;
  573. procedure SetTextJustify(horiz,vert : word);
  574. procedure SetTextStyle(font,direction : word;charsize : word);
  575. procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);
  576. procedure OutTextXY(x,y : integer;const TextString : string);
  577. procedure OutText(const TextString : string);
  578. Implementation
  579. {$IFDEF DPMI}
  580. uses WinAPI;
  581. {$ENDIF}
  582. const
  583. StdBufferSize = 4096; { Buffer size for FloodFill }
  584. type
  585. tinttable = array[0..8192] of integer;
  586. pinttable = ^tinttable;
  587. WordArray = Array [0..StdbufferSize] Of word;
  588. PWordArray = ^WordArray;
  589. const
  590. { Mask for each bit in byte used to determine pattern }
  591. BitArray: Array[0..7] of byte =
  592. ($01,$02,$04,$08,$10,$20,$40,$80);
  593. RevbitArray: Array[0..7] of byte =
  594. ($80,$40,$20,$10,$08,$04,$02,$01);
  595. { pre expanded line patterns }
  596. { 0 = LSB of byte pattern }
  597. { 15 = MSB of byte pattern }
  598. LinePatterns: Array[0..15] of BOOLEAN =
  599. (TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,
  600. TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE);
  601. const
  602. BGIPath : string = '.';
  603. { Default font 8x8 system from IBM PC }
  604. {$i fontdata.inc}
  605. var
  606. CurrentColor: Word;
  607. CurrentBkColor: Word;
  608. CurrentX : Integer; { viewport relative }
  609. CurrentY : Integer; { viewport relative }
  610. ClipPixels: Boolean; { Should cliiping be enabled }
  611. CurrentWriteMode: Integer;
  612. _GraphResult : Integer;
  613. LineInfo : LineSettingsType;
  614. FillSettings: FillSettingsType;
  615. { information for Text Output routines }
  616. CurrentTextInfo : TextSettingsType;
  617. CurrentXRatio: Real;
  618. CurrentYRatio: Real;
  619. installedfonts: longint; { Number of installed fonts }
  620. StartXViewPort: Integer; { absolute }
  621. StartYViewPort: Integer; { absolute }
  622. ViewWidth : Integer;
  623. ViewHeight: Integer;
  624. IsGraphMode : Boolean; { Indicates if we are in graph mode or not }
  625. ArcCall: ArcCoordsType; { Information on the last call to Arc or Ellipse }
  626. var
  627. { ******************** HARDWARE INFORMATION ********************* }
  628. { Should be set in InitGraph once only. }
  629. IntCurrentMode : Integer;
  630. IntCurrentDriver : Integer; { Currently loaded driver }
  631. XAspect : Integer;
  632. YAspect : Integer;
  633. MaxX : Integer; { Maximum resolution - ABSOLUTE }
  634. MaxY : Integer; { Maximum resolution - ABSOLUTE }
  635. MaxColor : Longint;
  636. PaletteSize : longint; { Maximum palette entry we can set, usually equal}
  637. { maxcolor. }
  638. DriverName: String;
  639. DirectColor : Boolean ; { Is it a direct color mode? }
  640. ModeList : PModeInfo;
  641. DirectVideo : Boolean; { Direct access to video memory? }
  642. {--------------------------------------------------------------------------}
  643. { }
  644. { LINE AND LINE RELATED ROUTINES }
  645. { }
  646. {--------------------------------------------------------------------------}
  647. {$i clip.inc}
  648. procedure HLineDefault(x,x2,y: integer);
  649. var
  650. Col: word;
  651. xtmp: integer;
  652. Begin
  653. { must we swap the values? }
  654. if x >= x2 then
  655. Begin
  656. xtmp := x2;
  657. x2 := x;
  658. x:= xtmp;
  659. end;
  660. { First convert to global coordinates }
  661. X := X + StartXViewPort;
  662. X2 := X2 + StartXViewPort;
  663. Y := Y + StartYViewPort;
  664. if ClipPixels then
  665. Begin
  666. if LineClipped(x,y,x2,y,StartXViewPort,StartYViewPort,
  667. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  668. exit;
  669. end;
  670. for x:= x to x2 do
  671. DirectPutPixel(X,Y);
  672. end;
  673. procedure VLineDefault(x,y,y2: integer);
  674. var
  675. Col: word;
  676. ytmp: integer;
  677. Begin
  678. { must we swap the values? }
  679. if y >= y2 then
  680. Begin
  681. ytmp := y2;
  682. y2 := y;
  683. y:= ytmp;
  684. end;
  685. { First convert to global coordinates }
  686. X := X + StartXViewPort;
  687. Y2 := Y2 + StartYViewPort;
  688. Y := Y + StartYViewPort;
  689. if ClipPixels then
  690. Begin
  691. if LineClipped(x,y,x,y2,StartXViewPort,StartYViewPort,
  692. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  693. exit;
  694. end;
  695. for y := y to y2 do Directputpixel(x,y)
  696. End;
  697. procedure LineDefault(X1, Y1, X2, Y2: Integer);
  698. var X, Y : Integer;
  699. deltax, deltay : Integer;
  700. d, dinc1, dinc2: Integer;
  701. xinc1 : Integer;
  702. xinc2 : Integer;
  703. yinc1 : Integer;
  704. yinc2 : Integer;
  705. i, j : Integer;
  706. Flag : Boolean; { determines pixel direction in thick lines }
  707. NumPixels : Integer;
  708. PixelCount : Integer;
  709. OldCurrentColor: Word;
  710. swtmp : integer;
  711. TmpNumPixels : integer;
  712. begin
  713. {******************************************}
  714. { SOLID LINES }
  715. {******************************************}
  716. if lineinfo.LineStyle = SolidLn then
  717. Begin
  718. { we separate normal and thick width for speed }
  719. { and because it would not be 100% compatible }
  720. { with the TP graph unit otherwise }
  721. if y1 = y2 then
  722. Begin
  723. {******************************************}
  724. { SOLID LINES HORIZONTAL }
  725. {******************************************}
  726. if lineinfo.Thickness=NormWidth then
  727. hline(x1,x2,y2)
  728. else
  729. begin
  730. { thick width }
  731. hline(x1,x2,y2-1);
  732. hline(x1,x2,y2);
  733. hline(x2,x2,y2+1);
  734. end;
  735. end
  736. else
  737. if x1 = x2 then
  738. Begin
  739. {******************************************}
  740. { SOLID LINES VERTICAL }
  741. {******************************************}
  742. if lineinfo.Thickness=NormWidth then
  743. vline(x1,y1,y2)
  744. else
  745. begin
  746. { thick width }
  747. vline(x1-1,y1,y2);
  748. vline(x1,y1,y2);
  749. vline(x1+1,y1,y2);
  750. end;
  751. end
  752. else
  753. begin
  754. { Convert to global coordinates. }
  755. x1 := x1 + StartXViewPort;
  756. x2 := x2 + StartXViewPort;
  757. y1 := y1 + StartYViewPort;
  758. y2 := y2 + StartYViewPort;
  759. { if fully clipped then exit... }
  760. if ClipPixels then
  761. begin
  762. if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
  763. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  764. exit;
  765. end;
  766. {******************************************}
  767. { SLOPED SOLID LINES }
  768. {******************************************}
  769. oldCurrentColor := CurrentColor;
  770. { Calculate deltax and deltay for initialisation }
  771. deltax := abs(x2 - x1);
  772. deltay := abs(y2 - y1);
  773. { Initialize all vars based on which is the independent variable }
  774. if deltax >= deltay then
  775. begin
  776. Flag := FALSE;
  777. { x is independent variable }
  778. numpixels := deltax + 1;
  779. d := (2 * deltay) - deltax;
  780. dinc1 := deltay Shl 1;
  781. dinc2 := (deltay - deltax) shl 1;
  782. xinc1 := 1;
  783. xinc2 := 1;
  784. yinc1 := 0;
  785. yinc2 := 1;
  786. end
  787. else
  788. begin
  789. Flag := TRUE;
  790. { y is independent variable }
  791. numpixels := deltay + 1;
  792. d := (2 * deltax) - deltay;
  793. dinc1 := deltax Shl 1;
  794. dinc2 := (deltax - deltay) shl 1;
  795. xinc1 := 0;
  796. xinc2 := 1;
  797. yinc1 := 1;
  798. yinc2 := 1;
  799. end;
  800. { Make sure x and y move in the right directions }
  801. if x1 > x2 then
  802. begin
  803. xinc1 := - xinc1;
  804. xinc2 := - xinc2;
  805. end;
  806. if y1 > y2 then
  807. begin
  808. yinc1 := - yinc1;
  809. yinc2 := - yinc2;
  810. end;
  811. { Start drawing at <x1, y1> }
  812. x := x1;
  813. y := y1;
  814. If LineInfo.Thickness=NormWidth then
  815. Begin
  816. { Draw the pixels }
  817. for i := 1 to numpixels do
  818. begin
  819. DirectPutPixel(x, y);
  820. if d < 0 then
  821. begin
  822. d := d + dinc1;
  823. x := x + xinc1;
  824. y := y + yinc1;
  825. end
  826. else
  827. begin
  828. d := d + dinc2;
  829. x := x + xinc2;
  830. y := y + yinc2;
  831. end;
  832. CurrentColor := OldCurrentColor;
  833. end;
  834. end
  835. else
  836. { Thick width lines }
  837. begin
  838. { Draw the pixels }
  839. for i := 1 to numpixels do
  840. begin
  841. { all depending on the slope, we can determine }
  842. { in what direction the extra width pixels will be put }
  843. If Flag then
  844. Begin
  845. DirectPutPixel(x-1,y);
  846. DirectPutPixel(x,y);
  847. DirectPutPixel(x+1,y);
  848. end
  849. else
  850. Begin
  851. DirectPutPixel(x, y-1);
  852. DirectPutPixel(x, y);
  853. DirectPutPixel(x, y+1);
  854. end;
  855. if d < 0 then
  856. begin
  857. d := d + dinc1;
  858. x := x + xinc1;
  859. y := y + yinc1;
  860. end
  861. else
  862. begin
  863. d := d + dinc2;
  864. x := x + xinc2;
  865. y := y + yinc2;
  866. end;
  867. CurrentColor := OldCurrentColor;
  868. end;
  869. end;
  870. end;
  871. end
  872. else
  873. {******************************************}
  874. { begin patterned lines }
  875. {******************************************}
  876. Begin
  877. { Convert to global coordinates. }
  878. x1 := x1 + StartXViewPort;
  879. x2 := x2 + StartXViewPort;
  880. y1 := y1 + StartYViewPort;
  881. y2 := y2 + StartYViewPort;
  882. { if fully clipped then exit... }
  883. if ClipPixels then
  884. begin
  885. if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
  886. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  887. exit;
  888. end;
  889. OldCurrentColor := CurrentColor;
  890. PixelCount:=0;
  891. if y1 = y2 then
  892. Begin
  893. { Check if we must swap }
  894. if x1 >= x2 then
  895. Begin
  896. swtmp := x1;
  897. x1 := x2;
  898. x2 := swtmp;
  899. end;
  900. if LineInfo.Thickness = NormWidth then
  901. Begin
  902. for PixelCount:=x1 to x2 do
  903. { optimization: PixelCount mod 16 }
  904. if LinePatterns[PixelCount and 15] = TRUE then
  905. begin
  906. DirectPutPixel(PixelCount,y2);
  907. end;
  908. end
  909. else
  910. Begin
  911. for i:=-1 to 1 do
  912. Begin
  913. for PixelCount:=x1 to x2 do
  914. { Optimization from Thomas - mod 16 = and 15 }
  915. if LinePatterns[PixelCount and 15] = TRUE then
  916. begin
  917. DirectPutPixel(PixelCount,y2+i);
  918. end;
  919. end;
  920. end;
  921. end
  922. else
  923. if x1 = x2 then
  924. Begin
  925. { Check if we must swap }
  926. if y1 >= y2 then
  927. Begin
  928. swtmp := y1;
  929. y1 := y2;
  930. y2 := swtmp;
  931. end;
  932. if LineInfo.Thickness = NormWidth then
  933. Begin
  934. for PixelCount:=y1 to y2 do
  935. { compare if we should plot a pixel here , compare }
  936. { with predefined line patterns... }
  937. if LinePatterns[PixelCount and 15] = TRUE then
  938. begin
  939. DirectPutPixel(x1,PixelCount);
  940. end;
  941. end
  942. else
  943. Begin
  944. for i:=-1 to 1 do
  945. Begin
  946. for PixelCount:=y1 to y2 do
  947. { compare if we should plot a pixel here , compare }
  948. { with predefined line patterns... }
  949. if LinePatterns[PixelCount and 15] = TRUE then
  950. begin
  951. DirectPutPixel(x1+i,PixelCount);
  952. end;
  953. end;
  954. end;
  955. end
  956. else
  957. Begin
  958. oldCurrentColor := CurrentColor;
  959. { Calculate deltax and deltay for initialisation }
  960. deltax := abs(x2 - x1);
  961. deltay := abs(y2 - y1);
  962. { Initialize all vars based on which is the independent variable }
  963. if deltax >= deltay then
  964. begin
  965. Flag := FALSE;
  966. { x is independent variable }
  967. numpixels := deltax + 1;
  968. d := (2 * deltay) - deltax;
  969. dinc1 := deltay Shl 1;
  970. dinc2 := (deltay - deltax) shl 1;
  971. xinc1 := 1;
  972. xinc2 := 1;
  973. yinc1 := 0;
  974. yinc2 := 1;
  975. end
  976. else
  977. begin
  978. Flag := TRUE;
  979. { y is independent variable }
  980. numpixels := deltay + 1;
  981. d := (2 * deltax) - deltay;
  982. dinc1 := deltax Shl 1;
  983. dinc2 := (deltax - deltay) shl 1;
  984. xinc1 := 0;
  985. xinc2 := 1;
  986. yinc1 := 1;
  987. yinc2 := 1;
  988. end;
  989. { Make sure x and y move in the right directions }
  990. if x1 > x2 then
  991. begin
  992. xinc1 := - xinc1;
  993. xinc2 := - xinc2;
  994. end;
  995. if y1 > y2 then
  996. begin
  997. yinc1 := - yinc1;
  998. yinc2 := - yinc2;
  999. end;
  1000. { Start drawing at <x1, y1> }
  1001. x := x1;
  1002. y := y1;
  1003. If LineInfo.Thickness=ThickWidth then
  1004. Begin
  1005. TmpNumPixels := NumPixels-1;
  1006. { Draw the pixels }
  1007. for i := 0 to TmpNumPixels do
  1008. begin
  1009. { all depending on the slope, we can determine }
  1010. { in what direction the extra width pixels will be put }
  1011. If Flag then
  1012. Begin
  1013. { compare if we should plot a pixel here , compare }
  1014. { with predefined line patterns... }
  1015. if LinePatterns[i and 15] = TRUE then
  1016. begin
  1017. DirectPutPixel(x-1,y);
  1018. DirectPutPixel(x,y);
  1019. DirectPutPixel(x+1,y);
  1020. end;
  1021. end
  1022. else
  1023. Begin
  1024. { compare if we should plot a pixel here , compare }
  1025. { with predefined line patterns... }
  1026. if LinePatterns[i and 15] = TRUE then
  1027. begin
  1028. DirectPutPixel(x,y-1);
  1029. DirectPutPixel(x,y);
  1030. DirectPutPixel(x,y+1);
  1031. end;
  1032. end;
  1033. if d < 0 then
  1034. begin
  1035. d := d + dinc1;
  1036. x := x + xinc1;
  1037. y := y + yinc1;
  1038. end
  1039. else
  1040. begin
  1041. d := d + dinc2;
  1042. x := x + xinc2;
  1043. y := y + yinc2;
  1044. end;
  1045. end;
  1046. end
  1047. else
  1048. Begin
  1049. { instead of putting in loop , substract by one now }
  1050. TmpNumPixels := NumPixels-1;
  1051. { NormWidth }
  1052. for i := 0 to TmpNumPixels do
  1053. begin
  1054. if LinePatterns[i and 15] = TRUE then
  1055. begin
  1056. DirectPutPixel(x,y);
  1057. end;
  1058. if d < 0 then
  1059. begin
  1060. d := d + dinc1;
  1061. x := x + xinc1;
  1062. y := y + yinc1;
  1063. end
  1064. else
  1065. begin
  1066. d := d + dinc2;
  1067. x := x + xinc2;
  1068. y := y + yinc2;
  1069. end;
  1070. end;
  1071. end
  1072. end;
  1073. {******************************************}
  1074. { end patterned lines }
  1075. {******************************************}
  1076. { restore color }
  1077. CurrentColor:=OldCurrentColor;
  1078. end;
  1079. end; { Line }
  1080. {********************************************************}
  1081. { Procedure InternalEllipse() }
  1082. {--------------------------------------------------------}
  1083. { This routine first calculates all points required to }
  1084. { draw a circle to the screen, and stores the points }
  1085. { to display in a buffer before plotting them. The }
  1086. { aspect ratio of the screen is taken into account when }
  1087. { calculating the values. }
  1088. {--------------------------------------------------------}
  1089. { INPUTS: X,Y : Center coordinates of Ellipse. }
  1090. { XRadius - X-Axis radius of ellipse. }
  1091. { YRadius - Y-Axis radius of ellipse. }
  1092. { stAngle, EndAngle: Start angle and end angles of the }
  1093. { ellipse (used for partial ellipses and circles) }
  1094. {--------------------------------------------------------}
  1095. { NOTE: - uses the current write mode. }
  1096. { - Angles must both be between 0 and 360 }
  1097. {********************************************************}
  1098. Procedure InternalEllipseDefault(X,Y: Integer;XRadius: word;
  1099. YRadius:word; stAngle,EndAngle: word);
  1100. var
  1101. i:integer;
  1102. xpt: pinttable;
  1103. ypt: pinttable;
  1104. j,Delta:real;
  1105. NumOfPixels: longint;
  1106. NumOfPix: Array[0..2] of longint;
  1107. count: longint;
  1108. ConvFac,TempTerm: real;
  1109. aval,bval: integer;
  1110. OldcurrentColor: word;
  1111. TmpAngle: word;
  1112. DeltaAngle: word;
  1113. Begin
  1114. { check if valid angles }
  1115. stangle := stAngle mod 361;
  1116. EndAngle := EndAngle mod 361;
  1117. { if impossible angles then swap them! }
  1118. if Endangle < StAngle then
  1119. Begin
  1120. TmpAngle:=EndAngle;
  1121. EndAngle:=StAngle;
  1122. Stangle:=TmpAngle;
  1123. end;
  1124. { calculate difference of angle now so we don't always have to calculate it }
  1125. DeltaAngle:= EndAngle-StAngle;
  1126. i:=0;
  1127. if LineInfo.Thickness=NormWidth then
  1128. Begin
  1129. { approximate the number of pixels required by using the circumference }
  1130. { equation of an ellipse. }
  1131. NumOfPixels:=8*Round(2*sqrt((sqr(XRadius)+sqr(YRadius)) div 2));
  1132. GetMem(xpt,NumOfpixels*sizeof(word));
  1133. GetMem(ypt,NumOfPixels*sizeof(word));
  1134. { Calculate the angle precision required }
  1135. Delta := DeltaAngle / (NumOfPixels);
  1136. { Adjust for screen aspect ratio }
  1137. XRadius:=(longint(XRadius)*10000) div XAspect;
  1138. YRadius:=(longint(YRadius)*10000) div YAspect;
  1139. { Initial counter value }
  1140. j:=Delta+StAngle;
  1141. { removed from inner loop to make faster }
  1142. ConvFac:=Pi/180.0;
  1143. Repeat
  1144. { this used by both sin and cos }
  1145. TempTerm := j*ConvFac;
  1146. { Calculate points }
  1147. xpt^[i]:=round(XRadius*Cos(TempTerm));
  1148. { calculate the value of y }
  1149. ypt^[i]:=round(YRadius*Sin(TempTerm+Pi));
  1150. j:=j+Delta;
  1151. inc(i);
  1152. Until j > DeltaAngle;
  1153. end
  1154. else
  1155. {******************************************}
  1156. { CIRCLE OR ELLIPSE WITH THICKNESS=3 }
  1157. {******************************************}
  1158. Begin
  1159. NumOfPix[1]:=8*Round(2*sqrt((sqr(XRadius)+sqr(YRadius)) div 2));
  1160. NumOfPix[0]:=8*Round(2*sqrt((sqr(XRadius-1)+sqr(YRadius-1)) div 2));
  1161. NumOfPix[2]:=8*Round(2*sqrt((sqr(XRadius+1)+sqr(YRadius+1)) div 2));
  1162. GetMem(xpt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
  1163. GetMem(ypt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
  1164. { removed from inner loop to make faster }
  1165. ConvFac:=Pi/180.0;
  1166. for Count:=0 to 2 do
  1167. Begin
  1168. aval:=XRadius+Count-1;
  1169. bval:=YRadius+Count-1;
  1170. Delta := DeltaAngle / (NumOfPix[Count]);
  1171. aval:= (longint(aval)*10000) div XAspect;
  1172. bval:= (longint(bval)*10000) div YAspect;
  1173. j:=Delta+Stangle;
  1174. Repeat
  1175. { this used by both sin and cos }
  1176. TempTerm := j*ConvFac;
  1177. xpt^[i]:=round((aval)*Cos(TempTerm));
  1178. { calculate the value of y }
  1179. ypt^[i]:=round(bval*Sin(TempTerm+Pi));
  1180. j:=j+Delta;
  1181. inc(i);
  1182. Until j > DeltaAngle;
  1183. end;
  1184. end;
  1185. {******************************************}
  1186. { NOW ALL PIXEL POINTS ARE IN BUFFER }
  1187. { plot them all to the screen }
  1188. {******************************************}
  1189. Count:=0;
  1190. OldcurrentColor:=currentColor;
  1191. Repeat
  1192. PutPixel(xpt^[Count]+X,ypt^[Count]+Y,CurrentColor);
  1193. inc(count);
  1194. until Count>=i;
  1195. { Get End and Start points into the ArcCall information record }
  1196. ArcCall.X := X;
  1197. ArcCall.Y := Y;
  1198. ArcCall.XStart := xpt^[0] + X;
  1199. ArcCall.YStart := ypt^[0] + Y;
  1200. ArcCall.XEnd := xpt^[Count-1] + X;
  1201. ArcCall.YEnd := ypt^[Count-1] + Y;
  1202. CurrentColor:=OldCurrentColor;
  1203. if LineInfo.Thickness=NormWidth then
  1204. Begin
  1205. Freemem(xpt,NumOfPixels*sizeof(word));
  1206. Freemem(ypt,NumOfPixels*sizeof(word));
  1207. end
  1208. else
  1209. Begin
  1210. FreeMem(xpt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
  1211. FreeMem(ypt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
  1212. end;
  1213. end;
  1214. {********************************************************}
  1215. { Procedure InternalEllipse() }
  1216. {--------------------------------------------------------}
  1217. { This routine first calculates all points required to }
  1218. { draw a circle to the screen, and stores the points }
  1219. { to display in a buffer before plotting them. The }
  1220. { aspect ratio of the screen is taken into account when }
  1221. { calculating the values. }
  1222. {--------------------------------------------------------}
  1223. { INPUTS: X,Y : Center coordinates of Ellipse. }
  1224. { XRadius - X-Axis radius of ellipse. }
  1225. { YRadius - Y-Axis radius of ellipse. }
  1226. { stAngle, EndAngle: Start angle and end angles of the }
  1227. { ellipse (used for partial ellipses and circles) }
  1228. {--------------------------------------------------------}
  1229. { NOTE: - uses the current write mode. }
  1230. { - Angles must both be between 0 and 360 }
  1231. {********************************************************}
  1232. (*
  1233. Procedure InternalEllipseDefault (x, y : integer;
  1234. xradius, yradius, stAngle, EndAngle : Word);
  1235. { Draw an ellipse arc. Crude but it works (anyone have a better one?) }
  1236. Var
  1237. aSqr, bSqr, twoaSqr, twobSqr, xa, ya, twoXbSqr, twoYaSqr, error : LongInt;
  1238. Alpha : Real;
  1239. const
  1240. RadToDeg = 180/Pi;
  1241. Procedure PlotPoints;
  1242. var
  1243. i,j: integer;
  1244. xm, ym: integer;
  1245. xp, yp: integer;
  1246. Begin
  1247. ym := y-ya;
  1248. yp := y+ya;
  1249. xm := x-xa;
  1250. xp := x+xa;
  1251. if LineInfo.Thickness = Normwidth then
  1252. Begin
  1253. If (Alpha>=StAngle) And (Alpha<=EndAngle) then
  1254. PutPixel (xm,ym, CurrentColor);
  1255. If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then
  1256. PutPixel (xm,yp, CurrentColor);
  1257. If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then
  1258. PutPixel (xp,yp, CurrentColor);
  1259. If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then
  1260. PutPixel (xp,ym, CurrentColor);
  1261. end
  1262. else
  1263. Begin
  1264. If (Alpha>=StAngle) And (Alpha<=EndAngle) then
  1265. for i:=-1 to 1 do
  1266. for j:=-1 to 1 do
  1267. PutPixel (xm+i,ym+j, CurrentColor);
  1268. If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then
  1269. for i:=-1 to 1 do
  1270. for j:=-1 to 1 do
  1271. PutPixel (xm+i,yp+j, CurrentColor);
  1272. If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then
  1273. for i:=-1 to 1 do
  1274. for j:=-1 to 1 do
  1275. PutPixel (xp+i,yp+j, CurrentColor);
  1276. If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then
  1277. for i:=-1 to 1 do
  1278. for j:=-1 to 1 do
  1279. PutPixel (xp+i,ym+j, CurrentColor);
  1280. end;
  1281. End;
  1282. Begin
  1283. StAngle:=StAngle MOD 361;
  1284. EndAngle:=EndAngle MOD 361;
  1285. StAngle := StAngle + 270;
  1286. EndAngle := EndAngle + 270;
  1287. If StAngle>EndAngle then
  1288. Begin
  1289. StAngle:=StAngle Xor EndAngle; EndAngle:=EndAngle Xor StAngle; StAngle:=EndAngle Xor StAngle;
  1290. End;
  1291. { Adjust for screen aspect ratio }
  1292. XRadius:=(longint(XRadius)*10000) div XAspect;
  1293. YRadius:=(longint(YRadius)*10000) div YAspect;
  1294. aSqr:=LongInt (xradius)*LongInt (xradius);
  1295. bSqr:=LongInt (yradius)*LongInt (yradius);
  1296. twoaSqr:=2*aSqr;
  1297. twobSqr:=2*bSqr;
  1298. xa:=0;
  1299. ya:=yradius;
  1300. twoXbSqr:=0;
  1301. twoYaSqr:=ya*twoaSqr;
  1302. error:=-ya*aSqr;
  1303. While twoXbSqr<=twoYaSqr Do Begin
  1304. If ya=0 then Alpha:=90 Else Alpha:=RadToDeg*Arctan (xa/ya); { Crude but it works }
  1305. PlotPoints;
  1306. Inc (xa);
  1307. Inc (twoXbSqr,twobSqr);
  1308. Inc (error,twoXbSqr-bSqr);
  1309. If error>=0 then Begin
  1310. Dec (ya);
  1311. Dec (twoYaSqr,twoaSqr);
  1312. Dec (error,twoYaSqr);
  1313. End;
  1314. End;
  1315. xa:=xradius;
  1316. ya:=0;
  1317. twoXbSqr:=xa*twobSqr;
  1318. twoYaSqr:=0;
  1319. error:=-xa*bSqr;
  1320. While twoXbSqr>twoYaSqr Do Begin
  1321. If ya=0 then Alpha:=90 Else Alpha:=RadToDeg*Arctan (xa/ya);
  1322. PlotPoints;
  1323. Inc (ya);
  1324. Inc (twoYaSqr,twoaSqr);
  1325. Inc (error,twoYaSqr-aSqr);
  1326. If error>=0 then Begin
  1327. Dec (xa);
  1328. Dec (twoXbSqr,twobSqr);
  1329. Dec (error,twoXbSqr);
  1330. End;
  1331. End;
  1332. End;
  1333. *)
  1334. procedure PatternLineDefault(x1,x2,y: integer);
  1335. {********************************************************}
  1336. { Draws a horizontal patterned line according to the }
  1337. { current Fill Settings. }
  1338. {********************************************************}
  1339. { Important notes: }
  1340. { - CurrentColor must be set correctly before entering }
  1341. { this routine. }
  1342. {********************************************************}
  1343. var
  1344. NrIterations: Integer;
  1345. i : Integer;
  1346. j : Integer;
  1347. TmpFillPattern : byte;
  1348. OldWriteMode : word;
  1349. OldCurrentColor : word;
  1350. begin
  1351. { convert to global coordinates ... }
  1352. x1 := x1 + StartXViewPort;
  1353. x2 := x2 + StartXViewPort;
  1354. y := y + StartYViewPort;
  1355. { if line was fully clipped then exit...}
  1356. if LineClipped(x1,y,x2,y,StartXViewPort,StartYViewPort,
  1357. StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
  1358. exit;
  1359. OldWriteMode := CurrentWriteMode;
  1360. CurrentWriteMode := NormalPut;
  1361. { number of times to go throuh the 8x8 pattern }
  1362. NrIterations := abs(x2 - x1) div 8;
  1363. Inc(NrIterations);
  1364. { Get the current pattern }
  1365. TmpFillPattern := FillPatternTable
  1366. { [FillSettings.Pattern][(((y+viewport.x1) and $7)+1];}
  1367. [FillSettings.Pattern][(y and $7)+1];
  1368. if FillSettings.Pattern = EmptyFill then
  1369. begin
  1370. OldCurrentColor := CurrentColor;
  1371. CurrentColor := CurrentBkColor;
  1372. HLine(x1,x2,y);
  1373. CurrentColor := OldCurrentColor;
  1374. end
  1375. else
  1376. if FillSettings.Pattern = SolidFill then
  1377. begin
  1378. HLine(x1,x2,y);
  1379. end
  1380. else
  1381. begin
  1382. For i:= 0 to NrIterations do
  1383. Begin
  1384. for j:=0 to 7 do
  1385. Begin
  1386. { x1 mod 8 }
  1387. if RevBitArray[x1 and 7] and TmpFillPattern <> 0 then
  1388. DirectPutpixel(x1,y)
  1389. else
  1390. begin
  1391. { According to the TP graph manual, we overwrite everything }
  1392. { which is filled up - checked against VGA and CGA drivers }
  1393. { of TP. }
  1394. OldCurrentColor := CurrentColor;
  1395. CurrentColor := CurrentBkColor;
  1396. DirectPutPixel(x1,y);
  1397. CurrentColor := OldCurrentColor;
  1398. end;
  1399. Inc(x1);
  1400. if x1 > x2 then
  1401. begin
  1402. CurrentWriteMode := OldWriteMode;
  1403. exit;
  1404. end;
  1405. end;
  1406. end;
  1407. end;
  1408. CurrentWriteMode := OldWriteMode;
  1409. end;
  1410. procedure LineRel(Dx, Dy: Integer);
  1411. Begin
  1412. Line(CurrentX, CurrentY, CurrentX + Dx, CurrentY + Dy);
  1413. CurrentX := CurrentX + Dx;
  1414. CurrentY := CurrentY + Dy;
  1415. end;
  1416. procedure LineTo(x,y : Integer);
  1417. Begin
  1418. Line(CurrentX, CurrentY, X, Y);
  1419. CurrentX := X;
  1420. CurrentY := Y;
  1421. end;
  1422. procedure Rectangle(x1,y1,x2,y2:integer);
  1423. begin
  1424. { Do not draw the end points }
  1425. Line(x1,y1,x2-1,y1);
  1426. Line(x1,y1+1,x1,y2);
  1427. Line(x2,y1,x2,y2-1);
  1428. Line(x1+1,y2,x2,y2);
  1429. end;
  1430. procedure GetLineSettings(var ActiveLineInfo : LineSettingsType);
  1431. begin
  1432. Activelineinfo:=Lineinfo;
  1433. end;
  1434. procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word);
  1435. var
  1436. i: byte;
  1437. j: byte;
  1438. Begin
  1439. if (LineStyle > UserBitLn) or ((Thickness <> Normwidth) and (Thickness <> ThickWidth)) then
  1440. _GraphResult := grError
  1441. else
  1442. begin
  1443. LineInfo.Thickness := Thickness;
  1444. LineInfo.LineStyle := LineStyle;
  1445. case LineStyle of
  1446. UserBitLn: Lineinfo.Pattern := pattern;
  1447. SolidLn: Lineinfo.Pattern := $ffff; { ------- }
  1448. DashedLn : Lineinfo.Pattern := $F8F8; { -- -- --}
  1449. DottedLn: LineInfo.Pattern := $CCCC; { - - - - }
  1450. CenterLn: LineInfo.Pattern := $FC78; { -- - -- }
  1451. end; { end case }
  1452. { setup pattern styles }
  1453. j:=15;
  1454. for i:=0 to 15 do
  1455. Begin
  1456. { bitwise mask for each bit in the word }
  1457. if (word($01 shl i) AND LineInfo.Pattern) <> 0 then
  1458. LinePatterns[j]:=TRUE
  1459. else
  1460. LinePatterns[j]:=FALSE;
  1461. Dec(j);
  1462. end;
  1463. end;
  1464. end;
  1465. {--------------------------------------------------------------------------}
  1466. { }
  1467. { VIEWPORT RELATED ROUTINES }
  1468. { }
  1469. {--------------------------------------------------------------------------}
  1470. Procedure ClearViewPortDefault;
  1471. var
  1472. j: integer;
  1473. OldWriteMode, OldCurColor: word;
  1474. LineSets : LineSettingsType;
  1475. Begin
  1476. { CP is always RELATIVE coordinates }
  1477. CurrentX := 0;
  1478. CurrentY := 0;
  1479. { Save all old settings }
  1480. OldCurColor := CurrentColor;
  1481. CurrentColor:=CurrentBkColor;
  1482. OldWriteMode:=CurrentWriteMode;
  1483. GetLineSettings(LineSets);
  1484. { reset to normal line style...}
  1485. SetLineStyle(SolidLn, 0, NormWidth);
  1486. { routines are relative here...}
  1487. for J:=0 to ViewHeight do
  1488. HLine(0, ViewWidth, J);
  1489. { restore old settings...}
  1490. SetLineStyle(LineSets.LineStyle, LineSets.Pattern, LineSets.Thickness);
  1491. CurrentColor := OldCurColor;
  1492. CurrentWriteMode := OldWriteMode;
  1493. end;
  1494. Procedure SetViewPort(X1, Y1, X2, Y2: Integer; Clip: Boolean);
  1495. Begin
  1496. if (X1 > GetMaxX) or (X2 > GetMaxX) or (X1 > X2) or (X1 < 0) then
  1497. Begin
  1498. _GraphResult := grError;
  1499. exit;
  1500. end;
  1501. if (Y1 > GetMaxY) or (Y2 > GetMaxY) or (Y1 > Y2) or (Y1 < 0) then
  1502. Begin
  1503. _GraphResult := grError;
  1504. exit;
  1505. end;
  1506. { CP is always RELATIVE coordinates }
  1507. CurrentX := 0;
  1508. CurrentY := 0;
  1509. StartXViewPort := X1;
  1510. StartYViewPort := Y1;
  1511. ViewWidth := X2-X1;
  1512. ViewHeight:= Y2-Y1;
  1513. ClipPixels := Clip;
  1514. end;
  1515. procedure GetViewSettings(var viewport : ViewPortType);
  1516. begin
  1517. ViewPort.X1 := StartXViewPort;
  1518. ViewPort.Y1 := StartYViewPort;
  1519. ViewPort.X2 := ViewWidth + StartXViewPort;
  1520. ViewPort.Y2 := ViewHeight + StartYViewPort;
  1521. ViewPort.Clip := ClipPixels;
  1522. end;
  1523. procedure ClearDevice;
  1524. var
  1525. ViewPort: ViewPortType;
  1526. begin
  1527. { Reset the CP }
  1528. CurrentX := 0;
  1529. CurrentY := 0;
  1530. { save viewport }
  1531. ViewPort.X1 := StartXviewPort;
  1532. ViewPort.X2 := ViewWidth - StartXViewPort;
  1533. ViewPort.Y1 := StartYViewPort;
  1534. ViewPort.Y2 := ViewHeight - StartYViewPort;
  1535. ViewPort.Clip := ClipPixels;
  1536. { put viewport to full screen }
  1537. StartXViewPort := 0;
  1538. ViewHeight := MaxY;
  1539. StartYViewPort := 0;
  1540. ViewWidth := MaxX;
  1541. ClipPixels := TRUE;
  1542. ClearViewPort;
  1543. { restore old viewport }
  1544. StartXViewPort := ViewPort.X1;
  1545. ViewWidth := ViewPort.X2-ViewPort.X1;
  1546. StartYViewPort := ViewPort.Y1;
  1547. ViewHeight := ViewPort.Y2-ViewPort.Y1;
  1548. ClipPixels := ViewPort.Clip;
  1549. end;
  1550. {--------------------------------------------------------------------------}
  1551. { }
  1552. { BITMAP PUT/GET ROUTINES }
  1553. { }
  1554. {--------------------------------------------------------------------------}
  1555. Procedure GetScanlineDefault (Y : Integer; Var Data);
  1556. {********************************************************}
  1557. { Procedure GetScanLine() }
  1558. {--------------------------------------------------------}
  1559. { Returns the full scanline of the video line of the Y }
  1560. { coordinate. The values are returned in a WORD array }
  1561. { each WORD representing a pixel of the specified scanline}
  1562. {********************************************************}
  1563. Var
  1564. Offset, x : Integer;
  1565. Begin
  1566. For x:=0 to MaxX Do Begin
  1567. WordArray(Data)[x]:=GetPixel(x, y);
  1568. End;
  1569. End;
  1570. Function DefaultImageSize(X1,Y1,X2,Y2: Integer): longint;
  1571. Begin
  1572. { each pixel uses two bytes, to enable modes with colors up to 64K }
  1573. { to work. }
  1574. DefaultImageSize := 12 + (((X2-X1)*(Y2-Y1))*2);
  1575. end;
  1576. Procedure DefaultPutImage(X,Y: Integer; var Bitmap; BitBlt: Word);
  1577. type
  1578. pt = array[0..32000] of word;
  1579. ptw = array[0..3] of longint;
  1580. var
  1581. color: word;
  1582. i,j: Integer;
  1583. Y1,X1: Integer;
  1584. k: integer;
  1585. Begin
  1586. X1:= ptw(Bitmap)[0]+X; { get width and adjust end coordinate accordingly }
  1587. Y1:= ptw(Bitmap)[1]+Y; { get height and adjust end coordinate accordingly }
  1588. k:= 12; { Three reserved longs at start of bitmap }
  1589. for j:=Y to Y1 do
  1590. Begin
  1591. for i:=X to X1 do
  1592. begin
  1593. case BitBlt of
  1594. {$R-}
  1595. CopyPut: color:= pt(Bitmap)[k]; { also = normalput }
  1596. XORPut: color:= pt(Bitmap)[k] XOR GetPixel(i,j);
  1597. OrPut: color:= pt(Bitmap)[k] OR GetPixel(i,j);
  1598. AndPut: color:= pt(Bitmap)[k] AND GetPixel(i,j);
  1599. NotPut: color:= not pt(Bitmap)[k];
  1600. {$R+}
  1601. end;
  1602. putpixel(i,j,color);
  1603. Inc(k);
  1604. end;
  1605. end;
  1606. end;
  1607. Procedure DefaultGetImage(X1,Y1,X2,Y2: Integer; Var Bitmap);
  1608. type
  1609. pt = array[0..32000] of word;
  1610. ptw = array[0..3] of longint;
  1611. var
  1612. i,j: integer;
  1613. k: longint;
  1614. Begin
  1615. k:= 12; { Three reserved longs at start of bitmap }
  1616. for j:=Y1 to Y2 do
  1617. Begin
  1618. for i:=X1 to X2 do
  1619. begin
  1620. {$R-}
  1621. pt(Bitmap)[k] :=getpixel(i,j);
  1622. {$R+}
  1623. Inc(k);
  1624. end;
  1625. end;
  1626. ptw(Bitmap)[0] := X2-X1; { First longint is width }
  1627. ptw(Bitmap)[1] := Y2-Y1; { Second longint is height }
  1628. ptw(bitmap)[2] := 0; { Third longint is reserved}
  1629. end;
  1630. Procedure GetArcCoords(var ArcCoords: ArcCoordsType);
  1631. Begin
  1632. ArcCoords.X := ArcCall.X;
  1633. ArcCoords.Y := ArcCall.Y;
  1634. ArcCoords.XStart := ArcCall.XStart;
  1635. ArcCoords.YStart := ArcCall.YStart;
  1636. ArcCoords.XEnd := ArcCall.XEnd;
  1637. ArcCoords.YEnd := ArcCall.YEnd;
  1638. end;
  1639. procedure SetVisualPageDefault(page : word);
  1640. begin
  1641. end;
  1642. procedure SetActivePageDefault(page : word);
  1643. begin
  1644. end;
  1645. Procedure DefaultHooks;
  1646. {********************************************************}
  1647. { Procedure DefaultHooks() }
  1648. {--------------------------------------------------------}
  1649. { Resets all hookable routine either to nil for those }
  1650. { which need overrides, and others to defaults. }
  1651. { This is called each time SetGraphMode() is called. }
  1652. {********************************************************}
  1653. Begin
  1654. { All default hooks procedures }
  1655. { required...}
  1656. DirectPutPixel := nil;
  1657. PutPixel := nil;
  1658. GetPixel := nil;
  1659. SetRGBPalette := nil;
  1660. GetRGBPalette := nil;
  1661. { optional...}
  1662. SetActivePage := SetActivePageDefault;
  1663. SetVisualPage := SetVisualPageDefault;
  1664. ClearViewPort := ClearViewportDefault;
  1665. PutImage := DefaultPutImage;
  1666. GetImage := DefaultGetImage;
  1667. ImageSize := DefaultImageSize;
  1668. GraphFreeMemPtr := nil;
  1669. GraphGetMemPtr := nil;
  1670. GetScanLine := GetScanLineDefault;
  1671. Line := LineDefault;
  1672. InternalEllipse := InternalEllipseDefault;
  1673. PatternLine := PatternLineDefault;
  1674. HLine := HLineDefault;
  1675. VLine := VLineDefault;
  1676. end;
  1677. Procedure InitVars;
  1678. {********************************************************}
  1679. { Procedure InitVars() }
  1680. {--------------------------------------------------------}
  1681. { Resets all internal variables, and resets all }
  1682. { overridable routines. }
  1683. {********************************************************}
  1684. Begin
  1685. DirectVideo := TRUE; { By default use fastest access possible }
  1686. ArcCall.X := 0;
  1687. ArcCall.Y := 0;
  1688. ArcCall.XStart := 0;
  1689. ArcCall.YStart := 0;
  1690. ArcCall.XEnd := 0;
  1691. ArcCall.YEnd := 0;
  1692. { Reset to default values }
  1693. IntCurrentMode := 0;
  1694. IntCurrentDriver := 0;
  1695. XAspect := 0;
  1696. YAspect := 0;
  1697. MaxX := 0;
  1698. MaxY := 0;
  1699. MaxColor := 0;
  1700. PaletteSize := 0;
  1701. DirectColor := FALSE;
  1702. DefaultHooks;
  1703. end;
  1704. {$i modes.inc}
  1705. {$i graph.inc}
  1706. function InstallUserDriver(Name: string; AutoDetectPtr: Pointer): integer;
  1707. begin
  1708. _graphResult := grError;
  1709. end;
  1710. function RegisterBGIDriver(driver: pointer): integer;
  1711. begin
  1712. _graphResult := grError;
  1713. end;
  1714. { ----------------------------------------------------------------- }
  1715. Procedure Arc(X,Y : Integer; StAngle,EndAngle,Radius: word);
  1716. var
  1717. OldWriteMode: word;
  1718. Begin
  1719. if (Radius = 0) then
  1720. Exit;
  1721. if (Radius = 1) then
  1722. begin
  1723. { must use clipping ... }
  1724. { don't need to explicitly set NormalPut mode }
  1725. { because PutPixel only supports normal put }
  1726. PutPixel(X, Y,CurrentColor);
  1727. Exit;
  1728. end;
  1729. { Only if we are using thickwidths lines do we accept }
  1730. { XORput write modes. }
  1731. OldWriteMode := CurrentWriteMode;
  1732. if (LineInfo.Thickness = NormWidth) then
  1733. CurrentWriteMode := NormalPut;
  1734. InternalEllipse(X,Y,Radius,Radius,StAngle,Endangle);
  1735. CurrentWriteMode := OldWriteMode;
  1736. end;
  1737. procedure Ellipse(X,Y : Integer; stAngle, EndAngle: word; XRadius,YRadius: word);
  1738. Begin
  1739. InternalEllipse(X,Y,XRadius,YRadius,stAngle,EndAngle);
  1740. end;
  1741. procedure FillEllipse(X, Y: Integer; XRadius, YRadius: Word);
  1742. {********************************************************}
  1743. { Procedure FillEllipse() }
  1744. {--------------------------------------------------------}
  1745. { Draws a filled ellipse using (X,Y) as a center point }
  1746. { and XRadius and YRadius as the horizontal and vertical }
  1747. { axes. The ellipse is filled with the current fill color}
  1748. { and fill style, and is bordered with the current color.}
  1749. {--------------------------------------------------------}
  1750. { Important notes: }
  1751. { - CONTRRARY to VGA BGI - SetWriteMode DOES not }
  1752. { affect the contour of the ellipses. BGI mode }
  1753. { supports XORPut but the FloodFill() is still bounded}
  1754. { by the ellipse. In OUR case, XOR Mode is simply }
  1755. { not supported. }
  1756. {********************************************************}
  1757. var
  1758. OldWriteMode: Word;
  1759. begin
  1760. { only normal put supported }
  1761. OldWriteMode := CurrentWriteMode;
  1762. CurrentWriteMode := NormalPut;
  1763. InternalEllipse(X,Y,XRadius,YRadius,0,360);
  1764. FloodFill(X,Y,CurrentColor);
  1765. { restore old write mode }
  1766. CurrentWriteMode := OldWriteMode;
  1767. end;
  1768. procedure Circle(X, Y: Integer; Radius:Word);
  1769. {********************************************************}
  1770. { Draws a circle centered at X,Y with the given Radius. }
  1771. {********************************************************}
  1772. { Important notes: }
  1773. { - Thickwidth circles use the current write mode, while}
  1774. { normal width circles ALWAYS use CopyPut/NormalPut }
  1775. { mode. (Tested against VGA BGI driver -CEC 13/Aug/99 }
  1776. {********************************************************}
  1777. var OriginalArcInfo: ArcCoordsType;
  1778. OldWriteMode: word;
  1779. begin
  1780. if (Radius = 0) then
  1781. Exit;
  1782. if (Radius = 1) then
  1783. begin
  1784. { only normal put mode is supported by a call to PutPixel }
  1785. PutPixel(X, Y, CurrentColor);
  1786. Exit;
  1787. end;
  1788. { save state of arc information }
  1789. { because it is not needed for }
  1790. { a circle call. }
  1791. move(ArcCall,OriginalArcInfo, sizeof(ArcCall));
  1792. if LineInfo.Thickness = Normwidth then
  1793. begin
  1794. OldWriteMode := CurrentWriteMode;
  1795. CurrentWriteMode := CopyPut;
  1796. end;
  1797. InternalEllipse(X,Y,Radius,Radius,0,360);
  1798. if LineInfo.Thickness = Normwidth then
  1799. CurrentWriteMode := OldWriteMode;
  1800. { restore arc information }
  1801. move(OriginalArcInfo, ArcCall,sizeof(ArcCall));
  1802. end;
  1803. procedure Sector(x, y: Integer; StAngle,EndAngle, XRadius, YRadius: Word);
  1804. var angle : real;
  1805. writemode : word;
  1806. begin
  1807. Ellipse(x,y,stAngle,endAngle,XRadius,YRadius);
  1808. { As in the TP graph unit - the line settings are used to }
  1809. { define the outline of the sector. }
  1810. writemode:=Currentwritemode;
  1811. Currentwritemode:=normalput;
  1812. Line(ArcCall.XStart, ArcCall.YStart, x,y);
  1813. Line(x,y,ArcCall.Xend,ArcCall.YEnd);
  1814. { we must take care of clipping so we call PutPixel instead }
  1815. { of DirectPutPixel... }
  1816. PutPixel(ArcCall.xstart,ArcCall.ystart,CurrentColor);
  1817. PutPixel(x,y,CurrentColor);
  1818. PutPixel(ArcCall.xend,ArcCall.yend,CurrentColor);
  1819. stangle:=Stangle mod 360; EndAngle:=Endangle mod 360;
  1820. if stAngle<=Endangle then
  1821. Angle:=(stAngle+EndAngle)/2
  1822. else
  1823. angle:=(stAngle-360+EndAngle)/2;
  1824. { fill from the point in the middle of the slice }
  1825. XRadius:=(longint(XRadius)*10000) div XAspect;
  1826. YRadius:=(longint(YRadius)*10000) div YAspect;
  1827. { avoid rounding errors }
  1828. if abs(ArcCall.xstart-ArcCall.xend)
  1829. +abs(ArcCall.ystart-ArcCall.yend)>2 then
  1830. FloodFill(x+round(sin((angle+90)*Pi/180)*XRadius/2),
  1831. y+round(cos((angle+90)*Pi/180)*YRadius/2),CurrentColor);
  1832. CurrentWriteMode := writemode;
  1833. end;
  1834. procedure SetFillStyle(Pattern : word; Color: word);
  1835. begin
  1836. { on invalid input, the current fill setting will be }
  1837. { unchanged. }
  1838. if (Pattern > UserFill) or (Color > GetMaxColor) then
  1839. begin
  1840. _GraphResult := grError;
  1841. exit;
  1842. end;
  1843. FillSettings.Color := Color;
  1844. FillSettings.Pattern := Pattern;
  1845. end;
  1846. procedure SetFillPattern(Pattern: FillPatternType; Color: word);
  1847. {********************************************************}
  1848. { Changes the Current FillPattern to a user defined }
  1849. { pattern and changes also the current fill color. }
  1850. { The FillPattern is saved in the FillPattern array so }
  1851. { it can still be used with SetFillStyle(UserFill,Color) }
  1852. {********************************************************}
  1853. var
  1854. i: integer;
  1855. begin
  1856. if Color > GetMaxColor then
  1857. begin
  1858. _GraphResult := grError;
  1859. exit;
  1860. end;
  1861. FillSettings.Color := Color;
  1862. FillSettings.Pattern := UserFill;
  1863. { Save the pattern in the buffer }
  1864. For i:=1 to 8 do
  1865. FillPatternTable[UserFill][i] := Pattern[i];
  1866. end;
  1867. procedure Bar(x1,y1,x2,y2:integer);
  1868. {********************************************************}
  1869. { Important notes for compatibility with BP: }
  1870. { - WriteMode is always CopyPut }
  1871. { - No contour is drawn for the lines }
  1872. {********************************************************}
  1873. var y : Integer;
  1874. origcolor : longint;
  1875. origlinesettings: Linesettingstype;
  1876. origwritemode : Integer;
  1877. begin
  1878. origlinesettings:=lineinfo;
  1879. origcolor:=CurrentColor;
  1880. { Always copy mode for Bars }
  1881. origwritemode := CurrentWriteMode;
  1882. CurrentWriteMode := CopyPut;
  1883. { All lines used are of this style }
  1884. Lineinfo.linestyle:=solidln;
  1885. Lineinfo.thickness:=normwidth;
  1886. case Fillsettings.pattern of
  1887. EmptyFill :
  1888. begin
  1889. Currentcolor:=CurrentBkColor;
  1890. for y:=y1 to y2 do
  1891. Hline(x1,x2,y);
  1892. end;
  1893. SolidFill :
  1894. begin
  1895. CurrentColor:=FillSettings.color;
  1896. for y:=y1 to y2 do
  1897. Hline(x1,x2,y);
  1898. end;
  1899. else
  1900. Begin
  1901. CurrentColor:=FillSettings.color;
  1902. for y:=y1 to y2 do
  1903. patternline(x1,x2,y);
  1904. end;
  1905. end;
  1906. CurrentColor:= Origcolor;
  1907. LineInfo := OrigLineSettings;
  1908. CurrentWriteMode := OrigWritemode;
  1909. end;
  1910. procedure bar3D(x1, y1, x2, y2 : integer;depth : word;top : boolean);
  1911. var
  1912. origwritemode : integer;
  1913. OldX, OldY : integer;
  1914. begin
  1915. origwritemode := CurrentWriteMode;
  1916. CurrentWriteMode := CopyPut;
  1917. Bar(x1,y1,x2,y2);
  1918. Rectangle(x1,y1,x2,y2);
  1919. { Current CP should not be updated in Bar3D }
  1920. { therefore save it and then restore it on }
  1921. { exit. }
  1922. OldX := CurrentX;
  1923. OldY := CurrentY;
  1924. if top then begin
  1925. Moveto(x1,y1);
  1926. Lineto(x1+depth,y1-depth);
  1927. Lineto(x2+depth,y1-depth);
  1928. Lineto(x2,y1);
  1929. end;
  1930. if Depth <> 0 then
  1931. Begin
  1932. Moveto(x2+depth,y1-depth);
  1933. Lineto(x2+depth,y2-depth);
  1934. Lineto(x2,y2);
  1935. end;
  1936. { restore CP }
  1937. CurrentX := OldX;
  1938. CurrentY := OldY;
  1939. CurrentWriteMode := origwritemode;
  1940. end;
  1941. {--------------------------------------------------------------------------}
  1942. { }
  1943. { COLOR AND PALETTE ROUTINES }
  1944. { }
  1945. {--------------------------------------------------------------------------}
  1946. {$i palette.inc}
  1947. procedure SetColor(Color: Word);
  1948. Begin
  1949. CurrentColor := Color;
  1950. end;
  1951. function GetColor: Word;
  1952. Begin
  1953. GetColor := CurrentColor;
  1954. end;
  1955. function GetBkColor: Word;
  1956. Begin
  1957. GetBkColor := CurrentBkColor;
  1958. end;
  1959. procedure SetBkColor(ColorNum: Word);
  1960. { Background color means background screen color in this case, and it is }
  1961. { INDEPENDANT of the viewport settings, so we must clear the whole screen }
  1962. { with the color. }
  1963. var
  1964. ViewPort: ViewportType;
  1965. Begin
  1966. GetViewSettings(Viewport);
  1967. SetViewPort(0,0,MaxX,MaxY,FALSE);
  1968. CurrentBkColor := ColorNum;
  1969. ClearViewPort;
  1970. SetViewport(ViewPort.X1,Viewport.Y1,Viewport.X2,Viewport.Y2,Viewport.Clip);
  1971. end;
  1972. function GetMaxColor: word;
  1973. { Checked against TP VGA driver - CEC }
  1974. begin
  1975. GetMaxColor:=MaxColor-1; { based on an index of zero so subtract one }
  1976. end;
  1977. Procedure MoveRel(Dx, Dy: Integer);
  1978. Begin
  1979. CurrentX := CurrentX + Dx;
  1980. CurrentY := CurrentY + Dy;
  1981. end;
  1982. Procedure MoveTo(X,Y: Integer);
  1983. {********************************************************}
  1984. { Procedure MoveTo() }
  1985. {--------------------------------------------------------}
  1986. { Moves the current pointer in VIEWPORT relative }
  1987. { coordinates to the specified X,Y coordinate. }
  1988. {********************************************************}
  1989. Begin
  1990. CurrentX := X;
  1991. CurrentY := Y;
  1992. end;
  1993. function GraphErrorMsg(ErrorCode: Integer): string;
  1994. Begin
  1995. GraphErrorMsg:='';
  1996. case ErrorCode of
  1997. grOk,grFileNotFound,grInvalidDriver: exit;
  1998. grNoInitGraph: GraphErrorMsg:='Graphics driver not installed';
  1999. grNotDetected: GraphErrorMsg:='Graphics hardware not detected';
  2000. grNoLoadMem,grNoScanMem,grNoFloodMem: GraphErrorMsg := 'Not enough memory for graphics';
  2001. grNoFontMem: GraphErrorMsg := 'Not enough memory to load font';
  2002. grFontNotFound: GraphErrorMsg:= 'Font file not found';
  2003. grInvalidMode: GraphErrorMsg := 'Invalid graphics mode';
  2004. grError: GraphErrorMsg:='Graphics error';
  2005. grIoError: GraphErrorMsg:='Graphics I/O error';
  2006. grInvalidFont,grInvalidFontNum: GraphErrorMsg := 'Invalid font';
  2007. grInvalidVersion: GraphErrorMsg:='Invalid driver version';
  2008. end;
  2009. end;
  2010. Function GetMaxX: Integer;
  2011. { Routine checked against VGA driver - CEC }
  2012. Begin
  2013. GetMaxX := MaxX;
  2014. end;
  2015. Function GetMaxY: Integer;
  2016. { Routine checked against VGA driver - CEC }
  2017. Begin
  2018. GetMaxY := MaxY;
  2019. end;
  2020. Function GraphResult: Integer;
  2021. Begin
  2022. GraphResult := _GraphResult;
  2023. _GraphResult := grOk;
  2024. end;
  2025. Function GetX: Integer;
  2026. Begin
  2027. GetX := CurrentX;
  2028. end;
  2029. Function GetY: Integer;
  2030. Begin
  2031. GetY := CurrentY;
  2032. end;
  2033. Function GetDriverName: string;
  2034. var
  2035. mode: PModeInfo;
  2036. begin
  2037. GetDriverName:=DriverName;
  2038. end;
  2039. procedure graphdefaults;
  2040. { PS: GraphDefaults does not ZERO the ArcCall structure }
  2041. { so a call to GetArcCoords will not change even the }
  2042. { returned values even if GraphDefaults is called in }
  2043. { between. }
  2044. var
  2045. i: integer;
  2046. begin
  2047. lineinfo.linestyle:=solidln;
  2048. lineinfo.thickness:=normwidth;
  2049. { reset line style pattern }
  2050. for i:=0 to 15 do
  2051. LinePatterns[i] := TRUE;
  2052. { By default, according to the TP prog's reference }
  2053. { the default pattern is solid, and the default }
  2054. { color is the maximum color in the palette. }
  2055. fillsettings.color:=GetMaxColor;
  2056. fillsettings.pattern:=solidfill;
  2057. { GraphDefaults resets the User Fill pattern to $ff }
  2058. { checked with VGA BGI driver - CEC }
  2059. for i:=1 to 8 do
  2060. FillPatternTable[UserFill][i] := $ff;
  2061. CurrentColor:=white;
  2062. SetBkColor(Black);
  2063. ClipPixels := TRUE;
  2064. { Reset the viewport }
  2065. StartXViewPort := 0;
  2066. StartYViewPort := 0;
  2067. ViewWidth := MaxX;
  2068. ViewHeight := MaxY;
  2069. { Reset CP }
  2070. CurrentX := 0;
  2071. CurrentY := 0;
  2072. { normal write mode }
  2073. CurrentWriteMode := CopyPut;
  2074. { Schriftart einstellen }
  2075. CurrentTextInfo.font := DefaultFont;
  2076. CurrentTextInfo.direction:=HorizDir;
  2077. CurrentTextInfo.charsize:=1;
  2078. CurrentTextInfo.horiz:=LeftText;
  2079. CurrentTextInfo.vert:=TopText;
  2080. XAspect:=10000; YAspect:=10000;
  2081. end;
  2082. procedure GetAspectRatio(var Xasp,Yasp : word);
  2083. begin
  2084. XAsp:=XAspect;
  2085. YAsp:=YAspect;
  2086. end;
  2087. procedure SetAspectRatio(Xasp, Yasp : word);
  2088. begin
  2089. Xaspect:= XAsp;
  2090. YAspect:= YAsp;
  2091. end;
  2092. procedure SetWriteMode(WriteMode : integer);
  2093. begin
  2094. if (writemode<>xorput) and (writemode<>CopyPut) then
  2095. exit;
  2096. CurrentWriteMode := WriteMode;
  2097. end;
  2098. procedure GetFillSettings(var Fillinfo:Fillsettingstype);
  2099. begin
  2100. Fillinfo:=Fillsettings;
  2101. end;
  2102. procedure GetFillPattern(var FillPattern:FillPatternType);
  2103. begin
  2104. FillPattern:=FillpatternTable[UserFill];
  2105. end;
  2106. procedure DrawPoly(numpoints : word;var polypoints);
  2107. type
  2108. ppointtype = ^pointtype;
  2109. pt = array[0..16000] of pointtype;
  2110. var
  2111. i : longint;
  2112. begin
  2113. if numpoints < 2 then
  2114. begin
  2115. _GraphResult := grError;
  2116. exit;
  2117. end;
  2118. for i:=0 to numpoints-2 do
  2119. line(pt(polypoints)[i].x,
  2120. pt(polypoints)[i].y,
  2121. pt(polypoints)[i+1].x,
  2122. pt(polypoints)[i+1].y);
  2123. end;
  2124. procedure PieSlice(X,Y,stangle,endAngle:integer;Radius: Word);
  2125. var angle : real;
  2126. XRadius, YRadius : word;
  2127. writemode : word;
  2128. begin
  2129. Arc(x,y,StAngle,EndAngle,Radius);
  2130. Line(ArcCall.XStart, ArcCall.YStart, x,y);
  2131. Line(x,y, ArcCall.XEnd, ArcCall.YEnd);
  2132. { must use PutPixel() instead of DirectPutPixel because we need }
  2133. { clipping... }
  2134. PutPixel(ArcCall.xstart,ArcCall.ystart,CurrentColor);
  2135. PutPixel(x,y,CurrentColor);
  2136. PutPixel(ArcCall.xend,ArcCall.yend,CurrentColor);
  2137. Stangle:=stAngle mod 360; EndAngle:=Endangle mod 360;
  2138. if Stangle<=Endangle then
  2139. angle:=(StAngle+EndAngle)/2
  2140. else
  2141. angle:=(Stangle-360+Endangle)/2;
  2142. { fill from the point in the middle of the slice }
  2143. XRadius:=(longint(Radius)*10000) div XAspect;
  2144. YRadius:=(longint(Radius)*10000) div YAspect;
  2145. { avoid rounding errors }
  2146. if abs(ArcCall.xstart-ArcCall.xend)
  2147. +abs(ArcCall.ystart-ArcCall.yend)>2 then
  2148. { FloodFill(x+round(sin((angle+90)*Pi/180)*XRadius/2),
  2149. y+round(cos((angle+90)*Pi/180)*YRadius/2),truecolor);}
  2150. CurrentWriteMode := writemode;
  2151. end;
  2152. {$i fills.inc}
  2153. {$i text.inc}
  2154. procedure InitGraph(var GraphDriver:Integer;var GraphMode:Integer;
  2155. const PathToDriver:String);
  2156. var i,index:Integer;
  2157. LoMode, HiMode: Integer;
  2158. CpyMode: Integer;
  2159. CpyDriver: Integer;
  2160. begin
  2161. { path to the fonts (where they will be searched)...}
  2162. bgipath:=PathToDriver;
  2163. if bgipath[length(bgipath)]<>'\' then
  2164. bgipath:=bgipath+'\';
  2165. { make sure our driver list is setup...}
  2166. QueryAdapterInfo;
  2167. if not assigned(SaveVideoState) then
  2168. RunError(216);
  2169. SaveVideoState;
  2170. InitVars;
  2171. DriverName:=InternalDriverName; { DOS Graphics driver }
  2172. if (Graphdriver=Detect) then
  2173. begin
  2174. HiMode := -1;
  2175. LoMode := -1;
  2176. { We start at VGA-1 }
  2177. GraphDriver := VGA;
  2178. CpyMode := 0;
  2179. { search all possible graphic drivers in ascending order...}
  2180. { usually the new driver numbers indicate newest hardware...}
  2181. { Internal driver numbers start at VGA=9 }
  2182. repeat
  2183. GetModeRange(GraphDriver,LoMode,HiMode);
  2184. { save the highest mode possible...}
  2185. if HiMode = -1 then break;
  2186. CpyMode:=HiMode;
  2187. CpyDriver:=GraphDriver;
  2188. { go to next driver if it exists...}
  2189. Inc(GraphDriver);
  2190. until (CpyMode=-1);
  2191. IntCurrentDriver := CpyDriver;
  2192. { If this is equal to -1 then no graph mode possible...}
  2193. if CpyMode = -1 then
  2194. begin
  2195. _GraphResult := grNotDetected;
  2196. exit;
  2197. end;
  2198. { Actually set the graph mode...}
  2199. SetGraphMode(CpyMode);
  2200. end
  2201. else
  2202. begin
  2203. { Search if that graphics modec actually exists...}
  2204. if SearchMode(GraphDriver,GraphMode) = nil then
  2205. begin
  2206. _GraphResult := grInvalidMode;
  2207. exit;
  2208. end
  2209. else
  2210. begin
  2211. IntCurrentDriver := GraphDriver;
  2212. SetGraphMode(GraphMode);
  2213. end;
  2214. end;
  2215. end;
  2216. procedure SetDirectVideo(DirectAccess: boolean);
  2217. begin
  2218. DirectVideo := DirectAccess;
  2219. end;
  2220. function GetDirectVideo: boolean;
  2221. begin
  2222. GetDirectVideo := DirectVideo;
  2223. end;
  2224. var
  2225. ExitSave: pointer;
  2226. begin
  2227. ModeList := nil;
  2228. SaveVideoState := nil;
  2229. RestoreVideoState := nil;
  2230. { This must be called at startup... because GetGraphMode may }
  2231. { be called even when not in graph mode. }
  2232. QueryAdapterInfo;
  2233. { Install standard fonts }
  2234. { This is done BEFORE startup... }
  2235. InstalledFonts := 0;
  2236. InstallUserFont('TRIP');
  2237. InstallUserFont('LITT');
  2238. InstallUserFont('SANS');
  2239. InstallUserFont('GOTH');
  2240. { This installs an exit procedure which cleans up the mode list...}
  2241. ExitSave := ExitProc;
  2242. ExitProc := @CleanMode;
  2243. end.
  2244. PieSlice
  2245. Sector
  2246. SetGraphBufSize
  2247. SetBkColor
  2248. DetectGraph
  2249. { DetectGraph() }
  2250. { SetBkColor() }