12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621 |
- {
- This file is part of the Free Pascal run time library.
- Copyright (c) 1993,99 by the Free Pascal development team
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- Unit Graph2;
- {-------------------------------------------------------}
- { Differences with TP Graph unit: }
- { - default putimage and getimage only support a max. }
- { of 64K colors on screen, because all pixels are }
- { saved as words. }
- { - Set RGB Palette is not used, SetPalette must be }
- { used instead. }
- { - In the TP graph unit, Clipping is always performed }
- { on strings written with OutText, and this clipping }
- { is done on a character per character basis (for }
- { example, if ONE part of a character is outside the }
- { viewport , then that character is not written at }
- { all to the screen. In FPC Pascal, clipping is done }
- { on a PIXEL basis, not a character basis, so part of }
- { characters which are not entirely in the viewport }
- { may appear on the screen. }
- { - SetTextStyle only conforms to the TP version when }
- { the correct (and expected) values are used for }
- { CharSize for stroked fonts (4 = stroked fonts) }
- { - InstallUserDriver is not supported, so always }
- { returns an error. }
- { - RegisterBGIDriver is not supported, so always }
- { returns an error. }
- { - DrawPoly XORPut mode is not exactly the same as in }
- { the TP graph unit. }
- { - FillEllipse does not support XORPut mode with a }
- { bounded FloodFill. Mode is always CopyPut mode. }
- { - Imagesize returns a longint instead of a word }
- { - ImageSize cannot return an error value }
- {-------------------------------------------------------}
- { AUTHORS: }
- { Gernot Tenchio - original version }
- { Florian Klaempfl - major updates }
- { Pierre Mueller - major bugfixes }
- { Carl Eric Codere - complete rewrite }
- { Thomas Schatzl - optimizations,routines and }
- { Credits (external): suggestions. }
- { - Original FloodFill code by }
- { Menno Victor van der star }
- { (the code has been heavily modified) }
- {-------------------------------------------------------}
- {-------------------------------------------------------}
- { For significant speed improvements , is is recommended }
- { that these routines be hooked (otherwise the default, }
- { slower routines will be used) : }
- { HLine() }
- { VLine() }
- { PatternLine() }
- { ClearViewPort() }
- { PutImage() }
- { GetImage() - ImageSize() should also be changed }
- { InternalEllipse() }
- { Line() }
- { GetScanLine() }
- {--------------------------------------------------------}
- { FPC unit requirements: }
- { All modes should at least have 1 graphics page to }
- { make it possible to create animation on all supported }
- { systems , this can be done either by double-buffering }
- { yourself in the heap if no hardware is available to do}
- { it. }
- {--------------------------------------------------------}
- { COMPATIBILITY WARNING: Some of the compatibility tests }
- { were done using the CGA and other the VGA drivers. }
- { Within the BGI drivers themselves the BEHAVIOUR is not }
- { the same, so be warned!!! }
- {--------------------------------------------------------}
- { History log: }
- { 15th February 1999: }
- { + Added support for system font in vertical mode }
- { + system font is now available for all platforms }
- { * font support routines now compile }
- { * textHeight would not return correct size for system }
- { font }
- { * Alignment of fonts partly fixed }
- { 17th Feb. 1999: }
- { + First support for stroked fonts }
- { 18th Feb. 1999: }
- { * bugfix of line drawing which fixes stroked font }
- { displays. }
- { 23rd Feb. 1999: }
- { + Applied Pierre's patches to font }
- { + Added scaling of bitmapped fonts }
- { + Vertical stroked fonts }
- { 24th Feb. 1999: }
- { * Scaling of stroked fonts must be done using FPs }
- { to be 100% compatible with turbo pascal }
- { + Sped up by 40% stroked font scaling calculations }
- { + RegisterBGIFont }
- { 9th march 1999: }
- { + Starting implementing Fillpoly() }
- { 15th march 1999: }
- { + SetFillStyle() }
- { + patternLine() }
- { + Bar() }
- { * GraphDefaults would not make the Default color }
- { of the fill pattern to the Max. Palette entry. }
- { + SetFillPattern() }
- { 20th march 1999: }
- { * GraphDefaults would not reset to the text system }
- { * DefaultFont would write one character too much to }
- { the screen }
- { + Sloped thick lines in Line() }
- { + Sloped patterned lines in Line() }
- { * GraphDefaults would not reset the User Fill pattern}
- { to $ff }
- { + DirectPutPixel takes care of XOR mode writes }
- { improves speed by about 30% over old method of }
- { GetPixel XOR CurrentColor }
- { * Dashed LineStyle exactly like BP version now }
- { + Center LineStyle (checked against CGA driver) }
- { * GraphDefaults() now resets linepattern array }
- { 1st april 1999: }
- { + First implementation of FillPoly (incomplete) }
- { 2nd april 1999: }
- { * FillPoly did not Reset PatternLine index }
- { * FillPoly did not use correct color }
- { * PatternLine was writing modes in reverse direction }
- { * PatternLine would not work with non-rectangular }
- { shapes. }
- { * PatternLine must fill up the ENTIRE pattern, }
- { with either the foreground or background color. }
- { * GraphDefaults() would not call SetBkColor() }
- { * Fixed some memory leaks in FillPoly() }
- { 11th April 1999: }
- { * PatternLine() was drawing one pixel less then }
- { requested }
- { 12th April 1999: }
- { + FloodFill - first working implementation }
- { Horrbly slow even on very fast cpu's }
- { + Some suggestions of Thomas implemented }
- { 13th April 1999: }
- { * FloodFill() vertical index was off by one pixel }
- { * FloodFill() would never draw the last line in the }
- { list }
- { - Removed ClearViewPort320 which was wrong anyways, }
- { will need to be implemented later. }
- { * PatternLine() would not always restore write mode }
- { + Circle() uses NormalPut always with NormWidth lines}
- { + FillEllipse() initial version }
- { * InternalEllipse() - 0 to 360 now supported as }
- { angles. }
- { 14th April 1999: }
- { * mod x = and (x-1)(from Thomas Schatzl) gives a }
- { significant speed improvement. }
- { 15th april 1999: }
- { + Arc() ok except for Aspect Ratio, which does not }
- { give us the correct ratio on a 320x200 screen. }
- { + Added FillPoly() from Thomas Schatzl }
- { + More hookable routines }
- { 16th april 1999: }
- { + Line() checked ok. }
- { 17th april 1999: }
- { * GraphDefaults() would not reset CP }
- { + GetX(), GetY(), MoveTo() checked for viewports }
- { * OutTextXY() should not update the CP }
- { * ClearViewPort() would not update the CP }
- { * ClearDevice() would not update the CP }
- { * Sector() would update the CP by calling LineTo }
- { * Bar3D() would update the CP }
- { * PieSlice() would update the CP }
- { 18th april 1999: }
- { + Clipping algorithm }
- { 19th april 1999: }
- { + Adapterinfo structure }
- { 20th april 1999: }
- { + GetModeName }
- { + GetGraphMode }
- { + GetModeRange }
- {--------------------------------------------------------}
- { LEFT TO DO: }
- { - optimize scaling of stroked fonts }
- { - optimize InternalEllipse() }
- { using linear appx. of sine/cosine tables }
- { - justification for stroked fonts does not work }
- { - On Closegraph deallocate all font pointers }
- {--------------------------------------------------------}
- { text.inc will crash on aligned requirement machines. }
- { (packed record for fontrec) }
- {$G+}
- Interface
- const
- { error codes }
- grOk = 0;
- grNoInitGraph = -1;
- grNotDetected = -2;
- grFileNotFound = -3;
- grInvalidDriver = -4;
- grNoLoadMem = -5;
- grNoScanMem = -6;
- grNoFloodMem = -7;
- grFontNotFound = -8;
- grNoFontMem = -9;
- grInvalidMode = -10;
- grError = -11;
- grIOerror = -12;
- grInvalidFont = -13;
- grInvalidFontNum = -14;
- grInvalidVersion = -18;
- { Color constants for setpalette }
- black = 0;
- blue = 1;
- green = 2;
- cyan = 3;
- red = 4;
- magenta = 5;
- brown = 6;
- lightgray = 7;
- darkgray = 8;
- lightblue = 9;
- lightgreen = 10;
- lightcyan = 11;
- lightred = 12;
- lightmagenta = 13;
- yellow = 14;
- white = 15;
- EGABlack = 0;
- EGABlue = 1;
- EGAGreen = 2;
- EGACyan = 3;
- EGARed = 4;
- EGAMagenta = 5;
- EGALightgray= 7;
- EGABrown = 20;
- EGADarkgray = 56;
- EGALightblue = 57;
- EGALightgreen = 58;
- EGALightcyan = 59;
- EGALightred = 60;
- EGALightmagenta=61;
- EGAYellow = 62;
- EGAWhite = 63;
- { Line styles for GetLineStyle/SetLineStyle }
- SolidLn = 0;
- DottedLn = 1;
- CenterLn = 2;
- DashedLn = 3;
- UserBitLn = 4;
- NormWidth = 1;
- ThickWidth = 3;
- { Set/GetTextStyle Konstanten: }
- DefaultFont = 0;
- TriplexFont = 1;
- SmallFont = 2;
- SansSerifFont = 3;
- GothicFont = 4;
- ScriptFont = 5;
- SimpleFont = 6;
- TSCRFont = 7;
- LCOMFont = 8;
- EuroFont = 9;
- BoldFont = 10;
- HorizDir = 0;
- VertDir = 1;
- UserCharSize = 0;
- ClipOn = true;
- ClipOff = false;
- { Bar3D constants }
- TopOn = true;
- TopOff = false;
- { fill pattern for Get/SetFillStyle: }
- EmptyFill = 0;
- SolidFill = 1;
- LineFill = 2;
- LtSlashFill = 3;
- SlashFill = 4;
- BkSlashFill = 5;
- LtBkSlashFill = 6;
- HatchFill = 7;
- XHatchFill = 8;
- InterleaveFill = 9;
- WideDotFill = 10;
- CloseDotFill = 11;
- UserFill = 12;
- { bitblt operators }
- NormalPut = 0;
- CopyPut = 0;
- XORPut = 1;
- OrPut = 2;
- AndPut = 3;
- NotPut = 4;
- { SetTextJustify constants }
- LeftText = 0;
- CenterText = 1;
- RightText = 2;
- BottomText = 0;
- TopText = 2;
- { graphic drivers }
- CurrentDriver = -128;
- Detect = 0;
- LowRes = 1;
- HercMono = 7;
- VGA = 9;
- VESA = 10;
- { graph modes }
- Default = 0;
- { VGA Driver modes }
- VGALo = 0;
- VGAMed = 1;
- VGAHi = 2;
- { Hercules mono card }
- HercMonoHi = 0;
- MaxColors = 65535; { Maximum possible colors using a palette }
- { otherwise, direct color encoding }
- type
- RGBRec = packed record
- Red: integer;
- Green: integer;
- Blue : integer;
- end;
- {$ifndef FPC}
- PaletteType = record
- Size : longint;
- Colors : array[0..255] of RGBRec;
- end;
- {$else}
- PaletteType = record
- Size : longint;
- Colors : array[0..MaxColors] of RGBRec;
- end;
- {$endif}
- LineSettingsType = record
- linestyle : word;
- pattern : word;
- thickness : word;
- end;
- TextSettingsType = record
- font : word;
- direction : word;
- charsize : word;
- horiz : word;
- vert : word;
- end;
- FillSettingsType = record
- pattern : word;
- color : word;
- end;
- FillPatternType = array[1..8] of byte;
- PointType = record
- x,y : integer;
- end;
- ViewPortType = record
- x1,y1,x2,y2 : integer;
- Clip : boolean;
- end;
- ArcCoordsType = record
- x,y : integer;
- xstart,ystart : integer;
- xend,yend : integer;
- end;
- const
- fillpatternTable : array[0..12] of FillPatternType = (
- ($00,$00,$00,$00,$00,$00,$00,$00), { background color }
- ($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff), { foreground color }
- ($ff,$ff,$00,$00,$ff,$ff,$00,$00), { horizontal lines }
- ($01,$02,$04,$08,$10,$20,$40,$80), { slashes }
- ($07,$0e,$1c,$38,$70,$e0,$c1,$83), { thick slashes }
- ($07,$83,$c1,$e0,$70,$38,$1c,$0e), { thick backslashes }
- ($5a,$2d,$96,$4b,$a5,$d2,$69,$b4), { backslashes }
- ($ff,$88,$88,$88,$ff,$88,$88,$88), { small boxes }
- ($18,$24,$42,$81,$81,$42,$24,$18), { rhombus }
- ($cc,$33,$cc,$33,$cc,$33,$cc,$33), { wall pattern }
- ($80,$00,$08,$00,$80,$00,$08,$00), { wide points }
- ($88,$00,$22,$00,$88,$00,$22,$00), { dense points }
- (0,0,0,0,0,0,0,0) { user defined line style }
- );
- { ******************** PROCEDURAL VARIABLES ********************* }
- { * These are hooks which have device specific stuff in them, * }
- { * therefore to add new modes or to redirect these routines * }
- { * then declare variables of these types as shown below. * }
- {-----------------------------------------------------------------}
- TYPE
- { This is the standard putpixel routine used by all function }
- { drawing routines, it will use the viewport settings, as }
- { well as clip, and use the current foreground color to plot }
- { the desired pixel. }
- defpixelproc = procedure(X,Y: Integer);
- { standard plot and get pixel }
- getpixelproc = function(X,Y: Integer): word;
- putpixelproc = procedure(X,Y: Integer; Color: Word);
- { clears the viewport, also used to clear the device }
- clrviewproc = procedure;
- { putimage procedure, can be hooked to accomplish transparency }
- putimageproc = procedure (X,Y: Integer; var Bitmap; BitBlt: Word);
- getimageproc = procedure(X1,Y1,X2,Y2: Integer; Var Bitmap);
- imagesizeproc= function (X1,Y1,X2,Y2: Integer): longint;
- graphfreememprc = procedure (var P: Pointer; size: word);
- graphgetmemprc = procedure (var P: pointer; size: word);
- { internal routines -- can be hooked for much faster drawing }
- { draw filled horizontal lines using current color }
- { on entry coordinates are already clipped. }
- hlineproc = procedure (x, x2,y : integer);
- { on entry coordinates are already clipped. }
- { draw filled vertical line using current color }
- vlineproc = procedure (x,y,y2: integer);
- { this routine is used to draw filled patterns for all routines }
- { that require it. (FillPoly, FloodFill, Sector, etc... }
- { clipping is verified, uses current Fill settings for drawing }
- patternlineproc = procedure (x1,x2,y: integer);
- { this routine is used to draw all circles/ellipses/sectors }
- { more info... on this later... }
- ellipseproc = procedure (X,Y: Integer;XRadius: word;
- YRadius:word; stAngle,EndAngle: word);
- { Line routine - draws lines thick/norm widths with current }
- { color and line style - LINE must be clipped here. }
- lineproc = procedure (X1, Y1, X2, Y2 : Integer);
- { this routine is used for FloodFill - it returns an entire }
- { screen scan line with a word for each pixel in the scanline }
- getscanlineproc = procedure (Y : integer; var data);
- { changes the active display screen where we draw to... }
- setactivepageproc = procedure (page: word);
- { changes the active display screen which we see ... }
- setvisualpageproc = procedure (page: word);
- { this routine actually switches to the desired video mode. }
- initmodeproc = procedure;
- { this routine is called to save the sate just before a mode set }
- savestateproc = procedure;
- { this routine is called in closegraph to cleanup... }
- restorestateproc = procedure;
- { This routine is a hook for SetRGBPalette }
- setrgbpaletteproc =
- procedure(ColorNum, RedValue, GreenValue, BlueValue: Integer);
- { This routine is a hook for GetRGBPalette }
- getrgbpaletteproc =
- procedure(ColorNum: integer; var
- RedValue, GreenValue, BlueValue: Integer);
- TYPE
- {-----------------------------------}
- { Linked list for mode information }
- { This list is set up by one of the }
- { following routines: }
- { It lists all available resolutions}
- { on this display adapter. }
- {-----------------------------------}
- { QueryAdapter() }
- { DetectGraph() }
- { InitGraph() }
- {-----------------------------------}
- PModeInfo = ^TModeInfo;
- TModeInfo = record
- DriverNumber: Integer;
- ModeNumber: Integer;
- MaxColor: Longint; { Maximum colors on screen }
- PaletteSize : Longint; { Maximum palette entry we can change }
- XAspect : Integer; { XAspect ratio correction factor }
- YAspect : Integer; { YAspect ratio correction factor }
- MaxX: Integer; { Max-X row }
- MaxY: Integer; { Max. column. }
- DirectColor: boolean; { Is this a direct color mode?? }
- ModeName: String[18];
- { necessary hooks ... }
- DirectPutPixel : DefPixelProc;
- GetPixel : GetPixelProc;
- PutPixel : PutPixelProc;
- SetRGBPalette : SetRGBPaletteProc;
- GetRGBPalette : GetRGBPaletteProc;
- { defaults possible ... }
- SetVisualPage : SetVisualPageProc;
- SetActivePage : SetActivePageProc;
- ClearViewPort : ClrViewProc;
- PutImage : PutImageProc;
- GetImage : GetImageProc;
- ImageSize : ImageSizeProc;
- GetScanLine : GetScanLineProc;
- Line : LineProc;
- InternalEllipse: EllipseProc;
- PatternLine : PatternLineProc;
- HLine : HLineProc;
- VLine : VLineProc;
- InitMode : InitModeProc;
- next: PModeInfo;
- end;
- VAR
- DirectPutPixel : DefPixelProc;
- ClearViewPort : ClrViewProc;
- PutPixel : PutPixelProc;
- PutImage : PutImageProc;
- GetImage : GetImageProc;
- ImageSize : ImageSizeProc;
- GetPixel : GetPixelProc;
- SetVisualPage : SetVisualPageProc;
- SetActivePage : SetActivePageProc;
- SetRGBPalette : SetRGBPaletteProc;
- GetRGBPalette : GetRGBPaletteProc;
- GraphFreeMemPtr: graphfreememprc;
- GraphGetMemPtr : graphgetmemprc;
- GetScanLine : GetScanLineProc;
- Line : LineProc;
- InternalEllipse: EllipseProc;
- PatternLine : PatternLineProc;
- HLine : HLineProc;
- VLine : VLineProc;
- SaveVideoState : SaveStateProc;
- RestoreVideoState: RestoreStateProc;
- Procedure Closegraph;
- procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word);
- function GraphErrorMsg(ErrorCode: Integer): string;
- Function GetMaxX: Integer;
- Function GetMaxY: Integer;
- Procedure SetViewPort(X1, Y1, X2, Y2: Integer; Clip: Boolean);
- Function GraphResult: Integer;
- function GetModeName(ModeNumber: integer): string;
- procedure SetGraphMode(Mode: Integer);
- function GetGraphMode: Integer;
- function GetMaxMode: word;
- procedure RestoreCrtMode;
- procedure GetModeRange(GraphDriver: Integer; var LoMode, HiMode: Integer);
- Function GetX: Integer;
- Function GetY: Integer;
- procedure GraphDefaults;
- procedure ClearDevice;
- procedure GetViewSettings(var viewport : ViewPortType);
- procedure SetWriteMode(WriteMode : integer);
- procedure GetFillSettings(var Fillinfo:Fillsettingstype);
- procedure GetFillPattern(var FillPattern:FillPatternType);
- procedure GetLineSettings(var ActiveLineInfo : LineSettingsType);
- procedure InitGraph(var GraphDriver:Integer;var GraphMode:Integer;const PathToDriver:String);
- function InstallUserDriver(Name: string; AutoDetectPtr: Pointer): integer;
- function RegisterBGIDriver(driver: pointer): integer;
- procedure SetFillStyle(Pattern : word; Color: word);
- procedure SetFillPattern(Pattern: FillPatternType; Color: word);
- procedure MoveRel(Dx, Dy: Integer);
- procedure MoveTo(X,Y: Integer);
- procedure SetDirectVideo(DirectAccess: boolean);
- function GetDirectVideo: boolean;
- { -------------------- Color/Palette ------------------------------- }
- procedure SetBkColor(ColorNum: Word);
- function GetColor: Word;
- function GetBkColor: Word;
- procedure SetColor(Color: Word);
- function GetMaxColor: word;
- procedure SetAllPalette(var Palette:PaletteType);
- procedure SetPalette(ColorNum: word; Color: shortint);
- procedure GetPalette(var Palette: PaletteType);
- function GetPaletteSize: integer;
- procedure GetDefaultPalette(var Palette: PaletteType);
- { -------------------- Shapes/Lines -------------------------------- }
- procedure Rectangle(x1,y1,x2,y2:integer);
- procedure Bar(x1,y1,x2,y2:integer);
- procedure Bar3D(x1, y1, x2, y2 : integer;depth : word;top : boolean);
- procedure FillPoly(NumPoints: word; Var PolyPoints);
- procedure DrawPoly(NumPoints : word;var polypoints);
- procedure LineRel(Dx, Dy: Integer);
- procedure LineTo(X,Y : Integer);
- procedure FloodFill(x : integer; y : integer; Border: word);
- { -------------------- Circle related routines --------------------- }
- procedure GetAspectRatio(var Xasp,Yasp : word);
- procedure SetAspectRatio(Xasp, Yasp : word);
- procedure GetArcCoords(var ArcCoords: ArcCoordsType);
- procedure Arc(X,Y : Integer; StAngle,EndAngle,Radius: word);
- procedure PieSlice(X,Y,stangle,endAngle:integer;Radius: Word);
- procedure FillEllipse(X, Y: Integer; XRadius, YRadius: Word);
- procedure Circle(X, Y: Integer; Radius:Word);
- procedure Sector(x, y: Integer; StAngle,EndAngle, XRadius, YRadius: Word);
- procedure Ellipse(X,Y : Integer; stAngle, EndAngle: word; XRadius,
- YRadius: word);
- { --------------------- Text related routines --------------------- }
- function InstallUserFont(const FontFileName : string) : integer;
- function RegisterBGIfont(font : pointer) : integer;
- procedure GetTextSettings(var TextInfo : TextSettingsType);
- function TextHeight(const TextString : string) : word;
- function TextWidth(const TextString : string) : word;
- procedure SetTextJustify(horiz,vert : word);
- procedure SetTextStyle(font,direction : word;charsize : word);
- procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);
- procedure OutTextXY(x,y : integer;const TextString : string);
- procedure OutText(const TextString : string);
- Implementation
- {$IFDEF DPMI}
- uses WinAPI;
- {$ENDIF}
- const
- StdBufferSize = 4096; { Buffer size for FloodFill }
- type
- tinttable = array[0..8192] of integer;
- pinttable = ^tinttable;
- WordArray = Array [0..StdbufferSize] Of word;
- PWordArray = ^WordArray;
- const
- { Mask for each bit in byte used to determine pattern }
- BitArray: Array[0..7] of byte =
- ($01,$02,$04,$08,$10,$20,$40,$80);
- RevbitArray: Array[0..7] of byte =
- ($80,$40,$20,$10,$08,$04,$02,$01);
- { pre expanded line patterns }
- { 0 = LSB of byte pattern }
- { 15 = MSB of byte pattern }
- LinePatterns: Array[0..15] of BOOLEAN =
- (TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,
- TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,TRUE);
- const
- BGIPath : string = '.';
- { Default font 8x8 system from IBM PC }
- {$i fontdata.inc}
- var
- CurrentColor: Word;
- CurrentBkColor: Word;
- CurrentX : Integer; { viewport relative }
- CurrentY : Integer; { viewport relative }
- ClipPixels: Boolean; { Should cliiping be enabled }
- CurrentWriteMode: Integer;
- _GraphResult : Integer;
- LineInfo : LineSettingsType;
- FillSettings: FillSettingsType;
- { information for Text Output routines }
- CurrentTextInfo : TextSettingsType;
- CurrentXRatio: Real;
- CurrentYRatio: Real;
- installedfonts: longint; { Number of installed fonts }
- StartXViewPort: Integer; { absolute }
- StartYViewPort: Integer; { absolute }
- ViewWidth : Integer;
- ViewHeight: Integer;
- IsGraphMode : Boolean; { Indicates if we are in graph mode or not }
- ArcCall: ArcCoordsType; { Information on the last call to Arc or Ellipse }
- var
- { ******************** HARDWARE INFORMATION ********************* }
- { Should be set in InitGraph once only. }
- IntCurrentMode : Integer;
- IntCurrentDriver : Integer; { Currently loaded driver }
- XAspect : Integer;
- YAspect : Integer;
- MaxX : Integer; { Maximum resolution - ABSOLUTE }
- MaxY : Integer; { Maximum resolution - ABSOLUTE }
- MaxColor : Longint;
- PaletteSize : longint; { Maximum palette entry we can set, usually equal}
- { maxcolor. }
- DriverName: String;
- DirectColor : Boolean ; { Is it a direct color mode? }
- ModeList : PModeInfo;
- DirectVideo : Boolean; { Direct access to video memory? }
- {--------------------------------------------------------------------------}
- { }
- { LINE AND LINE RELATED ROUTINES }
- { }
- {--------------------------------------------------------------------------}
- {$i clip.inc}
- procedure HLineDefault(x,x2,y: integer);
- var
- Col: word;
- xtmp: integer;
- Begin
- { must we swap the values? }
- if x >= x2 then
- Begin
- xtmp := x2;
- x2 := x;
- x:= xtmp;
- end;
- { First convert to global coordinates }
- X := X + StartXViewPort;
- X2 := X2 + StartXViewPort;
- Y := Y + StartYViewPort;
- if ClipPixels then
- Begin
- if LineClipped(x,y,x2,y,StartXViewPort,StartYViewPort,
- StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
- exit;
- end;
- for x:= x to x2 do
- DirectPutPixel(X,Y);
- end;
- procedure VLineDefault(x,y,y2: integer);
- var
- Col: word;
- ytmp: integer;
- Begin
- { must we swap the values? }
- if y >= y2 then
- Begin
- ytmp := y2;
- y2 := y;
- y:= ytmp;
- end;
- { First convert to global coordinates }
- X := X + StartXViewPort;
- Y2 := Y2 + StartYViewPort;
- Y := Y + StartYViewPort;
- if ClipPixels then
- Begin
- if LineClipped(x,y,x,y2,StartXViewPort,StartYViewPort,
- StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
- exit;
- end;
- for y := y to y2 do Directputpixel(x,y)
- End;
- procedure LineDefault(X1, Y1, X2, Y2: Integer);
- var X, Y : Integer;
- deltax, deltay : Integer;
- d, dinc1, dinc2: Integer;
- xinc1 : Integer;
- xinc2 : Integer;
- yinc1 : Integer;
- yinc2 : Integer;
- i, j : Integer;
- Flag : Boolean; { determines pixel direction in thick lines }
- NumPixels : Integer;
- PixelCount : Integer;
- OldCurrentColor: Word;
- swtmp : integer;
- TmpNumPixels : integer;
- begin
- {******************************************}
- { SOLID LINES }
- {******************************************}
- if lineinfo.LineStyle = SolidLn then
- Begin
- { we separate normal and thick width for speed }
- { and because it would not be 100% compatible }
- { with the TP graph unit otherwise }
- if y1 = y2 then
- Begin
- {******************************************}
- { SOLID LINES HORIZONTAL }
- {******************************************}
- if lineinfo.Thickness=NormWidth then
- hline(x1,x2,y2)
- else
- begin
- { thick width }
- hline(x1,x2,y2-1);
- hline(x1,x2,y2);
- hline(x2,x2,y2+1);
- end;
- end
- else
- if x1 = x2 then
- Begin
- {******************************************}
- { SOLID LINES VERTICAL }
- {******************************************}
- if lineinfo.Thickness=NormWidth then
- vline(x1,y1,y2)
- else
- begin
- { thick width }
- vline(x1-1,y1,y2);
- vline(x1,y1,y2);
- vline(x1+1,y1,y2);
- end;
- end
- else
- begin
- { Convert to global coordinates. }
- x1 := x1 + StartXViewPort;
- x2 := x2 + StartXViewPort;
- y1 := y1 + StartYViewPort;
- y2 := y2 + StartYViewPort;
- { if fully clipped then exit... }
- if ClipPixels then
- begin
- if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
- StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
- exit;
- end;
- {******************************************}
- { SLOPED SOLID LINES }
- {******************************************}
- oldCurrentColor := CurrentColor;
- { Calculate deltax and deltay for initialisation }
- deltax := abs(x2 - x1);
- deltay := abs(y2 - y1);
- { Initialize all vars based on which is the independent variable }
- if deltax >= deltay then
- begin
- Flag := FALSE;
- { x is independent variable }
- numpixels := deltax + 1;
- d := (2 * deltay) - deltax;
- dinc1 := deltay Shl 1;
- dinc2 := (deltay - deltax) shl 1;
- xinc1 := 1;
- xinc2 := 1;
- yinc1 := 0;
- yinc2 := 1;
- end
- else
- begin
- Flag := TRUE;
- { y is independent variable }
- numpixels := deltay + 1;
- d := (2 * deltax) - deltay;
- dinc1 := deltax Shl 1;
- dinc2 := (deltax - deltay) shl 1;
- xinc1 := 0;
- xinc2 := 1;
- yinc1 := 1;
- yinc2 := 1;
- end;
- { Make sure x and y move in the right directions }
- if x1 > x2 then
- begin
- xinc1 := - xinc1;
- xinc2 := - xinc2;
- end;
- if y1 > y2 then
- begin
- yinc1 := - yinc1;
- yinc2 := - yinc2;
- end;
- { Start drawing at <x1, y1> }
- x := x1;
- y := y1;
- If LineInfo.Thickness=NormWidth then
- Begin
- { Draw the pixels }
- for i := 1 to numpixels do
- begin
- DirectPutPixel(x, y);
- if d < 0 then
- begin
- d := d + dinc1;
- x := x + xinc1;
- y := y + yinc1;
- end
- else
- begin
- d := d + dinc2;
- x := x + xinc2;
- y := y + yinc2;
- end;
- CurrentColor := OldCurrentColor;
- end;
- end
- else
- { Thick width lines }
- begin
- { Draw the pixels }
- for i := 1 to numpixels do
- begin
- { all depending on the slope, we can determine }
- { in what direction the extra width pixels will be put }
- If Flag then
- Begin
- DirectPutPixel(x-1,y);
- DirectPutPixel(x,y);
- DirectPutPixel(x+1,y);
- end
- else
- Begin
- DirectPutPixel(x, y-1);
- DirectPutPixel(x, y);
- DirectPutPixel(x, y+1);
- end;
- if d < 0 then
- begin
- d := d + dinc1;
- x := x + xinc1;
- y := y + yinc1;
- end
- else
- begin
- d := d + dinc2;
- x := x + xinc2;
- y := y + yinc2;
- end;
- CurrentColor := OldCurrentColor;
- end;
- end;
- end;
- end
- else
- {******************************************}
- { begin patterned lines }
- {******************************************}
- Begin
- { Convert to global coordinates. }
- x1 := x1 + StartXViewPort;
- x2 := x2 + StartXViewPort;
- y1 := y1 + StartYViewPort;
- y2 := y2 + StartYViewPort;
- { if fully clipped then exit... }
- if ClipPixels then
- begin
- if LineClipped(x1,y1,x2,y2,StartXViewPort, StartYViewPort,
- StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
- exit;
- end;
- OldCurrentColor := CurrentColor;
- PixelCount:=0;
- if y1 = y2 then
- Begin
- { Check if we must swap }
- if x1 >= x2 then
- Begin
- swtmp := x1;
- x1 := x2;
- x2 := swtmp;
- end;
- if LineInfo.Thickness = NormWidth then
- Begin
- for PixelCount:=x1 to x2 do
- { optimization: PixelCount mod 16 }
- if LinePatterns[PixelCount and 15] = TRUE then
- begin
- DirectPutPixel(PixelCount,y2);
- end;
- end
- else
- Begin
- for i:=-1 to 1 do
- Begin
- for PixelCount:=x1 to x2 do
- { Optimization from Thomas - mod 16 = and 15 }
- if LinePatterns[PixelCount and 15] = TRUE then
- begin
- DirectPutPixel(PixelCount,y2+i);
- end;
- end;
- end;
- end
- else
- if x1 = x2 then
- Begin
- { Check if we must swap }
- if y1 >= y2 then
- Begin
- swtmp := y1;
- y1 := y2;
- y2 := swtmp;
- end;
- if LineInfo.Thickness = NormWidth then
- Begin
- for PixelCount:=y1 to y2 do
- { compare if we should plot a pixel here , compare }
- { with predefined line patterns... }
- if LinePatterns[PixelCount and 15] = TRUE then
- begin
- DirectPutPixel(x1,PixelCount);
- end;
- end
- else
- Begin
- for i:=-1 to 1 do
- Begin
- for PixelCount:=y1 to y2 do
- { compare if we should plot a pixel here , compare }
- { with predefined line patterns... }
- if LinePatterns[PixelCount and 15] = TRUE then
- begin
- DirectPutPixel(x1+i,PixelCount);
- end;
- end;
- end;
- end
- else
- Begin
- oldCurrentColor := CurrentColor;
- { Calculate deltax and deltay for initialisation }
- deltax := abs(x2 - x1);
- deltay := abs(y2 - y1);
- { Initialize all vars based on which is the independent variable }
- if deltax >= deltay then
- begin
- Flag := FALSE;
- { x is independent variable }
- numpixels := deltax + 1;
- d := (2 * deltay) - deltax;
- dinc1 := deltay Shl 1;
- dinc2 := (deltay - deltax) shl 1;
- xinc1 := 1;
- xinc2 := 1;
- yinc1 := 0;
- yinc2 := 1;
- end
- else
- begin
- Flag := TRUE;
- { y is independent variable }
- numpixels := deltay + 1;
- d := (2 * deltax) - deltay;
- dinc1 := deltax Shl 1;
- dinc2 := (deltax - deltay) shl 1;
- xinc1 := 0;
- xinc2 := 1;
- yinc1 := 1;
- yinc2 := 1;
- end;
- { Make sure x and y move in the right directions }
- if x1 > x2 then
- begin
- xinc1 := - xinc1;
- xinc2 := - xinc2;
- end;
- if y1 > y2 then
- begin
- yinc1 := - yinc1;
- yinc2 := - yinc2;
- end;
- { Start drawing at <x1, y1> }
- x := x1;
- y := y1;
- If LineInfo.Thickness=ThickWidth then
- Begin
- TmpNumPixels := NumPixels-1;
- { Draw the pixels }
- for i := 0 to TmpNumPixels do
- begin
- { all depending on the slope, we can determine }
- { in what direction the extra width pixels will be put }
- If Flag then
- Begin
- { compare if we should plot a pixel here , compare }
- { with predefined line patterns... }
- if LinePatterns[i and 15] = TRUE then
- begin
- DirectPutPixel(x-1,y);
- DirectPutPixel(x,y);
- DirectPutPixel(x+1,y);
- end;
- end
- else
- Begin
- { compare if we should plot a pixel here , compare }
- { with predefined line patterns... }
- if LinePatterns[i and 15] = TRUE then
- begin
- DirectPutPixel(x,y-1);
- DirectPutPixel(x,y);
- DirectPutPixel(x,y+1);
- end;
- end;
- if d < 0 then
- begin
- d := d + dinc1;
- x := x + xinc1;
- y := y + yinc1;
- end
- else
- begin
- d := d + dinc2;
- x := x + xinc2;
- y := y + yinc2;
- end;
- end;
- end
- else
- Begin
- { instead of putting in loop , substract by one now }
- TmpNumPixels := NumPixels-1;
- { NormWidth }
- for i := 0 to TmpNumPixels do
- begin
- if LinePatterns[i and 15] = TRUE then
- begin
- DirectPutPixel(x,y);
- end;
- if d < 0 then
- begin
- d := d + dinc1;
- x := x + xinc1;
- y := y + yinc1;
- end
- else
- begin
- d := d + dinc2;
- x := x + xinc2;
- y := y + yinc2;
- end;
- end;
- end
- end;
- {******************************************}
- { end patterned lines }
- {******************************************}
- { restore color }
- CurrentColor:=OldCurrentColor;
- end;
- end; { Line }
- {********************************************************}
- { Procedure InternalEllipse() }
- {--------------------------------------------------------}
- { This routine first calculates all points required to }
- { draw a circle to the screen, and stores the points }
- { to display in a buffer before plotting them. The }
- { aspect ratio of the screen is taken into account when }
- { calculating the values. }
- {--------------------------------------------------------}
- { INPUTS: X,Y : Center coordinates of Ellipse. }
- { XRadius - X-Axis radius of ellipse. }
- { YRadius - Y-Axis radius of ellipse. }
- { stAngle, EndAngle: Start angle and end angles of the }
- { ellipse (used for partial ellipses and circles) }
- {--------------------------------------------------------}
- { NOTE: - uses the current write mode. }
- { - Angles must both be between 0 and 360 }
- {********************************************************}
- Procedure InternalEllipseDefault(X,Y: Integer;XRadius: word;
- YRadius:word; stAngle,EndAngle: word);
- var
- i:integer;
- xpt: pinttable;
- ypt: pinttable;
- j,Delta:real;
- NumOfPixels: longint;
- NumOfPix: Array[0..2] of longint;
- count: longint;
- ConvFac,TempTerm: real;
- aval,bval: integer;
- OldcurrentColor: word;
- TmpAngle: word;
- DeltaAngle: word;
- Begin
- { check if valid angles }
- stangle := stAngle mod 361;
- EndAngle := EndAngle mod 361;
- { if impossible angles then swap them! }
- if Endangle < StAngle then
- Begin
- TmpAngle:=EndAngle;
- EndAngle:=StAngle;
- Stangle:=TmpAngle;
- end;
- { calculate difference of angle now so we don't always have to calculate it }
- DeltaAngle:= EndAngle-StAngle;
- i:=0;
- if LineInfo.Thickness=NormWidth then
- Begin
- { approximate the number of pixels required by using the circumference }
- { equation of an ellipse. }
- NumOfPixels:=8*Round(2*sqrt((sqr(XRadius)+sqr(YRadius)) div 2));
- GetMem(xpt,NumOfpixels*sizeof(word));
- GetMem(ypt,NumOfPixels*sizeof(word));
- { Calculate the angle precision required }
- Delta := DeltaAngle / (NumOfPixels);
- { Adjust for screen aspect ratio }
- XRadius:=(longint(XRadius)*10000) div XAspect;
- YRadius:=(longint(YRadius)*10000) div YAspect;
- { Initial counter value }
- j:=Delta+StAngle;
- { removed from inner loop to make faster }
- ConvFac:=Pi/180.0;
- Repeat
- { this used by both sin and cos }
- TempTerm := j*ConvFac;
- { Calculate points }
- xpt^[i]:=round(XRadius*Cos(TempTerm));
- { calculate the value of y }
- ypt^[i]:=round(YRadius*Sin(TempTerm+Pi));
- j:=j+Delta;
- inc(i);
- Until j > DeltaAngle;
- end
- else
- {******************************************}
- { CIRCLE OR ELLIPSE WITH THICKNESS=3 }
- {******************************************}
- Begin
- NumOfPix[1]:=8*Round(2*sqrt((sqr(XRadius)+sqr(YRadius)) div 2));
- NumOfPix[0]:=8*Round(2*sqrt((sqr(XRadius-1)+sqr(YRadius-1)) div 2));
- NumOfPix[2]:=8*Round(2*sqrt((sqr(XRadius+1)+sqr(YRadius+1)) div 2));
- GetMem(xpt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
- GetMem(ypt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
- { removed from inner loop to make faster }
- ConvFac:=Pi/180.0;
- for Count:=0 to 2 do
- Begin
- aval:=XRadius+Count-1;
- bval:=YRadius+Count-1;
- Delta := DeltaAngle / (NumOfPix[Count]);
- aval:= (longint(aval)*10000) div XAspect;
- bval:= (longint(bval)*10000) div YAspect;
- j:=Delta+Stangle;
- Repeat
- { this used by both sin and cos }
- TempTerm := j*ConvFac;
- xpt^[i]:=round((aval)*Cos(TempTerm));
- { calculate the value of y }
- ypt^[i]:=round(bval*Sin(TempTerm+Pi));
- j:=j+Delta;
- inc(i);
- Until j > DeltaAngle;
- end;
- end;
- {******************************************}
- { NOW ALL PIXEL POINTS ARE IN BUFFER }
- { plot them all to the screen }
- {******************************************}
- Count:=0;
- OldcurrentColor:=currentColor;
- Repeat
- PutPixel(xpt^[Count]+X,ypt^[Count]+Y,CurrentColor);
- inc(count);
- until Count>=i;
- { Get End and Start points into the ArcCall information record }
- ArcCall.X := X;
- ArcCall.Y := Y;
- ArcCall.XStart := xpt^[0] + X;
- ArcCall.YStart := ypt^[0] + Y;
- ArcCall.XEnd := xpt^[Count-1] + X;
- ArcCall.YEnd := ypt^[Count-1] + Y;
- CurrentColor:=OldCurrentColor;
- if LineInfo.Thickness=NormWidth then
- Begin
- Freemem(xpt,NumOfPixels*sizeof(word));
- Freemem(ypt,NumOfPixels*sizeof(word));
- end
- else
- Begin
- FreeMem(xpt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
- FreeMem(ypt,(NumOfPix[1]+NumOfPix[2]+NumOfPix[0])*sizeof(word));
- end;
- end;
- {********************************************************}
- { Procedure InternalEllipse() }
- {--------------------------------------------------------}
- { This routine first calculates all points required to }
- { draw a circle to the screen, and stores the points }
- { to display in a buffer before plotting them. The }
- { aspect ratio of the screen is taken into account when }
- { calculating the values. }
- {--------------------------------------------------------}
- { INPUTS: X,Y : Center coordinates of Ellipse. }
- { XRadius - X-Axis radius of ellipse. }
- { YRadius - Y-Axis radius of ellipse. }
- { stAngle, EndAngle: Start angle and end angles of the }
- { ellipse (used for partial ellipses and circles) }
- {--------------------------------------------------------}
- { NOTE: - uses the current write mode. }
- { - Angles must both be between 0 and 360 }
- {********************************************************}
- (*
- Procedure InternalEllipseDefault (x, y : integer;
- xradius, yradius, stAngle, EndAngle : Word);
- { Draw an ellipse arc. Crude but it works (anyone have a better one?) }
- Var
- aSqr, bSqr, twoaSqr, twobSqr, xa, ya, twoXbSqr, twoYaSqr, error : LongInt;
- Alpha : Real;
- const
- RadToDeg = 180/Pi;
- Procedure PlotPoints;
- var
- i,j: integer;
- xm, ym: integer;
- xp, yp: integer;
- Begin
- ym := y-ya;
- yp := y+ya;
- xm := x-xa;
- xp := x+xa;
- if LineInfo.Thickness = Normwidth then
- Begin
- If (Alpha>=StAngle) And (Alpha<=EndAngle) then
- PutPixel (xm,ym, CurrentColor);
- If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then
- PutPixel (xm,yp, CurrentColor);
- If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then
- PutPixel (xp,yp, CurrentColor);
- If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then
- PutPixel (xp,ym, CurrentColor);
- end
- else
- Begin
- If (Alpha>=StAngle) And (Alpha<=EndAngle) then
- for i:=-1 to 1 do
- for j:=-1 to 1 do
- PutPixel (xm+i,ym+j, CurrentColor);
- If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then
- for i:=-1 to 1 do
- for j:=-1 to 1 do
- PutPixel (xm+i,yp+j, CurrentColor);
- If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then
- for i:=-1 to 1 do
- for j:=-1 to 1 do
- PutPixel (xp+i,yp+j, CurrentColor);
- If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then
- for i:=-1 to 1 do
- for j:=-1 to 1 do
- PutPixel (xp+i,ym+j, CurrentColor);
- end;
- End;
- Begin
- StAngle:=StAngle MOD 361;
- EndAngle:=EndAngle MOD 361;
- StAngle := StAngle + 270;
- EndAngle := EndAngle + 270;
- If StAngle>EndAngle then
- Begin
- StAngle:=StAngle Xor EndAngle; EndAngle:=EndAngle Xor StAngle; StAngle:=EndAngle Xor StAngle;
- End;
- { Adjust for screen aspect ratio }
- XRadius:=(longint(XRadius)*10000) div XAspect;
- YRadius:=(longint(YRadius)*10000) div YAspect;
- aSqr:=LongInt (xradius)*LongInt (xradius);
- bSqr:=LongInt (yradius)*LongInt (yradius);
- twoaSqr:=2*aSqr;
- twobSqr:=2*bSqr;
- xa:=0;
- ya:=yradius;
- twoXbSqr:=0;
- twoYaSqr:=ya*twoaSqr;
- error:=-ya*aSqr;
- While twoXbSqr<=twoYaSqr Do Begin
- If ya=0 then Alpha:=90 Else Alpha:=RadToDeg*Arctan (xa/ya); { Crude but it works }
- PlotPoints;
- Inc (xa);
- Inc (twoXbSqr,twobSqr);
- Inc (error,twoXbSqr-bSqr);
- If error>=0 then Begin
- Dec (ya);
- Dec (twoYaSqr,twoaSqr);
- Dec (error,twoYaSqr);
- End;
- End;
- xa:=xradius;
- ya:=0;
- twoXbSqr:=xa*twobSqr;
- twoYaSqr:=0;
- error:=-xa*bSqr;
- While twoXbSqr>twoYaSqr Do Begin
- If ya=0 then Alpha:=90 Else Alpha:=RadToDeg*Arctan (xa/ya);
- PlotPoints;
- Inc (ya);
- Inc (twoYaSqr,twoaSqr);
- Inc (error,twoYaSqr-aSqr);
- If error>=0 then Begin
- Dec (xa);
- Dec (twoXbSqr,twobSqr);
- Dec (error,twoXbSqr);
- End;
- End;
- End;
- *)
- procedure PatternLineDefault(x1,x2,y: integer);
- {********************************************************}
- { Draws a horizontal patterned line according to the }
- { current Fill Settings. }
- {********************************************************}
- { Important notes: }
- { - CurrentColor must be set correctly before entering }
- { this routine. }
- {********************************************************}
- var
- NrIterations: Integer;
- i : Integer;
- j : Integer;
- TmpFillPattern : byte;
- OldWriteMode : word;
- OldCurrentColor : word;
- begin
- { convert to global coordinates ... }
- x1 := x1 + StartXViewPort;
- x2 := x2 + StartXViewPort;
- y := y + StartYViewPort;
- { if line was fully clipped then exit...}
- if LineClipped(x1,y,x2,y,StartXViewPort,StartYViewPort,
- StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
- exit;
- OldWriteMode := CurrentWriteMode;
- CurrentWriteMode := NormalPut;
- { number of times to go throuh the 8x8 pattern }
- NrIterations := abs(x2 - x1) div 8;
- Inc(NrIterations);
- { Get the current pattern }
- TmpFillPattern := FillPatternTable
- { [FillSettings.Pattern][(((y+viewport.x1) and $7)+1];}
- [FillSettings.Pattern][(y and $7)+1];
- if FillSettings.Pattern = EmptyFill then
- begin
- OldCurrentColor := CurrentColor;
- CurrentColor := CurrentBkColor;
- HLine(x1,x2,y);
- CurrentColor := OldCurrentColor;
- end
- else
- if FillSettings.Pattern = SolidFill then
- begin
- HLine(x1,x2,y);
- end
- else
- begin
- For i:= 0 to NrIterations do
- Begin
- for j:=0 to 7 do
- Begin
- { x1 mod 8 }
- if RevBitArray[x1 and 7] and TmpFillPattern <> 0 then
- DirectPutpixel(x1,y)
- else
- begin
- { According to the TP graph manual, we overwrite everything }
- { which is filled up - checked against VGA and CGA drivers }
- { of TP. }
- OldCurrentColor := CurrentColor;
- CurrentColor := CurrentBkColor;
- DirectPutPixel(x1,y);
- CurrentColor := OldCurrentColor;
- end;
- Inc(x1);
- if x1 > x2 then
- begin
- CurrentWriteMode := OldWriteMode;
- exit;
- end;
- end;
- end;
- end;
- CurrentWriteMode := OldWriteMode;
- end;
- procedure LineRel(Dx, Dy: Integer);
- Begin
- Line(CurrentX, CurrentY, CurrentX + Dx, CurrentY + Dy);
- CurrentX := CurrentX + Dx;
- CurrentY := CurrentY + Dy;
- end;
- procedure LineTo(x,y : Integer);
- Begin
- Line(CurrentX, CurrentY, X, Y);
- CurrentX := X;
- CurrentY := Y;
- end;
- procedure Rectangle(x1,y1,x2,y2:integer);
- begin
- { Do not draw the end points }
- Line(x1,y1,x2-1,y1);
- Line(x1,y1+1,x1,y2);
- Line(x2,y1,x2,y2-1);
- Line(x1+1,y2,x2,y2);
- end;
- procedure GetLineSettings(var ActiveLineInfo : LineSettingsType);
- begin
- Activelineinfo:=Lineinfo;
- end;
- procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word);
- var
- i: byte;
- j: byte;
- Begin
- if (LineStyle > UserBitLn) or ((Thickness <> Normwidth) and (Thickness <> ThickWidth)) then
- _GraphResult := grError
- else
- begin
- LineInfo.Thickness := Thickness;
- LineInfo.LineStyle := LineStyle;
- case LineStyle of
- UserBitLn: Lineinfo.Pattern := pattern;
- SolidLn: Lineinfo.Pattern := $ffff; { ------- }
- DashedLn : Lineinfo.Pattern := $F8F8; { -- -- --}
- DottedLn: LineInfo.Pattern := $CCCC; { - - - - }
- CenterLn: LineInfo.Pattern := $FC78; { -- - -- }
- end; { end case }
- { setup pattern styles }
- j:=15;
- for i:=0 to 15 do
- Begin
- { bitwise mask for each bit in the word }
- if (word($01 shl i) AND LineInfo.Pattern) <> 0 then
- LinePatterns[j]:=TRUE
- else
- LinePatterns[j]:=FALSE;
- Dec(j);
- end;
- end;
- end;
- {--------------------------------------------------------------------------}
- { }
- { VIEWPORT RELATED ROUTINES }
- { }
- {--------------------------------------------------------------------------}
- Procedure ClearViewPortDefault;
- var
- j: integer;
- OldWriteMode, OldCurColor: word;
- LineSets : LineSettingsType;
- Begin
- { CP is always RELATIVE coordinates }
- CurrentX := 0;
- CurrentY := 0;
- { Save all old settings }
- OldCurColor := CurrentColor;
- CurrentColor:=CurrentBkColor;
- OldWriteMode:=CurrentWriteMode;
- GetLineSettings(LineSets);
- { reset to normal line style...}
- SetLineStyle(SolidLn, 0, NormWidth);
- { routines are relative here...}
- for J:=0 to ViewHeight do
- HLine(0, ViewWidth, J);
- { restore old settings...}
- SetLineStyle(LineSets.LineStyle, LineSets.Pattern, LineSets.Thickness);
- CurrentColor := OldCurColor;
- CurrentWriteMode := OldWriteMode;
- end;
- Procedure SetViewPort(X1, Y1, X2, Y2: Integer; Clip: Boolean);
- Begin
- if (X1 > GetMaxX) or (X2 > GetMaxX) or (X1 > X2) or (X1 < 0) then
- Begin
- _GraphResult := grError;
- exit;
- end;
- if (Y1 > GetMaxY) or (Y2 > GetMaxY) or (Y1 > Y2) or (Y1 < 0) then
- Begin
- _GraphResult := grError;
- exit;
- end;
- { CP is always RELATIVE coordinates }
- CurrentX := 0;
- CurrentY := 0;
- StartXViewPort := X1;
- StartYViewPort := Y1;
- ViewWidth := X2-X1;
- ViewHeight:= Y2-Y1;
- ClipPixels := Clip;
- end;
- procedure GetViewSettings(var viewport : ViewPortType);
- begin
- ViewPort.X1 := StartXViewPort;
- ViewPort.Y1 := StartYViewPort;
- ViewPort.X2 := ViewWidth + StartXViewPort;
- ViewPort.Y2 := ViewHeight + StartYViewPort;
- ViewPort.Clip := ClipPixels;
- end;
- procedure ClearDevice;
- var
- ViewPort: ViewPortType;
- begin
- { Reset the CP }
- CurrentX := 0;
- CurrentY := 0;
- { save viewport }
- ViewPort.X1 := StartXviewPort;
- ViewPort.X2 := ViewWidth - StartXViewPort;
- ViewPort.Y1 := StartYViewPort;
- ViewPort.Y2 := ViewHeight - StartYViewPort;
- ViewPort.Clip := ClipPixels;
- { put viewport to full screen }
- StartXViewPort := 0;
- ViewHeight := MaxY;
- StartYViewPort := 0;
- ViewWidth := MaxX;
- ClipPixels := TRUE;
- ClearViewPort;
- { restore old viewport }
- StartXViewPort := ViewPort.X1;
- ViewWidth := ViewPort.X2-ViewPort.X1;
- StartYViewPort := ViewPort.Y1;
- ViewHeight := ViewPort.Y2-ViewPort.Y1;
- ClipPixels := ViewPort.Clip;
- end;
- {--------------------------------------------------------------------------}
- { }
- { BITMAP PUT/GET ROUTINES }
- { }
- {--------------------------------------------------------------------------}
- Procedure GetScanlineDefault (Y : Integer; Var Data);
- {********************************************************}
- { Procedure GetScanLine() }
- {--------------------------------------------------------}
- { Returns the full scanline of the video line of the Y }
- { coordinate. The values are returned in a WORD array }
- { each WORD representing a pixel of the specified scanline}
- {********************************************************}
- Var
- Offset, x : Integer;
- Begin
- For x:=0 to MaxX Do Begin
- WordArray(Data)[x]:=GetPixel(x, y);
- End;
- End;
- Function DefaultImageSize(X1,Y1,X2,Y2: Integer): longint;
- Begin
- { each pixel uses two bytes, to enable modes with colors up to 64K }
- { to work. }
- DefaultImageSize := 12 + (((X2-X1)*(Y2-Y1))*2);
- end;
- Procedure DefaultPutImage(X,Y: Integer; var Bitmap; BitBlt: Word);
- type
- pt = array[0..32000] of word;
- ptw = array[0..3] of longint;
- var
- color: word;
- i,j: Integer;
- Y1,X1: Integer;
- k: integer;
- Begin
- X1:= ptw(Bitmap)[0]+X; { get width and adjust end coordinate accordingly }
- Y1:= ptw(Bitmap)[1]+Y; { get height and adjust end coordinate accordingly }
- k:= 12; { Three reserved longs at start of bitmap }
- for j:=Y to Y1 do
- Begin
- for i:=X to X1 do
- begin
- case BitBlt of
- {$R-}
- CopyPut: color:= pt(Bitmap)[k]; { also = normalput }
- XORPut: color:= pt(Bitmap)[k] XOR GetPixel(i,j);
- OrPut: color:= pt(Bitmap)[k] OR GetPixel(i,j);
- AndPut: color:= pt(Bitmap)[k] AND GetPixel(i,j);
- NotPut: color:= not pt(Bitmap)[k];
- {$R+}
- end;
- putpixel(i,j,color);
- Inc(k);
- end;
- end;
- end;
- Procedure DefaultGetImage(X1,Y1,X2,Y2: Integer; Var Bitmap);
- type
- pt = array[0..32000] of word;
- ptw = array[0..3] of longint;
- var
- i,j: integer;
- k: longint;
- Begin
- k:= 12; { Three reserved longs at start of bitmap }
- for j:=Y1 to Y2 do
- Begin
- for i:=X1 to X2 do
- begin
- {$R-}
- pt(Bitmap)[k] :=getpixel(i,j);
- {$R+}
- Inc(k);
- end;
- end;
- ptw(Bitmap)[0] := X2-X1; { First longint is width }
- ptw(Bitmap)[1] := Y2-Y1; { Second longint is height }
- ptw(bitmap)[2] := 0; { Third longint is reserved}
- end;
- Procedure GetArcCoords(var ArcCoords: ArcCoordsType);
- Begin
- ArcCoords.X := ArcCall.X;
- ArcCoords.Y := ArcCall.Y;
- ArcCoords.XStart := ArcCall.XStart;
- ArcCoords.YStart := ArcCall.YStart;
- ArcCoords.XEnd := ArcCall.XEnd;
- ArcCoords.YEnd := ArcCall.YEnd;
- end;
- procedure SetVisualPageDefault(page : word);
- begin
- end;
- procedure SetActivePageDefault(page : word);
- begin
- end;
- Procedure DefaultHooks;
- {********************************************************}
- { Procedure DefaultHooks() }
- {--------------------------------------------------------}
- { Resets all hookable routine either to nil for those }
- { which need overrides, and others to defaults. }
- { This is called each time SetGraphMode() is called. }
- {********************************************************}
- Begin
- { All default hooks procedures }
- { required...}
- DirectPutPixel := nil;
- PutPixel := nil;
- GetPixel := nil;
- SetRGBPalette := nil;
- GetRGBPalette := nil;
- { optional...}
- SetActivePage := SetActivePageDefault;
- SetVisualPage := SetVisualPageDefault;
- ClearViewPort := ClearViewportDefault;
- PutImage := DefaultPutImage;
- GetImage := DefaultGetImage;
- ImageSize := DefaultImageSize;
- GraphFreeMemPtr := nil;
- GraphGetMemPtr := nil;
- GetScanLine := GetScanLineDefault;
- Line := LineDefault;
- InternalEllipse := InternalEllipseDefault;
- PatternLine := PatternLineDefault;
- HLine := HLineDefault;
- VLine := VLineDefault;
- end;
- Procedure InitVars;
- {********************************************************}
- { Procedure InitVars() }
- {--------------------------------------------------------}
- { Resets all internal variables, and resets all }
- { overridable routines. }
- {********************************************************}
- Begin
- DirectVideo := TRUE; { By default use fastest access possible }
- ArcCall.X := 0;
- ArcCall.Y := 0;
- ArcCall.XStart := 0;
- ArcCall.YStart := 0;
- ArcCall.XEnd := 0;
- ArcCall.YEnd := 0;
- { Reset to default values }
- IntCurrentMode := 0;
- IntCurrentDriver := 0;
- XAspect := 0;
- YAspect := 0;
- MaxX := 0;
- MaxY := 0;
- MaxColor := 0;
- PaletteSize := 0;
- DirectColor := FALSE;
- DefaultHooks;
- end;
- {$i modes.inc}
- {$i graph.inc}
- function InstallUserDriver(Name: string; AutoDetectPtr: Pointer): integer;
- begin
- _graphResult := grError;
- end;
- function RegisterBGIDriver(driver: pointer): integer;
- begin
- _graphResult := grError;
- end;
- { ----------------------------------------------------------------- }
- Procedure Arc(X,Y : Integer; StAngle,EndAngle,Radius: word);
- var
- OldWriteMode: word;
- Begin
- if (Radius = 0) then
- Exit;
- if (Radius = 1) then
- begin
- { must use clipping ... }
- { don't need to explicitly set NormalPut mode }
- { because PutPixel only supports normal put }
- PutPixel(X, Y,CurrentColor);
- Exit;
- end;
- { Only if we are using thickwidths lines do we accept }
- { XORput write modes. }
- OldWriteMode := CurrentWriteMode;
- if (LineInfo.Thickness = NormWidth) then
- CurrentWriteMode := NormalPut;
- InternalEllipse(X,Y,Radius,Radius,StAngle,Endangle);
- CurrentWriteMode := OldWriteMode;
- end;
- procedure Ellipse(X,Y : Integer; stAngle, EndAngle: word; XRadius,YRadius: word);
- Begin
- InternalEllipse(X,Y,XRadius,YRadius,stAngle,EndAngle);
- end;
- procedure FillEllipse(X, Y: Integer; XRadius, YRadius: Word);
- {********************************************************}
- { Procedure FillEllipse() }
- {--------------------------------------------------------}
- { Draws a filled ellipse using (X,Y) as a center point }
- { and XRadius and YRadius as the horizontal and vertical }
- { axes. The ellipse is filled with the current fill color}
- { and fill style, and is bordered with the current color.}
- {--------------------------------------------------------}
- { Important notes: }
- { - CONTRRARY to VGA BGI - SetWriteMode DOES not }
- { affect the contour of the ellipses. BGI mode }
- { supports XORPut but the FloodFill() is still bounded}
- { by the ellipse. In OUR case, XOR Mode is simply }
- { not supported. }
- {********************************************************}
- var
- OldWriteMode: Word;
- begin
- { only normal put supported }
- OldWriteMode := CurrentWriteMode;
- CurrentWriteMode := NormalPut;
- InternalEllipse(X,Y,XRadius,YRadius,0,360);
- FloodFill(X,Y,CurrentColor);
- { restore old write mode }
- CurrentWriteMode := OldWriteMode;
- end;
- procedure Circle(X, Y: Integer; Radius:Word);
- {********************************************************}
- { Draws a circle centered at X,Y with the given Radius. }
- {********************************************************}
- { Important notes: }
- { - Thickwidth circles use the current write mode, while}
- { normal width circles ALWAYS use CopyPut/NormalPut }
- { mode. (Tested against VGA BGI driver -CEC 13/Aug/99 }
- {********************************************************}
- var OriginalArcInfo: ArcCoordsType;
- OldWriteMode: word;
- begin
- if (Radius = 0) then
- Exit;
- if (Radius = 1) then
- begin
- { only normal put mode is supported by a call to PutPixel }
- PutPixel(X, Y, CurrentColor);
- Exit;
- end;
- { save state of arc information }
- { because it is not needed for }
- { a circle call. }
- move(ArcCall,OriginalArcInfo, sizeof(ArcCall));
- if LineInfo.Thickness = Normwidth then
- begin
- OldWriteMode := CurrentWriteMode;
- CurrentWriteMode := CopyPut;
- end;
- InternalEllipse(X,Y,Radius,Radius,0,360);
- if LineInfo.Thickness = Normwidth then
- CurrentWriteMode := OldWriteMode;
- { restore arc information }
- move(OriginalArcInfo, ArcCall,sizeof(ArcCall));
- end;
- procedure Sector(x, y: Integer; StAngle,EndAngle, XRadius, YRadius: Word);
- var angle : real;
- writemode : word;
- begin
- Ellipse(x,y,stAngle,endAngle,XRadius,YRadius);
- { As in the TP graph unit - the line settings are used to }
- { define the outline of the sector. }
- writemode:=Currentwritemode;
- Currentwritemode:=normalput;
- Line(ArcCall.XStart, ArcCall.YStart, x,y);
- Line(x,y,ArcCall.Xend,ArcCall.YEnd);
- { we must take care of clipping so we call PutPixel instead }
- { of DirectPutPixel... }
- PutPixel(ArcCall.xstart,ArcCall.ystart,CurrentColor);
- PutPixel(x,y,CurrentColor);
- PutPixel(ArcCall.xend,ArcCall.yend,CurrentColor);
- stangle:=Stangle mod 360; EndAngle:=Endangle mod 360;
- if stAngle<=Endangle then
- Angle:=(stAngle+EndAngle)/2
- else
- angle:=(stAngle-360+EndAngle)/2;
- { fill from the point in the middle of the slice }
- XRadius:=(longint(XRadius)*10000) div XAspect;
- YRadius:=(longint(YRadius)*10000) div YAspect;
- { avoid rounding errors }
- if abs(ArcCall.xstart-ArcCall.xend)
- +abs(ArcCall.ystart-ArcCall.yend)>2 then
- FloodFill(x+round(sin((angle+90)*Pi/180)*XRadius/2),
- y+round(cos((angle+90)*Pi/180)*YRadius/2),CurrentColor);
- CurrentWriteMode := writemode;
- end;
- procedure SetFillStyle(Pattern : word; Color: word);
- begin
- { on invalid input, the current fill setting will be }
- { unchanged. }
- if (Pattern > UserFill) or (Color > GetMaxColor) then
- begin
- _GraphResult := grError;
- exit;
- end;
- FillSettings.Color := Color;
- FillSettings.Pattern := Pattern;
- end;
- procedure SetFillPattern(Pattern: FillPatternType; Color: word);
- {********************************************************}
- { Changes the Current FillPattern to a user defined }
- { pattern and changes also the current fill color. }
- { The FillPattern is saved in the FillPattern array so }
- { it can still be used with SetFillStyle(UserFill,Color) }
- {********************************************************}
- var
- i: integer;
- begin
- if Color > GetMaxColor then
- begin
- _GraphResult := grError;
- exit;
- end;
- FillSettings.Color := Color;
- FillSettings.Pattern := UserFill;
- { Save the pattern in the buffer }
- For i:=1 to 8 do
- FillPatternTable[UserFill][i] := Pattern[i];
- end;
- procedure Bar(x1,y1,x2,y2:integer);
- {********************************************************}
- { Important notes for compatibility with BP: }
- { - WriteMode is always CopyPut }
- { - No contour is drawn for the lines }
- {********************************************************}
- var y : Integer;
- origcolor : longint;
- origlinesettings: Linesettingstype;
- origwritemode : Integer;
- begin
- origlinesettings:=lineinfo;
- origcolor:=CurrentColor;
- { Always copy mode for Bars }
- origwritemode := CurrentWriteMode;
- CurrentWriteMode := CopyPut;
- { All lines used are of this style }
- Lineinfo.linestyle:=solidln;
- Lineinfo.thickness:=normwidth;
- case Fillsettings.pattern of
- EmptyFill :
- begin
- Currentcolor:=CurrentBkColor;
- for y:=y1 to y2 do
- Hline(x1,x2,y);
- end;
- SolidFill :
- begin
- CurrentColor:=FillSettings.color;
- for y:=y1 to y2 do
- Hline(x1,x2,y);
- end;
- else
- Begin
- CurrentColor:=FillSettings.color;
- for y:=y1 to y2 do
- patternline(x1,x2,y);
- end;
- end;
- CurrentColor:= Origcolor;
- LineInfo := OrigLineSettings;
- CurrentWriteMode := OrigWritemode;
- end;
- procedure bar3D(x1, y1, x2, y2 : integer;depth : word;top : boolean);
- var
- origwritemode : integer;
- OldX, OldY : integer;
- begin
- origwritemode := CurrentWriteMode;
- CurrentWriteMode := CopyPut;
- Bar(x1,y1,x2,y2);
- Rectangle(x1,y1,x2,y2);
- { Current CP should not be updated in Bar3D }
- { therefore save it and then restore it on }
- { exit. }
- OldX := CurrentX;
- OldY := CurrentY;
- if top then begin
- Moveto(x1,y1);
- Lineto(x1+depth,y1-depth);
- Lineto(x2+depth,y1-depth);
- Lineto(x2,y1);
- end;
- if Depth <> 0 then
- Begin
- Moveto(x2+depth,y1-depth);
- Lineto(x2+depth,y2-depth);
- Lineto(x2,y2);
- end;
- { restore CP }
- CurrentX := OldX;
- CurrentY := OldY;
- CurrentWriteMode := origwritemode;
- end;
- {--------------------------------------------------------------------------}
- { }
- { COLOR AND PALETTE ROUTINES }
- { }
- {--------------------------------------------------------------------------}
- {$i palette.inc}
- procedure SetColor(Color: Word);
- Begin
- CurrentColor := Color;
- end;
- function GetColor: Word;
- Begin
- GetColor := CurrentColor;
- end;
- function GetBkColor: Word;
- Begin
- GetBkColor := CurrentBkColor;
- end;
- procedure SetBkColor(ColorNum: Word);
- { Background color means background screen color in this case, and it is }
- { INDEPENDANT of the viewport settings, so we must clear the whole screen }
- { with the color. }
- var
- ViewPort: ViewportType;
- Begin
- GetViewSettings(Viewport);
- SetViewPort(0,0,MaxX,MaxY,FALSE);
- CurrentBkColor := ColorNum;
- ClearViewPort;
- SetViewport(ViewPort.X1,Viewport.Y1,Viewport.X2,Viewport.Y2,Viewport.Clip);
- end;
- function GetMaxColor: word;
- { Checked against TP VGA driver - CEC }
- begin
- GetMaxColor:=MaxColor-1; { based on an index of zero so subtract one }
- end;
- Procedure MoveRel(Dx, Dy: Integer);
- Begin
- CurrentX := CurrentX + Dx;
- CurrentY := CurrentY + Dy;
- end;
- Procedure MoveTo(X,Y: Integer);
- {********************************************************}
- { Procedure MoveTo() }
- {--------------------------------------------------------}
- { Moves the current pointer in VIEWPORT relative }
- { coordinates to the specified X,Y coordinate. }
- {********************************************************}
- Begin
- CurrentX := X;
- CurrentY := Y;
- end;
- function GraphErrorMsg(ErrorCode: Integer): string;
- Begin
- GraphErrorMsg:='';
- case ErrorCode of
- grOk,grFileNotFound,grInvalidDriver: exit;
- grNoInitGraph: GraphErrorMsg:='Graphics driver not installed';
- grNotDetected: GraphErrorMsg:='Graphics hardware not detected';
- grNoLoadMem,grNoScanMem,grNoFloodMem: GraphErrorMsg := 'Not enough memory for graphics';
- grNoFontMem: GraphErrorMsg := 'Not enough memory to load font';
- grFontNotFound: GraphErrorMsg:= 'Font file not found';
- grInvalidMode: GraphErrorMsg := 'Invalid graphics mode';
- grError: GraphErrorMsg:='Graphics error';
- grIoError: GraphErrorMsg:='Graphics I/O error';
- grInvalidFont,grInvalidFontNum: GraphErrorMsg := 'Invalid font';
- grInvalidVersion: GraphErrorMsg:='Invalid driver version';
- end;
- end;
- Function GetMaxX: Integer;
- { Routine checked against VGA driver - CEC }
- Begin
- GetMaxX := MaxX;
- end;
- Function GetMaxY: Integer;
- { Routine checked against VGA driver - CEC }
- Begin
- GetMaxY := MaxY;
- end;
- Function GraphResult: Integer;
- Begin
- GraphResult := _GraphResult;
- _GraphResult := grOk;
- end;
- Function GetX: Integer;
- Begin
- GetX := CurrentX;
- end;
- Function GetY: Integer;
- Begin
- GetY := CurrentY;
- end;
- Function GetDriverName: string;
- var
- mode: PModeInfo;
- begin
- GetDriverName:=DriverName;
- end;
- procedure graphdefaults;
- { PS: GraphDefaults does not ZERO the ArcCall structure }
- { so a call to GetArcCoords will not change even the }
- { returned values even if GraphDefaults is called in }
- { between. }
- var
- i: integer;
- begin
- lineinfo.linestyle:=solidln;
- lineinfo.thickness:=normwidth;
- { reset line style pattern }
- for i:=0 to 15 do
- LinePatterns[i] := TRUE;
- { By default, according to the TP prog's reference }
- { the default pattern is solid, and the default }
- { color is the maximum color in the palette. }
- fillsettings.color:=GetMaxColor;
- fillsettings.pattern:=solidfill;
- { GraphDefaults resets the User Fill pattern to $ff }
- { checked with VGA BGI driver - CEC }
- for i:=1 to 8 do
- FillPatternTable[UserFill][i] := $ff;
- CurrentColor:=white;
- SetBkColor(Black);
- ClipPixels := TRUE;
- { Reset the viewport }
- StartXViewPort := 0;
- StartYViewPort := 0;
- ViewWidth := MaxX;
- ViewHeight := MaxY;
- { Reset CP }
- CurrentX := 0;
- CurrentY := 0;
- { normal write mode }
- CurrentWriteMode := CopyPut;
- { Schriftart einstellen }
- CurrentTextInfo.font := DefaultFont;
- CurrentTextInfo.direction:=HorizDir;
- CurrentTextInfo.charsize:=1;
- CurrentTextInfo.horiz:=LeftText;
- CurrentTextInfo.vert:=TopText;
- XAspect:=10000; YAspect:=10000;
- end;
- procedure GetAspectRatio(var Xasp,Yasp : word);
- begin
- XAsp:=XAspect;
- YAsp:=YAspect;
- end;
- procedure SetAspectRatio(Xasp, Yasp : word);
- begin
- Xaspect:= XAsp;
- YAspect:= YAsp;
- end;
- procedure SetWriteMode(WriteMode : integer);
- begin
- if (writemode<>xorput) and (writemode<>CopyPut) then
- exit;
- CurrentWriteMode := WriteMode;
- end;
- procedure GetFillSettings(var Fillinfo:Fillsettingstype);
- begin
- Fillinfo:=Fillsettings;
- end;
- procedure GetFillPattern(var FillPattern:FillPatternType);
- begin
- FillPattern:=FillpatternTable[UserFill];
- end;
- procedure DrawPoly(numpoints : word;var polypoints);
- type
- ppointtype = ^pointtype;
- pt = array[0..16000] of pointtype;
- var
- i : longint;
- begin
- if numpoints < 2 then
- begin
- _GraphResult := grError;
- exit;
- end;
- for i:=0 to numpoints-2 do
- line(pt(polypoints)[i].x,
- pt(polypoints)[i].y,
- pt(polypoints)[i+1].x,
- pt(polypoints)[i+1].y);
- end;
- procedure PieSlice(X,Y,stangle,endAngle:integer;Radius: Word);
- var angle : real;
- XRadius, YRadius : word;
- writemode : word;
- begin
- Arc(x,y,StAngle,EndAngle,Radius);
- Line(ArcCall.XStart, ArcCall.YStart, x,y);
- Line(x,y, ArcCall.XEnd, ArcCall.YEnd);
- { must use PutPixel() instead of DirectPutPixel because we need }
- { clipping... }
- PutPixel(ArcCall.xstart,ArcCall.ystart,CurrentColor);
- PutPixel(x,y,CurrentColor);
- PutPixel(ArcCall.xend,ArcCall.yend,CurrentColor);
- Stangle:=stAngle mod 360; EndAngle:=Endangle mod 360;
- if Stangle<=Endangle then
- angle:=(StAngle+EndAngle)/2
- else
- angle:=(Stangle-360+Endangle)/2;
- { fill from the point in the middle of the slice }
- XRadius:=(longint(Radius)*10000) div XAspect;
- YRadius:=(longint(Radius)*10000) div YAspect;
- { avoid rounding errors }
- if abs(ArcCall.xstart-ArcCall.xend)
- +abs(ArcCall.ystart-ArcCall.yend)>2 then
- { FloodFill(x+round(sin((angle+90)*Pi/180)*XRadius/2),
- y+round(cos((angle+90)*Pi/180)*YRadius/2),truecolor);}
- CurrentWriteMode := writemode;
- end;
- {$i fills.inc}
- {$i text.inc}
- procedure InitGraph(var GraphDriver:Integer;var GraphMode:Integer;
- const PathToDriver:String);
- var i,index:Integer;
- LoMode, HiMode: Integer;
- CpyMode: Integer;
- CpyDriver: Integer;
- begin
- { path to the fonts (where they will be searched)...}
- bgipath:=PathToDriver;
- if bgipath[length(bgipath)]<>'\' then
- bgipath:=bgipath+'\';
- { make sure our driver list is setup...}
- QueryAdapterInfo;
- if not assigned(SaveVideoState) then
- RunError(216);
- SaveVideoState;
- InitVars;
- DriverName:=InternalDriverName; { DOS Graphics driver }
- if (Graphdriver=Detect) then
- begin
- HiMode := -1;
- LoMode := -1;
- { We start at VGA-1 }
- GraphDriver := VGA;
- CpyMode := 0;
- { search all possible graphic drivers in ascending order...}
- { usually the new driver numbers indicate newest hardware...}
- { Internal driver numbers start at VGA=9 }
- repeat
- GetModeRange(GraphDriver,LoMode,HiMode);
- { save the highest mode possible...}
- if HiMode = -1 then break;
- CpyMode:=HiMode;
- CpyDriver:=GraphDriver;
- { go to next driver if it exists...}
- Inc(GraphDriver);
- until (CpyMode=-1);
- IntCurrentDriver := CpyDriver;
- { If this is equal to -1 then no graph mode possible...}
- if CpyMode = -1 then
- begin
- _GraphResult := grNotDetected;
- exit;
- end;
- { Actually set the graph mode...}
- SetGraphMode(CpyMode);
- end
- else
- begin
- { Search if that graphics modec actually exists...}
- if SearchMode(GraphDriver,GraphMode) = nil then
- begin
- _GraphResult := grInvalidMode;
- exit;
- end
- else
- begin
- IntCurrentDriver := GraphDriver;
- SetGraphMode(GraphMode);
- end;
- end;
- end;
- procedure SetDirectVideo(DirectAccess: boolean);
- begin
- DirectVideo := DirectAccess;
- end;
- function GetDirectVideo: boolean;
- begin
- GetDirectVideo := DirectVideo;
- end;
- var
- ExitSave: pointer;
- begin
- ModeList := nil;
- SaveVideoState := nil;
- RestoreVideoState := nil;
- { This must be called at startup... because GetGraphMode may }
- { be called even when not in graph mode. }
- QueryAdapterInfo;
- { Install standard fonts }
- { This is done BEFORE startup... }
- InstalledFonts := 0;
- InstallUserFont('TRIP');
- InstallUserFont('LITT');
- InstallUserFont('SANS');
- InstallUserFont('GOTH');
- { This installs an exit procedure which cleans up the mode list...}
- ExitSave := ExitProc;
- ExitProc := @CleanMode;
- end.
- PieSlice
- Sector
- SetGraphBufSize
- SetBkColor
- DetectGraph
- { DetectGraph() }
- { SetBkColor() }
|