(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *) (* Soubor: VESA2.PAS *) (* Obsah: kompletni jednotka pro 256barevnou SVGA (VESA) grafiku *) (* Autori puvodni jednotky SVGA 4: Asp/VR group, 1996-99 *) (* Virtual Research independent group production, 1999 *) (* Prevzal, upravil, opravil, rozsiril, vylepsil: Mircosoft *) (* (http://mircosoft.mzf.cz) *) (* Nastavovani frekvence castecne vychazi z Laacovy jednotky VenomGFX. *) (* Posledni uprava: 6.11.2024 *) (* Pro kompilaci: ERRMSG.TPU, KLAVESY2.TPU, CFG.TPU *) (* Pro spusteni: pokud chcete zobrazovat texty, potrebujete nejaky soubor *) (* s fontem typu *.FNT (vytvareji se mym programem *) (* FNTEDIT, neni to zadny oficialni format) *) (* Upozorneni: tyto zdrojove kody pouzivate na vlastni nebezpeci *) (* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *) unit VESA2; {$G+,N+,R-,B-,I-} {dulezite - nechat} {$E-,S-,Q-,V-,X-} {podruzne - jak je libo} {Pozn.: vsechny verejne identifikatory v tehle jednotce zacinaji podtrzitkem. Puvodni ucel byl, aby se nepletly s jednotkou Graph a slo v jednom programu pouzivat obe. Ted uz je to spis jenom takove poznavaci znameni.} {...$define Blbuvzdornost} {Nechte definovat, pokud chcete zapnout kontrolu poradi parametru (napr. levy horni vs. pravy dolni roh) u vsech kreslicich procedur. Pokud definovana neni, kontroluje se poradi pouze u zabezpecenych procedur (__neco). U tech zakladnich (_neco) je to na vas.} {...$define debug} {Pomocne informace, ktere se za behu programu vypisuji na obrazovku, a ruzne diagnosticke procedury. Jen pro vyjimecne pripady, obvykle nejsou potreba.} interface {Nasledujici dve promenne se automaticky vyplni pri spusteni programu, ktery tuto jednotku pouziva:} var _VESAVersion:word; {Verze VESA BIOSu graficke karty. Vyssi byte je ta cislice pred teckou, nizsi ta za teckou (napr. $0102 = verze 1.2). Da se podle toho odhadnout, co karta umi.} _8bitPalette:boolean; {True, jestli je graficka karta schopna prepnuti do rezimu, kdy jsou jednotlive slozky barev v palete (RGB) vyjadrene plnymi 8 bity misto standardnich 6. To umi zaridit jednotka Paleta2.} (************************** Spusteni grafiky: *******************************) procedure _SetMode(Mode:word); {Nastavi prislusny graficky (nebo textovy) rezim. Moznosti jsou:} const _Textmode=0; {rezim, ktery byl nastaven pred spustenim programu (obvykle 16barevny textovy rezim 80x25), tuto hodnotu zadejte pro ukonceni grafiky.} _640x350=$11C; {\ Graficke rezimy; cisla v nazvech udavaji rozliseni } _640x400=$100; { \ v pixelech. Ciselne hodnoty odpovidaji standardnim } _640x480=$101; { \ kodum techto rezimu. Kdyby na vasi graficke karte } _800x600=$103; { / byly kodovane jinak, nevadi, procedura uz si nejaky} _1024x768=$105; { / rezim s pozadovanym rozlisenim najde. } {Standardni obnovovaci frekvence monitoru je 60 Hz. Na LCD je to v pohode, ale na starsich CRT to taha za oci - potrebovaly by aspon 80. Jestli mate VESA VBE verze 3.0 nebo novejsi (viz _Vesaversion vyse), muzete si pred zavolanim _Setmode nastavit pozadovanou frekvenci do teto promenne:} const _RefreshFrequency:word=0; {Nula znamena vychozi frekvenci (60 Hz), cokoli jineho je primo pozadovana frekvence v Hz. Pokud ma monitor datovy kanal DDC a v OS je zaveden prislusny ovladac, bude nejdrive zkontrolovano, jestli je vubec schopen zadanou frekvenci pouzit, a kdyz ne, tak se mu frekvence automaticky prizpusobi, aby nedoslo k poskozeni. Pokud DDC neni k dispozici, dostane uzivatel na vyber, jestli to chce risknout se zadanou frekvenci, nebo radsi necha tu vychozi. Po skonceni procedury _Setmode najdete v promenne _Refreshfrequency vyslednou prizpusobenou hodnotu, ktera vam na obrazovce prave bezi. Nastavena frekvence se automaticky uklada do konfiguracniho souboru (Cfgsoubor z jednotky CFG), kde si ji muzete zkontrolovat a pripadne rucne prepsat. Pred kazdym spustenim grafiky si jednotka tuto hodnotu nacte a pokusi se ji pouzit (samozrejme s kontrolou a prizpusobenim moznostem monitoru). _Setmode navic vyplnuje nasledujici promenne:} var _VGACompatible:boolean; {Jestli je graficka karta kompatibilni s VGA. Pokud neni (to se mi jeste nestalo), nelze pouzivat standardni porty VGA, tj. cekani na navrat paprsku nebo primou manipulaci s paletou.} _MaxX,_MaxY:word; {Souradnice praveho dolniho rohu obrazovky. V zadnem pripade je nemente, vyuzivaji se k vypoctum adres bodu na obrazovce!} (****************************** Bankovani: **********************************) {Obrazovka zabira v pameti graficke karty (VRAM) nekolik set KB, ale v realnem rezimu muzeme pristupovat pouze k jednomu 64KB segmentu ($A000). Resi se to tak, ze ten segment nad VRAM posouvame podle toho, do ktere casti obrazovky zrovna potrebujeme kreslit. Jednotlivym poloham segmentu se rika banky. Cisluji se od nuly a vetsinou kazda dalsi zacina presne za koncem te predchozi (tedy po 64 KB). Ale existuji i karty, ktere je maji nasazene husteji (treba Cirrus Logic je ma po 4 KB) - tomu se rika granularita. Bankovaci procedury v tehle jednotce si cisla bank automaticky prepocitavaji tak, aby odpovidala obvykle granularite 64 KB. Za normalnich okolnosti probiha bankovani plne automaticky uvnitr kreslicich procedur, takze se o nej nemusite starat. Rucni bankovani je potreba pouze ve vyjimecnych pripadech - napr. kdyz neco kreslite v preruseni, potrebujete napred zjistit puvodni banku a pak se do ni zase vratit, abyste nerozhodili kresleni, co mezitim bezi na popredi.} {Pro zapisovaci okno graficke karty:} procedure _SwitchBank(bank:word); {Prepne do zadane banky.} function _GetBank:word; {Vrati cislo aktualne nastavene banky.} {Pro cteci okno:} procedure _SwitchRBank(bank:word); function _GetRBank:word; {O jakych oknech se tu vlastne mluvi: jde o pristupove cesty k VRAM. Vetsina existujicich grafickych karet pracuje pouze s jednim oknem (A). Jeho segmentova adresa je prakticky vzdy $A000 a sluzba pro prepinani bank ho zna pod cislem 0. Nektere karty maji jeste druhe okno (B) s cislem 1. A teoreticky je mozne, aby jedno z tech oken bylo pouze pro zapis a druhe pouze pro cteni. Tato jednotka si dostupnost a vlastnosti obou oken detekuje pri spousteni grafickeho rezimu a je schopna provozu za jakychkoli podminek (tedy opet: pokud neprogramujete grafiku v preruseni, muzete to pustit z hlavy). Pozn.: jedine dva pripady, kdy se vyuziva cteci okno, jsou funkce Getpixel a procedura Getimage.} (************************** Orezavaci okno: *********************************) {Vsechno, co tahle jednotka kresli, je schopna oriznout tak, aby to nepresahovalo za okraje monitoru a nezpusobovalo vady obrazu (pretekani mezi levym a pravym okrajem apod.) nebo zapisy do nealokovane pameti. Orezavaci okno muze byt obecne jakykoli obdelnik, pri spusteni grafiky se automaticky nastavi na celou obrazovku. Prenastavit se da temihle procedurami:} procedure _SetWindow(minX,minY,maxX,maxY:integer); {Min je levy horni roh, max pravy dolni. Zadane hodnoty se kontroluji a jakekoli nesmysly (prohozene minimum s maximem nebo polohy mimo monitor) se automaticky opravuji.} procedure _SetDefaultWindow; {Nastavi orezavaci okno zpatky na celou obrazovku.} {Souradnice okna jsou ulozene v techto promennych:} var _MinClipX,_MinClipY,_MaxClipX,_MaxClipY:integer; {Pripadne rucni zmeny nevadi, jenom si davejte pozor na rozsahy - nesmi presahnout mimo monitor.} (********************* Kresleni geometrickych tvaru: ************************) {Vetsina procedur ma dve varianty: _neco - jedno podtrzitko znaci nizkourovnovou variantu bez orezavani podle okna. Je na vas, abyste si kontrolovali souradnice a nekreslili mimo obrazovku. __neco - dve podtrzitka znaci bezpecnou verzi s orezavanim. Tady uz je jedno kam to nakreslite, maximalne to nebude videt.} {Nektere procedury maji parametr Style, ktery urcuje, jakym zpusobem maji kreslit. Moznosti jsou:} const _Outline=0; {vykresli pouze obrys obrazce} _Filled=1; {vyplni danou barvou cely obrazec} _Xor=2; {kresleny obrazec xoruje s puvodnim obsahem obrazovky (uzitecnou vlastnosti xoru je, ze druhym vykreslenim na stejnem miste se obrazec smaze) Konstanty muzete libovolne scitat, parametr Style funguje jako bitove pole. Nesmyslne hodnoty (napr. vypln u cary) nevadi, ignoruji se.} procedure _PutPixel(x,y:word; Color,Style:byte); procedure __PutPixel(x,y:integer; Color,Style:byte); {Pixel na souradnicich x,y obarvi barvou Color. Lze vyuzit styl _xor, styl _filled nema vliv.} function _GetPixel(x,y:word):byte; function __GetPixel(x,y:integer):byte; {Vrati barvu pixelu na danych souradnicich. Kdyz po __Getpixelu chceme pixel mimo okno, vrati barvu z nejblizsiho okraje.} procedure _HLine(x1,x2,y:word; Color:word); procedure _XorHLine(x1,x2,y:word; Color:word); procedure __HLine(x1,x2,y:integer; Color,Style:byte); {Nakresli vodorovnou caru v barve Color z bodu x1,y do bodu x2,y (s vypnutou blbuvzdornosti musi byt u _ varianty x2>x1). Pouziva 32bitove vykreslovani a je optimalizovana na rychlost, proto je v nizkourovnove verzi xor zvlast a barva typu word (hodnoty davejte normalne v rozsahu 0..255).} procedure _VLine(x,y1,y2:word; Color,Style:byte); procedure __VLine(x,y1,y2:integer; Color,Style:byte); {Svisla cara z bodu x,y1 do bodu x,y2 (y2>y1). Kresli se pixel po pixelu, takze nema cenu ji moc optimalizovat: mezi normalnim kreslenim a xorem prepina parametr Style.} procedure _Line(x1,y1,x2,y2:word; Color:byte; Style:byte); procedure __Line(x1,y1,x2,y2:integer; Color:byte; Style:byte); {Obecna cara z bodu x1,y1 do bodu x2,y2. V pripade, ze vyjde presne vodorovne nebo svisle, vykresluje se pomoci Hline nebo Vline. Jinak je to serie Putpixelu rozmistena pomoci Bresenhamova algoritmu.} procedure _MaskedLine(x1,y1,x2,y2:integer; Color,Style:byte; Mask:word); procedure __MaskedLine(x1,y1,x2,y2:integer; Color,Style:byte; Mask:word); {Vzorkovana (prerusovana) cara. Mask je maska podobna jako pri nastavovani SetLineStyle v BGI: nejvyssi bit se promitne do prvniho pixelu cary (x1,y1), druhy nejvyssi bit do druheho pixelu atd. a dal se maska opakuje az do konce cary. Pixely, ktere odpovidaji jednickovym bitum masky, se vykresli barvou Color. Pixely, ktere odpovidaji nulam, se vynechaji. Kresli se Putpixelem bez optimalizaci na rychlost.} procedure __ThickLine(x1,y1,x2,y2:integer; Width:word; Color,Style:byte); {Tlusta cara, Width je sirka v pixelech. Styly funguji vsechny a navic jeste jeden specialni, ktery zakulati konce:} const _RoundEnds=4; procedure __Ellipse(centerX,centerY,rX,rY:word; Color,Style:byte); {Elipsa. centerX, centerY - souradnice stredu rX, rY - vodorovny a svisly polomer Color - barva obrysu nebo vyplne Style - funguji vsechny rezimy (obrys, vypln i xor) Prazdna elipsa se sklada z Putpixelu, vyplnena z Hline.} procedure __Rectangle(x1,y1,x2,y2:word; Color,Style:byte); {Obdelnik. x1,y1 - levy horni roh x2,y2 - pravy dolni roh Color - barva Style - funguji vsechny rezimy Prazdny se sklada z __Hline a __Vline, plny je __Bar.} procedure _Bar(x1,y1,x2,y2,Color:word); procedure __Bar(x1,y1,x2,y2:integer; Color,Style:byte); {Vyplneny obdelnik, parametry obdobne jako Rectangle. _Bar je optimalizovany na rychlost (32 b), neda se stylovat a s vypnutou blbuvzdornosti musi mit x2>x1 a y2>y1. __Baru prohozene souradnice nevadi a da se u nej pouzit styl _xor (s nim se kresli jako serie Xorhline, jinak Bar). Styl _filled nema vliv, vzdy se kresli s vyplni.} procedure _MaskedBar(x1,y1,x2,y2,Colors:word; var Mask); procedure __MaskedBar(x1,y1,x2,y2:integer; Colors:word; var Mask); {Obdelnik s dvojbarevnou vyplni, podobny tomu z BGI se vzorkem nastavenym procedurou Setfillpattern. Navazovani vzorku pri kresleni nekolika obdelniku pres sebe je zaruceno, rychlost je pomerne slusna (64b kopirovani pres FPU). x1,y1,x2,y2 - jako u vyse uvedenych obdelniku, varianta __ vzdy kontroluje spravne poradi. Colors - ve vyssim bytu je barva pozadi, v nizsim barva popredi. Mask - pole osmi bytu, ktere funguje jako ctverec 8x8 bitu. Kazdy byte je jeden radek (prvni nahore, posledni dole), kazdy bit v bytu je jeden pixel (nejvyssi bit vlevo, nejnizsi vpravo). Bity s hodnotou 1 se vykresli barvou popredi, bity 0 barvou pozadi. Pro ukladani masek muzete vyuzit treba tenhle typ:} type _8ByteArray=array[0..7] of byte; {A tady je par preddefinovanych vzorku (pred pouzitim smazte ty tri tecky):} {$define vzorky} {$ifdef vzorky} const _LineFill: _8bytearray=($FF,$FF,$00,$00,$FF,$FF,$00,$00);{= 2px} _LineFill2: _8bytearray=($CC,$CC,$CC,$CC,$CC,$CC,$CC,$CC);{|| 2px} _LtSlashFill: _8bytearray=($01,$02,$04,$08,$10,$20,$40,$80);{/ 1px} _LtSlashFill2: _8bytearray=($11,$22,$44,$88,$11,$22,$44,$88);{// 1px} _SlashFill: _8bytearray=($C1,$83,$07,$0E,$1C,$38,$70,$E0);{/ 3px} _SlashFill2: _8bytearray=($78,$F0,$E1,$C3,$87,$0F,$1E,$3C);{/ 4px} _LtBkSlashFill1:_8bytearray=($80,$40,$20,$10,$08,$04,$02,$01);{\ 1px} _LtBkSlashFill2:_8bytearray=($88,$44,$22,$11,$88,$44,$22,$11);{\\ 1px} _BkSlashFill: _8bytearray=($F0,$78,$3C,$1E,$0F,$87,$C3,$E1);{\ 4px} _LtBkSlashFill: _8bytearray=($A5,$D2,$69,$B4,$5A,$2D,$96,$4B);{\\\ 1+2+1px} _HatchFill: _8bytearray=($FF,$88,$88,$88,$FF,$88,$88,$88);{# 1px} _XHatchFill: _8bytearray=($81,$42,$24,$18,$18,$24,$42,$81);{XX 1px s uzly} _XHatchFill2: _8bytearray=($11,$0A,$04,$0A,$11,$A0,$40,$A0);{XX 1px bez uzlu} _InterleaveFill:_8bytearray=($CC,$33,$CC,$33,$CC,$33,$CC,$33);{.. 2px} _WideDotFill0: _8bytearray=($00,$02,$00,$00,$00,$20,$00,$00);{. 1px 3%} _WideDotFill1: _8bytearray=($00,$22,$00,$00,$00,$22,$00,$00);{. 1px 6%} _WideDotFill: _8bytearray=($80,$00,$08,$00,$80,$00,$08,$00);{. 1px 6%} _CloseDotFill: _8bytearray=($88,$00,$22,$00,$88,$00,$22,$00);{. 1px 13%} _CloseDotFill2: _8bytearray=($00,$AA,$00,$AA,$00,$AA,$00,$AA);{.. 1px 25%} _CloseDotFill3: _8bytearray=($55,$AA,$55,$AA,$55,$AA,$55,$AA);{.... 1px 50%} {Jmena bez cisel odpovidaji standardnim vzorkum z BGI (viz Setfillstyle), ostatni jsou nove.} {$endif} procedure __Box(x1,y1,x2,y2:integer; TLColor,BRColor,FillColor,Style:byte); {Obdelnik s vyplni a dvojbarevnym obrysem. x1,y1,x2,y2 - souradnice vrcholu (na poradi nesejde, prekontroluje se) TLColor - barva obrysu vlevo a nahore (Top/Left) BRColor - barva obrysu vpravo a dole (Bottom/Right) FillColor - barva vyplne Style - funguji vsechny rezimy (nezapomente na _filled, jestli ho chcete vyplneny)} procedure __MaskedBox(x1,y1,x2,y2:integer; TLColor,BRColor:byte; FillColors:word; Style:byte; var Mask); {Vysledek je podobny jako u Boxu, ale vnitrek se kresli procedurou MaskedBar. Style - _outline = jen obrysy _filled = vnitrek vyplneny vzorkem _xor funguje jenom na okraje, vzorek se xorovat neda} procedure __Triangle(x1,y1,x2,y2,x3,y3:integer; Color,Style:byte); {Trojuhelnik. Styly funguji vsechny.} procedure __Polygon(var VertexList; NumberOfVertices:word; Color,Style:byte); {Mnohouhelnik s obecnym poctem vrcholu. VertexList - seznam vrcholu ve tvaru x1,y1,x2,y2,x3,y3 atd., souradnice jsou typu integer. Procedura ho vidi pres tuhle sablonu: } type _VertexArray=array[1..16382] of record x,y:integer; end; { Pouzijte bud primo tenhle typ, nebo nejake stejne usporadane pole. NumberOfVertices - pocet vrcholu. Teoreticke maximum je 16382 (vetsi pole se souradnicemi nejde alokovat), minimum je 1. Color, Style - jako obvykle. Pozn.: vyplneny mnohouhelnik se kresli jako "vejir" trojuhelniku se spolecnym vrcholem v prvnim bode seznamu. U nekonvexnich mnohouhelniku si proto davejte pozor, aby pomyslna spojnice prvniho bodu s libovolnym jinym nikde neprotinala obrys obrazce.} procedure _Fill(Color:word); procedure __Fill(Color:word); {Vyplni celou obrazovku danou barvou. _Fill vyplnuje 64bitove a je vic nez dvakrat rychlejsi nez __Fill, ktera je obycejny 32bitovy Bar pres cele orezavaci okno.} procedure __FloodFill(x,y:integer; Color,BorderColor:word); {Rozlije barvu Color po obrazovce pocinaje v bode x,y (ktery musi lezet uvnitr orezavaciho okna, jinak procedura nic nedela). Hranice jsou okraj okna a puvodni obsah obrazovky v zavislosti na parametru BorderColor: 0..255 - procedura funguje jako Floodfill z jednotky Graph, barva se volne preleva pres cokoli, zarazi se jedine o BorderColor. 256..65535 - procedura funguje jako plechovka ve windowsovskem Malovani, barva se rozleva po jednobarevne oblasti a zarazi se o jakoukoli jinou barvu. Pozn.: floodfill je dost pomaly, protoze vola spoustu Getpixelu. Nehodi se proto pro animace v realnem case.} (****************************** Bitmapy: ************************************) procedure _GetImage(x1,y1,x2,y2:word; Target:pointer); {Nacte obdelnikovy vyrez obrazovky do pameti - podobne jako Getimage z BGI. Nacitana oblast nesmi zasahovat mimo obrazovku (pokud ano, nactou se kraviny), orezavaci okno se ignoruje. Ukazatel Target musi ukazovat na predem pripravenou alokovanou pamet (tam se nacteny obrazek ulozi). Pokud ma hodnotu nil, procedura nic nedela a hned skonci, zadne jine kontrolni mechanismy nema. Potrebne mnozstvi pameti se spocita jako sirka*vyska obrazku (1 pixel = 1 B, informace o rozmerech se neukladaji), obrazova data jsou v pameti usporadana po radcich zleva doprava a odshora dolu. X1,y1 je levy horni roh, x2,y2 pravy dolni (pri vypnute blbuvzdornosti to nesmite prohodit).} procedure __PutImage(x1,y1:integer; Width,Height:word; Source:pointer); {Zobrazi obdelnikovy obrazek. X1,y1 jsou souradnice leveho horniho rohu, Width a Height jsou sirka a vyska v pixelech (spatne zadane rozmery zpusobi rozhozeni obrazku). Parametr Source je ukazatel na prislusna graficka data, format dat je stejny jako u _Getimage. Procedura je optimalizovana pro co nejvetsi rychlost (64 b).} procedure __PutTImage(x1,y1:integer; Width,Height:word; Source:pointer); {Podobny jako Putimage, ale vynechava pixely s barvou 0 (pruhlednost). Rychlost nic moc, kresli se po jednotlivych bytech.} procedure __PutRTImage(x1,y1:integer; Width,Height:word; Source:pointer); {Jako PutTImage, ale obrazek kresli zrcadlove prevraceny (leva <-> prava).} function _GetSprite(x1,y1,x2,y2:integer; Target:pointer; MaxSize:word; TransparentColor:byte):boolean; {Nacte z obrazovky obrazek specialnim zpusobem - rovnou vynechava pruhledne oblasti, takze zabere min pameti a da se mnohem rychleji zobrazovat. x1,y1 - levy horni roh prohledavane oblasti x2,y2 - pravy dolni roh prohledavane oblasti Target - ukazatel na predem alokovane misto, do ktereho se nacteny obrazek ulozi MaxSize - sem zadejte, jak velke to alokovane misto je, resp. kolik mista v nem jste ochotni funkci poskytnout - velikost obrazku totiz nejde spocitat predem TransparentColor - ktera barva na obrazovce se ma behem nacitani brat jako pruhledna (a tedy nenacitat) Pokud se obrazek podari nacist cely, funkce vrati true. Pokud ne (tedy pokud by jeho velikost presahla zadanou hodnotu MaxSize), bude nactena jenom cast (teoreticky zobrazitelna) a vrati se false. Vysledna velikost nacteneho obrazku v bytech je ulozena na zacatku Target^ ve formatu word (tento word se do velikosti pocita). Tento udaj lze pouzit pro prekopirovani obrazku do nove promenne s presnou velikosti, ulozeni do souboru apod..} procedure __PutSprite(x,y:integer; Source:pointer); {Zobrazi pruhledny obrazek ziskany vyse uvedenou funkci. Protoze je obrazek ulozen jako seznam souvislych radku a ne jako obdelnikova bitmapa, vykresluje se tim nejrychlejsim, co mame na sklade (64/32b).} procedure __FillSprite(x,y:integer; Source:pointer; Color:byte); {Zobrazi jednobarevny flek v barve Color a tvaru daneho pruhledneho obrazku.} (******************************* Texty: *************************************) {datovy typ pro nacitani a uchovavani fontu (pisma):} type _Font = record GlyphHeight, {vyska pisma v radcich (bytech)} StdXScale,StdYScale,StdPitch:byte; {doporucene parametry ulozene v souboru s fontem (vodorovne meritko, svisle meritko, roztec)} GlyphData:pointer; {ukazatel na obrazky jednotlivych znaku} end; procedure _LoadFont(var Target:_font; var Source:file); {Nacte font ze souboru. Target - promenna, do ktere se ma font nacist. Pripadnou chybu nacitani poznate podle polozky target.glyphdata: pokud bude nil, nacteni se nepovedlo. Source - beztypovy soubor otevreny prikazem Reset(source,1), kurzor v nem musi byt na zacatku fontu. Po nacteni bude kurzor za koncem fontu (krome pripadu, kdy doslo k chybe - pak muze skoncit kdekoli) a soubor zustane otevreny (font si tedy muzete zakombinovat do nejakeho viceuceloveho datoveho souboru). Proceduru nepouzivejte na jiz nactene fonty (zustaly by ztracene v pameti)!! Format souboru s fontem je popsan na konci teto jednotky.} procedure _LoadFont2(var Target:_font; FileName:string); {Take nacita font, ale soubor se ji zadava jmenem. Procedura si ho otevre, precte a pak zase zavre. Jednodussi na pouziti, ale da se pouzit jen pro soubory obsahujici pouze samotny font. Opet nepouzivat na jiz nactene fonty!} function _SaveFont(var Source:_font; FileName:string):boolean; {Ulozi font do souboru (jmeno piste i s koncovkou); vraci true, pokud se to povede. Smysl ma asi jenom v editorech fontu.} procedure _DisposeFont(var f:_font); {Vymaze font z pameti a promennou f pro kontrolu vyplni nulami. Nepouzivejte na font, ktery jeste nebyl nacteny, vynulovany nebo jinak inicializovany, doslo by k pokusu o dealokaci nealokovane pameti a program by spadl.} procedure _SetFont(var f:_font; SetDefaults:boolean); {Vybere font pro psani procedurou __Print (viz dale). Promennou f je potreba zachovat, protoze se na ni pouze napichnou interni ukazatele, ale graficka data se nikam fyzicky nekopiruji. SetDefaults - true => Nastavi se doporucene parametry textu (meritko a roztec), ktere byly s fontem ulozene v souboru. Doporucena hodnota pro vetsinu pripadu. false => Meritko a roztec zustanou tak, jak byly nastavene puvodne.} procedure _SetTextScale(XScale,YScale,Pitch:byte); {Nastavi meritko pisma pro proceduru __Print. XScale, YScale - meritko pisma pro vodorovny a svisly smer (technicky vzato rozmery jednoho bodu pisma) Pitch - roztec dvou sousednich znaku (od leveho kraje jednoho po levy kraj druheho); obvykle byva rovna sirce znaku vynasobene vodorovnym meritkem, ale neni to povinne Kdyz do nektereho parametru date nulu, zustane zachovana jeho puvodni hodnota (napr. _settextscale(0,3,0) zmeni pouze vysku).} procedure _SetTextJustify(xJustify,yJustify:byte); {Nastavi zarovnani pisma pro proceduru __Print, tj. na kterou stranu od referencniho bodu se ma vypsany text umistit. xJustify - vodorovne: 0 = vlevo (vychozi), 1 = na stred, 2 = vpravo yJustify - svisle: 0 = dolu, 1 = na stred, 2 = nahoru (vychozi) Hodnoty odpovidaji konstantam LeftText, CenterText, RightText, BottomText a TopText z jednotky Graph.} {Parametry pisma jsou ulozene v nasledujicich promennych:} var __XScale,__YScale,__Pitch:word; __xJustify,__yJustify:byte; {Puvodne byly mysleny jako interni, ale obcas je potreba je cist. Psat kvuli tomu specialni proceduru by bylo zbytecne tezkopadne, tak je nechavam verejne. (pozn.: typ word je nutny jenom kvuli assembleru, pouziva se bytovy rozsah)} {Casto je potreba neco napsat nejakym druhem pisma a pak se vratit k tomu, co bylo nastavene puvodne. Aby se nemusely vsechny parametry ukladat po jednom rucne, mame tu nasledujici tri procedury:} procedure _PushTextSettings; procedure _PopTextSettings; procedure _LoadTextSettings; {Prvni ulozi vsechny parametry pisma (meritko, roztec, zarovnani a ukazatel na font) do pameti. Druha je obnovi a z pameti smaze. Treti je obnovi, ale v pameti je necha. Pamet je zasobnik typu LIFO (co ulozite jako posledni, to pujde ven jako prvni), ukladat tedy muzete opakovane a pak se postupne vracet k predchozim verzim.} procedure __Print(X,Y:integer; Color,Style:byte; Message:string); {Zobrazi na obrazovku jeden radek textu (podobne jeko Outtextxy). X,Y - souradnice, na kterych chceme text vykreslit, konecna poloha zavisi na aktualne nastavenem zarovnani (_SetTextJustify) Style - _filled nema vliv, _xor funguje normalne Message - text k zobrazeni Nasledujici odstavec popisuje rozsirene moznosti teto procedury. Pokud se nechcete zabyvat nicim slozitym (treba kdyz tuhle jednotku vidite poprve), muzete ho bez obav preskocit. Do zobrazovaneho retezce se daji vkladat specialni ridici kody. Vzdycky zacinaji retezcem '%%', pak nasleduje jeden hlavni znak a pak urcity pocet cislic - parametru. Jsou delane maximalne blbuvzdorne, tj. pri jakekoli chybe se proste zobrazi jako normalni text a nevznikne zadny problem. Vsechny dale uvedene sekvence znaku '#' znamenaji obycejne desitkove cislo, pocet krizku udava pocet cifer (ten je nutne presne dodrzet; pokud je cislo kratsi, musi se na zacatku doplnit nulami, jinak ho procedura povazuje za chybny kod). Seznam vsech kodu: %%b### - nastavi barvu textu od tohoto mista dal. ### je triciferne cislo barvy (000..255). %%B - obnovi puvodni barvu (jaka byla zadana parametrem procedury) %%z### - misto tohoto kodu zobrazi znak s ordinalnim (ASCII) cislem ###. Vhodne napr. kdyz chcete zobrazit znaky ze zacatku ASCII tabulky, ktere z textovych souboru nejdou cist klasicky pres Readln. %%x### - posune pomyslny "kurzor" o dany pocet pixelu vlevo (pak musi byt prvni cifra cisla '-') nebo vpravo. Napr. %%x+83, %%x215, %%x-04. %%y### - obdobne posouva "kurzor" nahoru (-) nebo dolu (+). %%Y - nastavi yovou souradnici "kurzoru" zpet na hodnotu zadanou parametrem procedury. %%r### - nastavi roztec pisma (v pixelech) od tohoto mista dal. %%R - obnovi puvodni roztec, jaka byla nastavena pred volanim procedury %%h### - nastavi vodorovne meritko pisma (h jako horizontalni). Zarovnava se doleva. Neovlivni roztec, tu si musite nastavit zvlast. %%v### - nastavi svisle (vertikalni) meritko. Zarovnava se nahoru. %%H, %%V - obnovi puvodni meritka, jaka byla nastavena pred volanim procedury. %%0 - obnovi puvodni hodnoty uplne vseho krome posunu ve smeru x (tj. barvu, souradnici y, roztec a obe meritka). Po skonceni procedury budou automaticky obnoveny parametry textu, ktere byly nastavene puvodne. Pokud z nejakeho duvodu potrebujete ridici sekvence vyradit z provozu, zmente hodnotu tehle promenne:} const _ControlCodes:byte=1; {Mozne hodnoty jsou:} _Use=1; {kody pouzivat, ridit se podle nich} _Print=2; {nepouzivat, zobrazit je jako prosty text} _Skip=3; {nepouzivat ani nevypisovat} {Nekdy je potreba dynamicky nastavovat pri zobrazovani textu jeho meritko. To se obvykle provede rucnim prepocitanim a prenastavenim velikosti a roztece. Ciselne hodnoty zadane ridicimi kody primo v textu ale nejsou zvenku pristupne, proto tu mame tuto promennou:} const _ControlCodeScale:word=100; {Urcuje meritko cisel v procentech. Plati pro vsechny kody krome %%b a %%z.} procedure _MeasureText(Message:string); {Projde dany retezec znak po znaku a spocita jeho rozmery (v pixelech) s ohledem na aktualni nastaveni parametru pisma a zpusob vyhodnocovani ridicich kodu. Nastavi hodnotu techto verejnych globalnich promennych:} var _Width,_Height:word; {celkova sirka a vyska retezce od nejzazsiho leveho okraje po pravy a od horniho po dolni} _DeltaX,_DeltaY:integer; {Tohle prictete k souradnicim, na kterych chcete text zobrazit, a vyjde vam nejzazsi leva a horni souradnice okraju textu. Pokud se text nikam neposune pomoci ridicich kodu nebo zarovnani, jsou obe tyto hodnoty nulove.} {Jestli ridici kody nepouzivate, staci na vypocet rozmeru tyhle jednoduche funkce:} function _TextWidth(NumberOfChars:byte):word; function _TextHeight:word; {Sirka textu se pocita z poctu znaku, roztece a vodorovneho meritka, vyska z vysky fontu a svisleho meritka (nezavisi na poctu znaku).} (*************************** Virtualni obrazovka: ***************************) {Graficka karta ma obvykle mnohem vic pameti, nez kolik zabere jedna obrazovka. Zbytek VRAM pokracuje dale dolu pod viditelnou cast monitoru a da se do ni normalne kreslit (pripadne ji vyuzit jako odkladiste dat, i kdyz vyrazne pomalejsi nez RAM nebo XMS). Neviditelna cast VRAM se da zviditelnit tak, ze nad ni posuneme pocatek zobrazeni monitoru:} procedure _SetDisplayOrigin(x,y:word); {Nastavi polohu leveho horniho rohu monitoru nad videopameti (VRAM). Vychozi poloha po zapnuti grafiky je 0,0. Hybat obrazovkou do stran celkem nema smysl, za levym a pravym okrajem se zobrazi jenom pretekly obsah z protilehleho okraje. Posun nahoru a dolu je ovsem sikovna vec - umoznuje strankovani:} procedure _SetActivePage(PageNumber:byte); {Vybere stranku videopameti, na kterou se ma presmerovat veskere kresleni. Stranka c. 0 zacina na absolutni souradnici 0,0, stranka 1 na 0,_maxy+1 atd.} procedure _SetVisualPage(PageNumber:byte); {Posune pocatek zobrazeni nad danou stranku, takze se objevi na monitoru.} {V praxi se vetsinou pouzivaji dve stranky: jedna je videt a do druhe mezitim kreslime dalsi fazi animace. Kdyz mame dokresleno, stranky prohodime. Pro jednoduchost na to mame tyhle dve jednoucelove procedury, nic jineho obvykle neni potreba (pro uplnost: jednotka pouziva stranky 0 a 1):} procedure _TogglePaging; {Prepina mezi normalnim a strankovanym rezimem kresleni. Viditelna stranka zustava vzdy na miste, presouva se jenom ta aktivni (kreslici).} procedure _Swap; {Prohodi aktivni a viditelnou stranku, takze se zobrazi to, co jste dosud nakreslili. Ma zabudovane cekani na synchronizacni impuls obrazovky (viz nize), takze nezpusobuje poblikavani obrazu.} {Protoze _Togglepaging strankovani zapina i vypina, hodi se neco na pamatovani, v jakem rezimu zrovna jsme, a neco na nouzovy navrat:} var _PagingActive:boolean; {Nastavuje se automaticky pri togglu, true znamena zapnute strankovani.} procedure _ResetPages; {Nastavi aktivni i viditelnou stranku na 0.} {Videopameti je obvykle habadej, ale teoreticky muzete narazit i na vyjimku. Pred prvnim zapnutim strankovani si proto radeji zkontrolujte tuto promennou:} var _VirtualScreenAvailable:boolean; {True, pokud je pri aktualnim rozliseni dost pameti aspon na jednu neviditelnou stranku. Nastavuje se automaticky pri spusteni grafiky.} {Obraz se na monitoru neobjevuje okamzite, z VRAM se kopiruje postupne po radcich. Jak na starych vakuovych obrazovkach (CRT), kde beha elektronovy paprsek, tak na novych LCD, kde se postupne plni radky pixelu. Pokud primo na viditelnou stranku nakreslite nejaky obrazec, neni jiste, ze se zobrazi hned cely najednou - mozna pod nim jeste problikne pozadi. Jedina sance, kdy nic neproblikava, je, kdyz se s kreslenim trefite presne do synchronizacniho impulsu obrazovky, tedy do okamziku, kdy se vykreslovaci paprsek vraci od posledniho radku zpatky nahoru. Ten impuls se da detekovat:} procedure _VSync; {Ceka na synchronizacni impuls obrazovky. Muze se ovsem stat, ze impuls uz probiha, vy se trefite nekam doprostred a v tom zbytku uz moc nestihnete.} procedure _VSyncStart; {Ceka na zacatek synchronizacniho impulsu. Kdyby uz probihal, pocka na zacatek pristiho, takze mate vzdy zarucenou celou delku. Take to ale znamena, ze obcas budete cekat cely cyklus obrazovky navic (cca 17 ms). Jediny pripad, kdy ma smysl synchronizaci pouzivat, je prepinani stranek: presun pocatku zobrazeni je dost rychly na to, aby se vesel do delky impulsu. Jakekoli kresleni je moc pomale.} (************************ Rizeni spotreby monitoru: *************************) {(PM = power management)} procedure _SetPMMode(mode:byte); {Nastavi obrazovku do daneho rezimu. Mozne hodnoty jsou:} const _On=0; {zapnuto} _Standby=1; {prvni usporny rezim (opetovne zapnuti je rychle)} _Suspend=2; {druhy usporny rezim (o neco uspornejsi, opetovne zapnuti trva dele)} _Off=4; {uplne vypnuto, sviti uz jenom kontrolka} _ReducedOn=8; {asi nejaky tmavsi obraz, pry to je pro ploche obrazovky} function _GetPMMode:byte; {Vraci kod rezimu, v jakem se zrovna monitor nachazi. Pokud se test nepovede, vraci nulu (_On).} function _GetAllPMModes:byte; {Vraci kody vsech rezimu, do kterych se monitor da prepnout (soucet vyse uvedenych kodu; jednotliva cisla z nej lovte po bitech). V pripade neuspechu vraci nulu.} implementation(**************************************************************) uses errmsg, {kvuli chybovym hlaskam - lze zrusit a vyresit jinak, ale bude to pracnejsi} klavesy2, {jen pro pripadne cteni odpovedi uzivatele pri startu grafiky - lze vyradit a prepsat to na automat} cfg; {pro ukladani a nacitani obnovovaci frekvence do souboru - lze zrusit} type PoleWordu=array[0..1000] of word; {na horni mezi nezalezi, stejne je to jenom sablona pro ukazatel} UkNaPoleWordu=^polewordu; {pomocne typy} T_VESAInfo = record {navratovy buffer na informace o rozhrani VESA} Signature:array[0..3] of char; {'VESA' nebo 'VBE2', kdyz je vsechno v poradku} Version:word; {cislo verze VESA rozhrani; v hornim bytu je ta cislice pred teckou, v dolnim ta za teckou} OEMId:pointer; {ukazatel na jmeno karty (retezec zakonceny znakem #0)} Flags:longint; {ruzne atributy} ModeList:uknapolewordu; {ukazatel na seznam dostupnych rezimu (pole je ukonceno hodnotou $FFFF)} VideoMemory:word; {velikost VRAM [64KB bloku], od VESA verze 1.1} zbytek:array[1..492] of byte; end; P_VESAinfo = ^T_VESAInfo; var _PuvodniRezim:byte; {sem se ulozi cislo rezimu, v jakem se obrazovka nachazela pred spustenim programu (obvykle 3)} Granularity:word; {Granularita znamena, o kolik KB dal zacina nasledujici banka. Tohle uz je prepocitana hodnota, kterou kdyz vynasobime cislo banky spocitane beznym zpusobem, vyjde skutecne cislo banky, ktere muzeme poslat na grafarnu.} _CteciSegment,_ZapisovaciSegment, {segmentove adresy oken, obvykle $A000} _CteciOkno,_ZapisovaciOkno:word; {cisla oken pro cteni a zapis (obvykle obe 0 (A), ale nektere karty pouzivaji na cteni B)} CurBank:word; {aktualni banka} __SwitchBank:pointer; {adresa procedury pro prepinani bank pod VESA} __LHy:word; {automaticky se pricita k yove souradnici vseho, co se kresli (kvuli strankovani)} {pro rastrove texty (__Print a spol.):} __Vyska:word; {vyska fontu (pocet radku kazdeho znaku)} procedure Chcipni(NaCo:byte);{pomocna procedura pro zobrazovani chybovych hlasek, abych je nemusel vypisovat vickrat} var txt:string; Begin case NaCo of 0:txt:='Vase graficka karta nema VESA rozhrani, ktere je pro spusteni tohoto programu potreba. /' +' Your graphic card doesn''t support VESA interface needed by this program.'; 1:txt:='Neni dost zakladni pameti na pomocny buffer. / Not enough memory for a temporary buffer.'; 2:txt:='Vase graficka karta nepodporuje pozadovany rezim. / Your graphic card doesn''t support the desired graphic mode.'; 3:txt:='Nepodarilo se spustit pozadovany graficky rezim. / The desired graphic mode couldn''t be started.'; end; chyba(txt,0); End;{chcipni} const _NeniVESA=0; {hodnoty parametru pro tuto proceduru} _MaloPameti=1; _RezimNepujde=2; _NeselSpustit=3; procedure _NouzovySwitchbank; far; assembler; {nouzovka pro pripad, kdy od karty nedostaneme adresu bankovaci procedury} Asm int $10 {nastaveni registru je stejne jako pro tu specialni proceduru} End;{_nouzovyswitchbank} procedure _OkoukniVesu; {zjisti par dulezitych informaci o rozhrani VESA, vola se automaticky pri startu programu} var VESAInfo:P_VESAInfo; vysledek:word; Begin if maxavail$004F)or((VESAInfo^.Signature<>'VESA')and(VESAInfo^.Signature<>'VBE2')) then chcipni(_nenivesa); with vesainfo^ do begin _vesaversion:=version; _vgacompatible:=(flags and 2)=0;{predbezne (hodnota se aktualizuje pri spusteni grafiky)} _8bitpalette:=(flags and 1)<>0; end; dispose(vesainfo); End;{_okouknivesu} procedure _SetMode(mode:word); {nejdelsi a nejkomplikovanejsi procedura, kterou v teto jednotce najdete :-)} type t_ModeInfo = record {buffer na informace o rezimu} {pro vsechny verze rozhrani VESA:} Atributy:word;{par dulezitych bitu: bit 0: 1 = hardware tento rezim zvladne 1: jsou pritomne rozsirene informace (pro VESA 1.2 a vyssi je vzdy 1) 2: podporovan vystup pres BIOS 3: 0 = cernobily, 1 = barevny 4: 0 = textovy, 1 = graficky od verze 2.0: 5: 0 = VGA kompatibilni, 1 = ne 6: 0 = bankovani podporovano, 1 = ne 7: LFB podporovano 8: podporovan double scan (= radky se kresli nadvakrat; nutne pro nizka rozliseni, kdy jsou pixely moc vysoke a vykreslovaci paprsek moc tenky) od verze 3.0: 9: moznost prokladaneho rezimu (= zobrazuji se jen liche radky nebo tak nejak) 10: podporovan hardwarovy triplebuffering 11: hardware zvladne stereoskopicke zobrazeni (jsou na to potreba specialni LCD bryle) 12: podporovana zdvojena adresa pocatku zobrazeni 13..15: rezervovano} AtributyOknaA:byte;{bit 0: okno existuje 1: da se z nej cist 2: da se do nej zapisovat 3..7: rezervovano} AtributyOknaB:byte;{-''-} Granularita:word;{o kolik KB se posune okno, kdyz prepneme na dalsi banku (zivotne dulezita hodnota)} VelikostOkna:word;{[KB]} SegmentOknaA:word;{v real modu prakticky vzdy $A000} SegmentOknaB:word; BankovaciProcedura:pointer;{dulezita procedura na prepinani bank} BytuNaRadek:word;{kolik je celych bytu na radek (v bankovanych rezimech)} {pro VBE 1.2 a vyssi (pro nizsi verze pouze pokud bit 1 v atributech je 1):} RozliseniX:word; {\ rozmery obrazovky v pixelech,} RozliseniY:word; {/ je treba zkontrolovat } SirkaZnaku, VyskaZnaku:byte; PocetBitovychRovin:byte;{pro 256 barev je to 1} BituNaPixel:byte;{pro 256barevne rezimy 8, tohle zkontrolujeme} PocetBank:byte; PametovyModel:byte;{0 = textak 1 = CGA 2 = HGC 3 = 16barevna EGA 4 = packed pixel (bezna 256barevna grafika, ve ktere tato jednotka pracuje) 5 = "sequ 256" (non-chain 4) graphics 6 = direct color (hicolor nebo truecolor) 7 = YUV 8..15 - rezervovano 16..255 - specialni OEM modely} VelikostBanky:byte;{[KB], obvykle 64} PocetStranek:byte;{kolik stranek se vejde do VRAM (tato hodnota je o 1 mensi nez skutecnost)} Rezervovano1:byte; {pro pametove modely 6 (direct color) a 7 (YUV):} VelikostCerveneMasky:byte;{[b]} PoziceCervene:byte;{pozice LSB cervene masky} VelikostZeleneMasky:byte; PoziceZelene:byte; VelikostModreMasky:byte; PoziceModre:byte; VelikostRezervovaneMasky:byte; PoziceRezervovane:byte; AtributyDirectcoloru:byte; {pro VBE 2.0 a vyssi:} FyzickaFlatAdresa:longint; Rezervovano2:longint; Rezervovano3:word; {pro VBE 3.0 a vyssi:} BytuNaRadek_LFB:word; PocetStranek_BankovaneRezimy:byte; PocetStranek_LFB:byte; VelikostCerveneMasky_LFB:byte; PoziceCervene_LFB:byte; VelikostZeleneMasky_LFB:byte; PoziceZelene_LFB:byte; VelikostModreMasky_LFB:byte; PoziceModre_LFB:byte; VelikostRezervovaneMasky_LFB:byte; PoziceRezervovane_LFB:byte; MaxPixelClock:longint;{maximalni zobrazovaci frekvence [pixelu/s] (mel by to byt dword)} Zbytek:array[1..190] of byte;{doplnek do nutnych 256 B} end; p_ModeInfo = ^t_modeinfo; t_CRTCInfo = record {casovaci tabulka pro nastavovani frekvence} HorizontalTotal:word; {pro podrobnosti viz proceduru SpocitejCRTC} HorizontalSyncStart:word; HorizontalSyncEnd:word; VerticalTotal:word; VerticalSyncStart:word; VerticalSyncEnd:word; Flags:byte; PixelClock:longint; RefreshRate:word; zbytek:array[0..39] of byte; end; p_CRTCInfo = ^t_crtcinfo; var vesainfo:p_vesainfo; modeinfo:p_modeinfo; crtcinfo:p_crtcinfo; {----------------------------------------------------------------------------} function _ZjistiMaxFrekvenci(rezim,f:word):word; {Vraci bud hodnotu obnovovaci frekvence monitoru v Hz vetsi nebo rovnou zadane frekvenci f, nebo 0, kdyz nic nenajde.} type tEDIDinfo = record {informace o monitoru, ktere se daji ziskat pres DDC (pokud ho ten monitor podporuje)} rezervovano1:array[0..7] of byte; KodVyrobce:word; {tripismenny kod vyrobce: bity 14..10 daji prvni pismeno, bity 9..5 druhe a 4..0 treti (1 = A, 2 = B atd.).} TypMonitoru:word; {kod modelu monitoru} SerioveCislo:longint; {cislo monitoru (oficialne dword)} TydenVyroby:byte; RokVyroby:byte; {0 = 1990, 1 = 1991 atd.} CisloVerzeEDID:byte; CisloRevizeEDID:byte; TypVstupu:byte;{bity 0: oddelena synchronizace 1: sdruzena synchronizace 2: synchronizace podle zelene 4-3: nevyuzito 6-5: urovne napeti: 00 = 0.700V/0.300V 01 = 0.714V/0.286V 10 = 0.100V/0.400V 11 - rezervovano 7: 0 = analogovy signal, 1 = digitalni} SirkaMonitoru, {\ v centimetrech } VyskaMonitoru:byte;{/ } GammaFaktor:byte; {skutecna hodnota gammy je (GammaFaktor/100)+1} MoznostiDPMS:byte;{bity 0..2: nevyuzito 3: typ zobrazeni: 1 = barevny, RGB 0 = barevny, specialni ne-RGB 4: neyuzito 5: 1 = podporovan rezim "off" 6: 1 = podporovan rezim "suspend" 7: 1 = podporovan rezim "standby"} ChromaInfo:array[1..10] of byte; {netusim, k cemu to je} MozneFrekvence:word;{bit 0: 720x400, 70 Hz (VGA 640x400, IBM) (1 = podporovano) 1: 720x400, 88 Hz (XGA2) 2: 640x480, 60 Hz (VGA) 3: 640x480, 67 Hz (Mac II, Apple) 4: 640x480, 72 Hz (VESA) 5: 640x480, 75 Hz (VESA) 6: 800x600, 56 Hz (VESA) 7: 800x600, 60 Hz (VESA) 8: 800x600, 72 Hz (VESA) 9: 800x600, 75 Hz (VESA) 10: 832x624, 75 Hz (Mac II) 11: 1024x768, 87 Hz prokladany (8514A) 12: 1024x768, 60 Hz (VESA) 13: 1024x768, 70 Hz (VESA) 14: 1024x768, 75 Hz (VESA) 15: 1280x1024, 75 Hz (VESA)} MozneFrekvence2:byte;{bit 7: 1152x870, 75 Hz (Mac II, Apple)} MozneFrekvence3: array[1..8] of record rozliseni:byte;{vodorovne rozliseni = (tohle+31)*8} frekvence:byte;{bity 0..5: obnovovaci frekvence [Hz] zmensena o 60 6..7: pomer stran (vyska/sirka): 01 = 0.75 (3:4) 10 = 0.8 11 = 0.5625 (9:16)} end;{kdyz jsou obe hodnoty 0 nebo 1, pak dana standardni frekvence neexistuje} PodrobneInfo:array[1..4] of array[0..17] of byte; {tady muzou byt bud dalsi podrobnosti ohledne obnovovacich frekvenci (viz tDTDinfo) nebo ruzne textove informace (viz tTIinfo)} rezervovano2:byte; KontrolniSoucet:byte; {dolni byte z 16bitoveho souctu vsech predchozich bytu v celem tomto zaznamu} end; pEDIDinfo = ^tedidinfo; tDTDinfo = record {jeden mozny tvar polozek pole PodrobneInfo v typu tEDIDinfo} HorizFrek:byte;{[kHz]} VertFrek:byte;{[Hz]} HorizAktivniCas:byte;{[px], vodorovne rozliseni (netusim, jak se to ma do toho bytu vejit)} HorizNeaktivniCas:byte;{[px]} HorizAktivniCas2:byte;{[px]} VertAktivniCas:byte;{[px]} VertNeaktivniCas:byte;{[px]} VertAktivniCas2:byte;{[px]} HorizSyncOfset:byte;{[px]} HorizSyncSirka:byte;{[px]} VertSyncOfset:byte;{[px]} Ofset_sirka2:byte;{[px]} SirkaObrazu:byte;{[mm]} VyskaObrazu:byte;{[mm]} Rozmer2:byte;{???} VodorovnyOkraj:byte;{[px]} SvislyOkraj:byte;{[px]} TypZobrazeni:byte;{bity 7: 1 = prokladany (interlaced) 6-5: stereoskopicky: 00 = normalni, bez sterea 01 = stereo, synchronizace podle obrazku pro prave oko 10 = stereo, synchronizace podle obrazku pro leve oko 11 neni definovano 4-3: typ synchronizace: 00 = analogova sdruzena 01 = analogova sdruzena bipolarni 10 = digitalni sdruzena 11 = digitalni oddelena 2: pro typ synchronizace 11: polarita vertikalni synchronizace (0 = -, 1 = +) pro vsechny ostatni typy: stridava (serrate) polarita vert. synchronizace 1: pro typ synchronizace 11: polarita horizontalni synchronizace (0 = -, 1 = +) pro vsechny ostatni typy: okamzik synchronizace (0 = podle zelene, 1 = RGB) 0: asi nevyuzito} end; tTIinfo = record {druhy mozny tvar polozek pole PodrobneInfo v typu tEDIDinfo} identifikace:array[1..3] of char;{kdyz jsou vsechny tyto 3 B nulove, je to TI, jinak to je DTD} case CoToJe:byte of{urcuje, jake informace budou nasledovat: $FF = seriove cislo $FE = jmeno prodejce $FD = rozsah frekvenci (jedina vec, kterou nyni vyuzijeme) $FC = jmeno monitoru (modelu)} $FD:(rezervovano1:byte;{obvykle hodnota 0} MinVertFrek:byte;{minimalni vertikalni obnovovaci frekvence [Hz]} MaxVertFrek:byte;{maximalni -"-} MinHorizFrek:byte;{minimalni horizontalni obnov. frekvence [kHz]} MaxHorizFrek:byte;{maximalni -"-} rezervovano2:byte);{obvykle hodnota $FF} $FF,$FE,$FC:(NejakyText:array[1..14] of char);{ukonceny je bud znakem #0 nebo #10} end; var EDIDinfo:pedidinfo; maxf,tmp:word; i:byte; Begin _zjistimaxfrekvenci:=0;{jestli skoncime predcasne, tohle tu zustane} if f=0 then exit; {nacteni informaci z monitoru pres DDC kanal:} if maxavail$004F then begin {$ifdef debug}writeln('Monitor nezvlada DDC, nelze nacist informace o podporovanych frekvencich.');{$endif} dispose(edidinfo); exit; end; {Udaje o monitoru jsou nacteny, jdeme najit vhodnou frekvenci. Nejdriv ji zkusime najit v prislusne tabulce (beru v uvahu pouze plnohodnotne VESA rezimy a frekvence nad 60 Hz):} maxf:=0; with edidinfo^ do case rezim of _640x480:if (moznefrekvence and 32)<>0 then maxf:=75 else if (moznefrekvence and 16)<>0 then maxf:=72; _800x600:if (moznefrekvence and 512)<>0 then maxf:=75 else if (moznefrekvence and 256)<>0 then maxf:=72; _1024x768:if (moznefrekvence and 16384)<>0 then maxf:=75 else if (moznefrekvence and 8192)<>0 then maxf:=70; end; {$ifdef debug} write('V prvni tabulce '); if maxf=0 then writeln('nebyla zadna vhodna frekvence nalezena.') else writeln('byla nalezena frekvence ',maxf,' Hz.'); {$endif} if maxf=f then begin {jestli uz to staci, tak berem a konec...} _zjistimaxfrekvenci:=tmp; {$ifdef debug}writeln('Naslo se ',tmp,' Hz.');{$endif} exit; end else if tmp>maxf then maxf:=tmp; {...jinak dal hledame maximum} end; end; {$ifdef debug} write('Po prohledani druhe tabulky '); if maxf=0 then writeln('stale zadnou vhodnou frekvenci nemame.') else writeln('mame frekvenci ',maxf,' Hz.'); {$endif} end; {Posledni kontrola - mezni frekvence:} for i:=1 to 4 do with ttiinfo(edidinfo^.podrobneinfo[i]) do if (identifikace=#0#0#0)and(cotoje=$FD) then begin if maxfmaxvertfrek then maxf:=maxvertfrek; {$ifdef debug}writeln('Max. frekvence monitoru je ',maxvertfrek,' Hz.');{$endif} break; end; {ted uz to jenom nejak shrnout a vyhodnotit:} if maxf<60 then maxf:=0; {to uz radsi vychozi frekvenci (tohle se snad ani nemuze stat)} dispose(edidinfo); _zjistimaxfrekvenci:=maxf; End;{_zjistimaxfrekvenci} {----------------------------------------------------------------------------} function JeToOn(rezim:word; var buffer:t_modeinfo):boolean; {nacte informace o rezimu a vrati true, pokud je to ten hledany} var vysledek:word; Begin {$ifdef debug}writeln('Kontroluji rezim c. ',rezim,'...');{$endif} jetoon:=false; fillchar(modeinfo^,256,0); {vynulujeme zasobnik (starsi verze VESA to za nas neudelaji)} asm mov AX,$4F01 {sluzba "zjisti informace o rezimu"} mov CX,rezim {o kterem rezimu} les DI,buffer {pripravime zasobnik} int $10 mov vysledek,AX end; if vysledek=$4F then with buffer do begin jetoon:=((atributy and 25)=25){je to barevny graficky rezim a hardware ho zvladne} and ((atributy and 64)=0){funguje v nem bankovani} and (((atributyoknaA and 1)<>0) or((atributyoknaB and 1)<>0)){existuje presouvatelne okno (cili opet: funguje bankovani)} and (((atributy and 2)=0) or ((rozlisenix=_maxx+1)and(rozliseniy=_maxy+1)and(bitunapixel=8))); {bud mame VBE 1.0 nebo 1.1 a budeme doufat, ze to vyjde, nebo mame novejsi a pak si zkontrolujeme rozliseni a barevnou hloubku} _vgacompatible:=(atributy and 32)=0; if granularita=0 then granularity:=1 else granularity:=64 div granularita;{prepocitani granularity na pouzitelnou hodnotu} {(pozn.: granularitA je polozka infa a granularitY je globalni promenna)} if bankovaciprocedura=nil then begin __switchbank:=@_nouzovyswitchbank; {kdyz to nejde jinak, pouzijeme int $10} {$ifdef debug}writeln('Na bankovani se pouzije int 10h.');{$endif} end else __switchbank:=bankovaciprocedura; {urceni zapisovaciho a cteciho okna a segmentu:} if (atributyoknaA and 5)=5 then begin {okno A existuje a da se do nej zapisovat} _zapisovaciokno:=0; _zapisovacisegment:=segmentoknaA; end else if (atributyoknaB and 5)=5 then begin {okno B existuje a da se do nej zapisovat} _zapisovaciokno:=1; _zapisovacisegment:=segmentoknaB; end else begin {zadne z obou oken neni pouzitelne (to se snad vubec nemuze stat)} _zapisovacisegment:=$A000; _zapisovaciokno:=0; {vychozi hodnoty - tim se snad nic nezkazi} {$ifdef debug}writeln('Nebylo nalezeno okno pro zapis do VRAM, pouzije se vychozi nastaveni.');{$endif} end; if (atributyoknaA and 3)=3 then begin {okno A existuje a da se z nej cist} _cteciokno:=0; _ctecisegment:=segmentoknaA; end else if (atributyoknaB and 3)=3 then begin {okno B existuje a da se z nej cist} _cteciokno:=1; _ctecisegment:=segmentoknaB; end else begin _ctecisegment:=$A000; _cteciokno:=0; {$ifdef debug}writeln('Nebylo nalezeno okno pro cteni z VRAM, pouzije se vychozi nastaveni.');{$endif} end; {$ifdef debug} writeln('Zapisovaci okno: segment = ',_zapisovacisegment:5,', cislo = ',_zapisovaciokno); writeln('Cteci okno: segment = ',_ctecisegment:5,', cislo = ',_cteciokno); {$endif} end; End;{jetoon} {----------------------------------------------------------------------------} procedure SpocitejCRTC(var buffer:t_crtcinfo; rezim:word);{vypocita casovaci tabulku pro nastaveni frekvence} {const xadjust=0; yadjust=0; {netusim, k cemu jsou (tuhle proceduru jsem nevymyslel), ale funguje to i bez nich} var HSWidth,VSWidth:word; SS,SE:word; doublescan:boolean; xres,yres:word; pc:record l,h:word; end;{emulace dwordu, ktera umozni 32bitovou praci v 16bitovem prekladaci} Begin xres:=_maxx+1; yres:=_maxy+1; doublescan:=yres<400; {moderni monitory maji ostrejsi paprsek, ktery nedokaze vykreslit tak vysoke pixely...} if doublescan then yres:=yres*2; {...takze je musi kreslit nadvakrat => potrebujeme dvojnasobnou obnovovaci frekvenci} with buffer do begin {Priznam se, ze tyhle vypocty nejsou moje dilo a ne vse jsem pochopil. Zkusim se podelit aspon o zaklady. +-+-+-+-+-+>+-+-+-+-+-+-+-+-+ <- Tohle je zjednoduseny nakres monitoru. V +-+-+-+-+-+-+-+>+-+-+-+-+-+-+ Vy#ovana oblast je to, co vidite S >+-+-#-#-#-#-#-#-#-#-#-#-#-+-+ (pozadovanych 800x600 apod.). Vy+ovany E +-+-#-#-#-#-#-#-#-#-#-#-#-+-+ zbytek je okraj, ktery se nezobrazuje. +-+-#-#-#-#-#-#-#-#-#-#-#-+-+ Zamerovace elektronoveho paprsku ho jenom +-+-#-#-#-#>#-#-#-#-#-#-#-+-+ naprazdno prejizdeji. Pomlckami jsou V +-+-#-#-#-#-#-#-#-#-#-#-#-+-+ vyznaceny radky. To, jestli zrovna S >+-+-#-#-#-#-#-#-#-#-#-#-#-+-+ paprsek sviti nebo nesviti, se urcuje S +-+-+-+-+-+-+>+-+-+-+-+-+-+-+ signaly Horizontal sync a Vertical sync. +-+-+-+-+-+-+-+-+-+-+-+-+-+-+ Kdyz jsou oba na nule, paprsek sviti. ^ ^ Horizontal total a Vertical total jsou HSE HSS rozmery cele plochy, kterou zamerovaci civky obsahnou (v pixelech), vcetne okraju, kde je paprsek vypnuty. Horizontal sync start je okamzik (vlastne misto, opet v pixelech), kdy paprsek dorazi doprava na konec zobrazovane plochy, nahodi se signal H. sync a paprsek se vypne. Horizontal sync end je okamzik (souradnice), kdy paprsek na levem okraji vstupuje do zobrazovane oblasti, signal H. sync konci a paprsek se rozsviti. Horizontal sync width je doba (vzdalenost) mezi H. s. start a H. S. end, tedy kdy paprsek nesviti. Podobne je to s hodnotami Vertical sync start, end a width. V oblasti horniho a dolniho okraje se H. sync prepina naprazdno a paprsek je stejne porad vypnuty, protoze je zapnuty V. sync (a to je presne ta doba zvana "navrat paprsku" (vertical retrace), na kterou se ceka, kdyz se zobrazuji nejake animovane veci z virtualni obrazovky). Vsechny tyto rozmery se pocitaji vicemene odhadem: ve vodorovnem smeru je sirka okraje cca 27% viditelne plochy, ve svislem cca 7%. Zbyle pricitani konstant, nulovani nejnizsich bitu a podobne jde mimo moje chapani (asi by to chtelo nejaky podrobnejsi manual). Pixel clock je frekvence, s jakou paprsek prejizdi jednotlive pixely (takze jednotka je pixel za sekundu), radove megahertzy. Je to asi nejdulezitejsi udaj o frekvenci. Horizontalni obnovovaci frekvence rika, kolik radku za sekundu se vykresli (radove kilohertzy). Vertikalni obnovovaci frekvence znamena, kolik se vykresli obrazovek za sekundu (radove desitky Hz), a to je presne to, co chceme mit ve vysledku vetsi nez tech vychozich blikavych 60 Hz a kvuli cemu celou tuhle saskarnu provadime :-).} horizontaltotal:=round(xres*1.27) and not 7; HSWidth:=round((horizontaltotal-xres)/5) and not 7; HorizontalSyncStart:=xres+16; HorizontalSyncEnd:=HorizontalSyncStart+HSWidth; VerticalTotal:=round(yres*1.07); VSWidth:=round(VerticalTotal/100)+1; VerticalSyncStart:=yres+round((VerticalTotal-yres)/5)+1; VerticalSyncEnd:=VerticalSyncStart+VSWidth; SS:=HorizontalSyncStart{+xadjust}; SE:=HorizontalSyncEnd{+xadjust}; { if xadjust<0 then begin if SS0)and(longint(pc)>modeinfo^.maxpixelclock) {^^tahle podminka je tu pro pripad, ze by longint pretekl az do zaporna (mel by to byt dword)} then begin {$ifdef debug}writeln('Pozadovana frekvence (pixel clock) je prilis velka - pouzije se vychozi.');{$endif} _refreshfrequency:=0; exit; end; asm mov AX,$4F0B {sluzba "najdi nejblizsi frekvenci"} xor BX,BX db $66; mov CX,pc.l {= mov ECX,dword ptr pc ($66 je prefix, ktery rika, ze se ma kopirovat 32 bitu)} mov DX,rezim int $10 db $66; mov pc.l,CX {= mov dword ptr pc,ECX} mov se,AX {promennou SE uz nebudu potrebovat, tak ji vyuziju jako pomocnou} end; if se=$4F then begin pixelclock:=longint(pc); refreshrate:=_refreshfrequency*100; {v setinach Hz} end else begin _refreshfrequency:=0; {$ifdef debug}writeln('Nebyla nalezena vhodna frekvence (pixel clock), pouzije se vychozi.');{$endif} end; end; End;{spocitejCRTC} {----------------------------------------------------------------------------} function SpustHo(rezim:word; var crtc:t_crtcinfo):word; assembler; {spusti graficky rezim, vraci $4F pri uspechu} Asm mov CX,_refreshfrequency {na test, jestli je to nula nebo ne} mov AX,$4F02 {sluzba "nastav rezim"} mov BX,rezim {cislo rezimu} or CX,CX {je to nula?} jz @VychoziFrekvence {ano => frekvenci neresime} or BX,2048 {tenhle bit rika, ze se ma nastavit uzivatelska frekvence} les DI,crtc @VychoziFrekvence: xor CX,CX {pro jistotu} int $10 {navratova hodnota funkce = AX} End;{spustho} {----------------------------------------------------------------------------} var kon:konfigurace; i:integer; Begin{_setmode} case mode of _Textmode:begin {ukonceni grafiky a navrat do puvodniho rezimu obrazovky} asm xor AH,AH mov AL,_puvodnirezim {normalne by to melo byt cislo 3 (textak 80x25x16), ale jeden nikdy nevi...} int $10 {jina, asi rovnocenna moznost: mov AX,$4F02 mov BX,_puvodnirezim int $10} end; _maxx:=79; {jen tak pro poradek} _maxy:=24; {$ifdef debug}writeln('Graficky rezim ukoncen.');{$endif} exit; end; {pripravime si rozliseni:} _640x350:begin _MaxX:=639; _MaxY:=349; end; _640x400:begin _MaxX:=639; _MaxY:=399; end; _640x480:begin _MaxX:=639; _MaxY:=479; end; _800x600:begin _MaxX:=799; _MaxY:=599; end; _1024x768:begin _MaxX:=1023; _MaxY:=767; end; end; {pripravime konfiguracni soubor:} kon.init; kon.vybersekci('[VESA]'); kon.definujpolozku('frekvence',@_RefreshFrequency,_word); {pripravime navratove zasobniky:} if maxavail neni co resit} {$ifdef debug}writeln('Obnovovaci frekvence jde nastavovat az od verze 3.0, u vas tedy ne.');{$endif} end else begin {OK, grafarna to umi => podivame se, co chce nastavit uzivatel} {nacteni drive ulozene frekvence ze souboru:} {$ifdef debug} writeln('Zkousim nacist frekvenci z konfiguracniho souboru ',cfgsoubor); writeln('Pred: f=',_refreshfrequency); {$endif} kon.nacti(cfgsoubor); {$ifdef debug} writeln('Po: f=',_refreshfrequency); {$endif} end; if _refreshfrequency<>0 then begin {pokud mame zadanou frekvenci, zkontrolujeme, jestli ji monitor zvladne} i:=_zjistimaxfrekvenci(mode,_refreshfrequency); if i=0 {cteni DDC se nepovedlo...} then begin {...ale je sance, ze frekvence pujde nastavit (jestli tu jsme, tak urcite mame VESA 3+)} writeln; writeln('Vas monitor bud nema rozhrani DDC nebo nebyla nalezena zadna vhodna'); writeln('obnovovaci frekvence, kterou by zvladal.'); writeln('Dalsi postup je na vas, stisknete prislusnou klavesu:'); writeln; writeln('Enter - pouzit vychozi frekvenci adapteru (bezpecne, ale je to jen 60 Hz)'); writeln('R - presto zkusit nastavit zadanou frekvenci ',_refreshfrequency,' Hz'); writeln(' POZOR, jen pokud jste si jisti, ze to vas monitor snese!!!'); writeln('Esc - okamzity konec programu'); writeln; writeln; writeln('Your monitor doesn''t support DDC interface or no suitable refresh'); writeln('frequency has been found.'); writeln('Now it''s up to you, choose and press a key:'); writeln; writeln('Enter - use default frequency (always safe, but it''s only 60 Hz)'); writeln('R - try to use the specified frequency of ',_refreshfrequency,' Hz'); writeln(' WARNING - only if you are sure your screen can handle it!!!'); writeln('Esc - abort the program immediately'); writeln; kresetuj; repeat i:=xreadkey; until i in [13,27,82,114]; case i of 13:begin {$ifdef debug}writeln('Vychozi frekvence nastavena.');{$endif} _refreshfrequency:=0; end; 27:begin {$ifdef debug}writeln('Program ukoncen.');{$endif} halt; end; {$ifdef debug}else writeln('Dobra, jedeme dal.');{$endif} end; end else _refreshfrequency:=i; {OK, frekvence byla pres DDC nalezena (nebo nalezena nebyla a je 0)} {jeste jedna kontrola:} if modeinfo^.maxpixelclock=0 then begin {$ifdef debug}writeln('ModeInfo.MaxPixelClock=0 => pouzije se vychozi frekvence.');{$endif} _refreshfrequency:=0; end; end; {spocitame casovaci tabulku:} if _refreshfrequency<>0 then spocitejCRTC(crtcinfo^,mode); {$ifdef debug} if _refreshfrequency<>0 then begin writeln(' Rekapitulace vypoctu frekvence:'); writeln('pozadovana frekvence = ',_refreshfrequency,' Hz'); writeln(' (pokud je 0, znamena to vychozi frekvenci adapteru;'); writeln(' nasledujicich hodnot si v takovem pripade nevsimejte)'); writeln('modeinfo.MaxPixelClock = ',modeinfo^.maxpixelclock,' Hz'); writeln('crtcinfo.PixelClock = ',crtcinfo^.pixelclock,' Hz'); writeln('crtcinfo.RefreshRate = ',crtcinfo^.refreshrate,' setin Hz'); end; writeln; writeln('Esc = konec programu, cokoli jineho = pokracovat,'); kresetuj; if readkey=#27 then halt; {$endif} if spustho(mode,crtcinfo^)<>$4F then if _refreshfrequency<>0 then begin _refreshfrequency:=0; {$ifdef debug} writeln('Start grafiky se zadanou frekvenci se nepovedl, zkusime to jeste s vychozi.'); {$endif} if spustho(mode,crtcinfo^)<>$4F then chcipni(_neselspustit); end else chcipni(_neselspustit); _virtualscreenavailable:=(longint(vesainfo^.videomemory)shl 16)div((longint(_maxx)+1)*(_maxy+1))>=2; dispose(modeinfo); dispose(vesainfo); dispose(crtcinfo); _setdefaultwindow; curbank:=$FFFF; {po inicializaci by mela byt vzdy nastavena banka 0, ale co kdyby nebyla} {ulozeni skutecne nastavene frekvence pro priste:} kon.uloz(cfgsoubor); kon.zrus; End;{_setmode} procedure _SwitchBank(bank:word); assembler; {pouze pro zapisovaci okno!!!} Asm mov AX,bank {AX:=pozadovana banka} mov curbank,AX {ulozeni banky do globalni promenne} mul granularity {vynasobeni AX granularitou - ted je tam skutecne cislo banky} mov DX,AX {do DX s nim (__switchbank ho chce prave tam)} mov BX,_zapisovaciokno {podkod sluzby - "nastav banku" a cislo okna, do ktereho kreslime} mov AX,$4F05 {kod sluzby - "ovladani pristupu k obrazovce"} call __switchbank {do toho!} End;{_switchbank} procedure _SwitchRBank(bank:word); assembler; {pro cteci okno} Asm mov AX,bank mul granularity mov DX,AX mov BX,_cteciokno mov AX,$4F05 call __switchbank End;{_switchrbank} function _getbank:word; assembler; Asm mov AX,curbank {jednoduse opiseme prislusnou globalni promennou} End;{_switchbank} {v AX se vrati vysledek} function _getrbank:word; assembler; {promenna Curbank plati pouze pro zapisovaci okno, u cteciho musime banku zjistit "poctive", volanim prislusne VESA sluzby:} Asm mov AX,$4F05 {kod sluzby - "ovladani pristupu k obrazovce"} mov BX,_cteciokno {do BL kod cteciho okna} or BX,$0100 {do BH kod podsluzby "zjisti banku"} call __switchbank {do toho!} mov AX,DX {v DX se nam vratilo cislo banky} xor DX,DX {DX bude vyssi word delence, tak musi byt 0} div granularity {vydelime AX granularitou; v DX zustane zbytek, ale ten nas nezajima} End;{_switchbank} {v AX se vrati vysledek} procedure xchange(var a,b:integer); assembler; {prohodi dva integery} Asm push DS lds SI,a {nacteni ukazatelu na promenne} les DI,b mov AX,DS:[SI] {nacteni hodnot promennych} mov BX,ES:[DI] mov DS:[SI],BX {ulozeni hodnot v obracenem poradi} mov ES:[DI],AX pop DS End;{xchange} function ClipLine(var x1,y1,x2,y2:integer):boolean; {Orizne souradnice cary podle okna. Vraci true, pokud z cary zbyl aspon kousek, ktery by sel zobrazit.} var otoceno:boolean; Begin otoceno:=false; repeat if (x1>=_minclipx)and(x1<=_maxclipx)and (x2>=_minclipx)and(x2<=_maxclipx)and (y1>=_minclipy)and(y1<=_maxclipy)and (y2>=_minclipy)and(y2<=_maxclipy) then begin {cara je urcite cela v okne => OK, muzeme kreslit} clipline:=true; break; end; if (x1<_minclipx)and(x2<_minclipx)or (x1>_maxclipx)and(x2>_maxclipx)or (y1<_minclipy)and(y2<_minclipy)or (y1>_maxclipy)and(y2>_maxclipy) then begin {cara je urcite cela mimo okno => OK, neni co kreslit} clipline:=false; break; end; {Existuji pripady, kdy predchozi podminka rekne, ze cara neni venku, ale pritom ve skutecnosti venku je. To ale nevadi - cara se trochu zkrati a v pristim cyklu uz bude jasne, ze je opravdu venku, a skonci se.} if x1<_minclipx then begin {1 vycuhuje vlevo} y1:=y1+longint(y2-y1)*(_MinClipX-x1)div(x2-x1); {deleni nulou se nemusime bat, protoze kdyby ted bylo x2=x1, musela by byt obe x mimo okno, coz by ale odchytila predchozi podminka a uz bychom tady nebyli} x1:=_MinClipX; end else if y1<_minclipy then begin {1 vycuhuje nahore} x1:=x1+longint(x2-x1)*(_MinClipY-y1)div(y2-y1); y1:=_MinClipY; end else if x1>_maxclipx then begin {1 vycuhuje vpravo} y1:=y1+longint(y2-y1)*(_MaxClipX-x1)div(x2-x1); x1:=_MaxClipX; end else if y1>_maxclipy then begin {1 vycuhuje dole} x1:=x1+longint(x2-x1)*(_MaxClipY-y1)div(y2-y1); y1:=_MaxClipY; end else begin {Bod 1 nevycuhuje, takze vycuhuje jenom bod 2. Abychom nemuseli psat dalsi ctyri podminky pro bod 2, radsi oba body prohodime.} xchange(x1,x2); xchange(y1,y2); otoceno:=not otoceno; end; {Mohli bychom napsat ty ctyri podminky tak, ze by se v jednom cyklu provedlo veskere orezavani najednou? Ne. Vypada to sice, ze bychom tak usetrili par pruchodu cyklem, ale ve skutecnosti by to nefungovalo. Mohlo by se totiz stat, ze by se cara zkratila podle x a hned potom zase protahla podle y a vysla by nekonecna smycka. Proto je nutne, aby se po kazdem "rezu" zkontrolo- valo, jestli uz cara neni venku z okna.} until false; {konci se Breakem} if otoceno then begin {u maskovane cary je potreba, aby se kreslila od spravneho konce, proto tohle} xchange(x1,x2); xchange(y1,y2); end; End;{clipline} procedure _PutPixel(x,y:word; color,style:byte);assembler; Asm mov AX,__lhy mov DX,_zapisovacisegment add y,AX {pro virtualni obrazovku} mov ES,DX {ES = segment pro videopamet} mov AX,_MaxX inc AX {AX = sirka obrazovky} mul y {vynasob AX ypsilonem; co pretece, dej do DX} add AX,x {k AX pricti x} adc DX,0 {jestli AX preteklo, zvys hodnotu DX} {vysledek: v AX je ofset bodu, v DX cislo banky} mov DI,AX {ofset ulozime do registru k tomu urcenemu} {ted se postarame o bankovani:} cmp DX,CurBank {neni nahodou potrebna banka uz nastavena?} je @neprepinej {je -> nebudeme se zdrzovat prepinanim} mov curbank,DX {rozepsana procedura _switchbank} mov AX,DX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank @neprepinej: mov AL,color test style,_xor jz @normal xor byte ptr ES:[DI],AL {xorove vykresleni} jmp @konec @normal: mov ES:[DI],AL {normalni vykresleni} @konec: End;{_putpixel} procedure __PutPixel(x,y:integer; color,style:byte); Begin if (x>=_MinClipX)and(x<=_MaxClipX)and(y>=_MinClipY)and(y<=_MaxClipY) then _putpixel(x,y,color,style); End;{__PutPixel} function _GetPixel(x,y:word):byte; assembler; Asm mov AX,__lhy mov DX,_ctecisegment add y,AX mov ES,DX mov AX,_MaxX inc AX mul y add AX,x adc DX,0 mov CX,_cteciokno mov DI,AX cmp CX,_zapisovaciokno jne @prepni {pokud nejsou obe okna stejna, nemusi promenna Curbank platit => prepneme vzdy} cmp DX,CurBank je @neprepinej mov curbank,DX @prepni: mov AX,DX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_cteciokno call __switchbank @neprepinej: mov AL,ES:[DI] End;{_getpixel} function __GetPixel(x,y:integer):byte; Begin if x<_minclipx then x:=_minclipx else if x>_maxclipx then x:=_maxclipx; if y<_minclipy then y:=_minclipy else if y>_maxclipy then y:=_maxclipy; __getpixel:=_GetPixel(x,y); End;{__getpixel} procedure _HLine(x1,x2,y:word; color:word); assembler; var count:word; Asm {$ifdef blbuvzdornost} {jestli x1>x2, prohodime je} mov AX,x1 cmp AX,x2 js @OK mov AX,x1 mov BX,x2 mov x2,AX mov x1,BX @OK: {$endif} {Nasledujici usek je optimalizovan pro paralelni zpracovani instrukci na Pentiich (starsim procesorum, ktere to neumi, to nepomuze ani neuskodi):} mov AX,__lhy; mov DX,color add y,AX; {pro virtualni obrazovku} mov DH,DL mov AX,_zapisovacisegment; mov color,DX {barva ma ted hodnotu barvy v dolnim i hornim bytu} mov ES,AX; {ES = cilovy segment} mov BX,x2 mov AX,_MaxX; sub BX,x1 inc AX; inc BX mul y; mov count,BX {count = pocet pixelu (delka cary)} add AX,x1 adc DX,0 {DX = pocatecni banka} mov DI,AX {DI = ofset zacatku cary} cmp DX,CurBank je @neprepinej mov curbank,DX mov AX,DX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank mov AX,DI @neprepinej: {pocatecni banka nastavena} mov BX,count dec BX add AX,BX {AX = ofset konce cary} jnc @najednou {kdyz se vejdeme do jedne banky, jdeme dal...} {...jinak vyplnime nejdriv konec prvni banky:} mov CX,$FFFF sub CX,DI inc CX {CX = pocet pixelu v prvni bance} mov AX,count sub AX,CX mov count,AX {count = pocet pixelu ve druhe bance} mov AX,color db $66; shl AX,16 mov AX,color {EAX ma ted v kazdem bytu hodnotu barvy} mov BX,CX shr CX,2 and BX,3 db $66; rep stosw {= rep stosd, kopiruje se po 4 bytech} mov CX,BX rep stosb {prekopirovani zbylych max. 3 bytu} {v posledni iteraci DI preteklo a je v nem 0, coz presne chceme} inc curbank mov AX,curbank mul granularity {__switchbank obcas necha v DX nejakou kravinu, tak musime znova nasobit a nejde jenom pricist granularitu} mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank {a jsme o banku dal} @najednou: mov CX,count {CX = pocet pixelu (ve druhe bance nebo cele cary)} mov AX,color db $66; shl AX,16 mov AX,color {EAX = barva} mov BX,CX shr CX,2 and BX,3 db $66; rep stosw mov CX,BX rep stosb End;{_hline} procedure _XorHLine(x1,x2,y:word;color:word); assembler; var count:word; Asm {$ifdef blbuvzdornost} {jestli x1>x2, prohodime je} mov AX,x1 cmp AX,x2 js @OK mov AX,x1 mov BX,x2 mov x1,BX mov x2,AX @OK: {$endif} mov AX,__lhy add y,AX mov AX,color mov AH,AL mov color,AX mov AX,_zapisovacisegment mov ES,AX mov AX,x2 sub AX,x1 inc AX mov count,AX mov AX,_MaxX inc AX mul y add AX,x1 adc DX,0 mov DI,AX cmp DX,CurBank je @neprepinej mov curbank,DX mov AX,DX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank mov AX,DI @neprepinej: mov BX,count dec BX add AX,BX jnc @najednou mov CX,$FFFF sub CX,DI inc CX mov AX,count sub AX,CX mov count,AX mov AX,color db $66; shl AX,16 mov AX,color mov BX,CX shr CX,2 jz @nic1 {aby se nekreslilo nic, pokud CX=0 (o to se normalne stara Rep)} @smycka1: db $66; xor ES:[DI],AX {xorovani po dwordech} add DI,4 loop @smycka1 @nic1: and BX,3 mov CX,BX or CX,CX jz @nic2 @smycka2: xor byte ptr ES:[DI],AL {prexorovani zbylych max. 3 bytu} inc DI loop @smycka2 @nic2: inc curbank mov AX,curbank mul granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank @najednou: mov CX,count mov AX,color db $66; shl AX,16 mov AX,color mov BX,CX shr CX,2 jz @nic3 @smycka3: db $66; xor ES:[DI],AX add DI,4 loop @smycka3 @nic3: and BX,3 mov CX,BX or CX,CX jz @nic4 @smycka4: xor byte ptr ES:[DI],AL inc DI loop @smycka4 @nic4: End;{_xorhline} procedure __HLine(x1,x2,y:integer; color,style:byte); Begin if x1>x2 then asm {kontrola poradi xovych souradnic} mov AX,x1 mov BX,x2 mov x1,BX mov x2,AX end; if (y<_MinClipY)or(y>_MaxClipY)or(x1>_MaxClipX)or(x2<_MinClipX) then Exit; if x1<_MinClipX then x1:=_MinClipX; if x2>_MaxClipX then x2:=_MaxClipX; if style and _xor=0 then _HLine(x1,x2,y,color) else _xorHLine(x1,x2,y,color); End;{__hline} procedure _VLine(x,y1,y2:word; color,style:byte); assembler; var incr:word; Asm {$ifdef blbuvzdornost} {jestli y1>y2, prohodime je} mov AX,y1 cmp AX,y2 js @OK mov AX,y1 mov BX,y2 mov y2,AX mov y1,BX @OK: {$endif} mov BX,__lhy; mov CX,_zapisovacisegment add y1,BX; mov ES,CX add y2,BX mov AX,_MaxX inc AX mov incr,AX {incr = sirka obrazovky} mul y1 add AX,x adc DX,0 {DX = pocatecni banka} mov DI,AX {DI = pocatecni ofset} cmp DX,CurBank je @neprepinej mov AX,DX mov curbank,DX mul granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank @neprepinej: {pocatecni banka nastavena} mov AL,color test style,_xor jz @normalni1 xor byte ptr ES:[DI],AL jmp @PixelVykreslen1 @normalni1: mov ES:[DI],AL @PixelVykreslen1: {prvni pixel je nakreslen} mov CX,y2 sub CX,y1 {CX = pocet cyklu} jz @konec @cyklus: add DI,incr {DI = ofset dalsiho pixelu} jnc @PoradVJedneBance inc curbank mov AX,curbank mul granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank mov AL,color {do AL vratime barvu} @PoradVJedneBance: {spravna banka je nastavena} test style,_xor jz @normalni2 xor byte ptr ES:[DI],AL jmp @PixelVykreslen2 @normalni2: mov ES:[DI],AL @PixelVykreslen2: {dalsi pixel je nakreslen} loop @cyklus @konec: End;{_vline} procedure __VLine(x,y1,y2:integer;color,style:byte); Begin if y1>y2 then asm mov AX,y1 mov BX,y2 mov y1,BX mov y2,AX end; if (x<_MinClipX)or(x>_MaxClipX)or(y1>_MaxClipY)or(y2<_MinClipY) then Exit; if y1<_MinClipY then y1:=_MinClipY; if y2>_MaxClipY then y2:=_MaxClipY; _VLine(x,y1,y2,color,style); End;{__vline} procedure _line(x1,y1,x2,y2:word; color:byte; style:byte); var dx,dy,krokx,kroky:integer; pom:word; Begin {Bresenhamuv algoritmus obecne cary: K pomocne promenne pricitame hodnotu mensiho z rozdilu souradnic (dx nebo dy) a ridici promennou pri tom menime o 1. Jakmile pomocna promenna dosahne nebo presahne hodnotu vetsiho z rozdilu souradnic, ten vetsi rozdil od ni odecteme a zmenime o 1 i druhou souradnici. Na zacatku musi mit pomocna promenna hodnotu rovnou polovine toho vetsiho rozdilu souradnic, jinak by cara byla nesymetricka.} {Pokud vychazi cara vodorovna nebo svisla, pouzijeme z duvodu rychlosti radsi procedury pro vodorovnou nebo svislou caru, i kdyz Bresenhamuv algoritmus by fungoval i v techto pripadech (krok druhe souradnice by byl 0):} if x1=x2 then begin if y2>y1 then _vline(x1,y1,y2,color,style) else _vline(x1,y2,y1,color,style); exit; end; if y1=y2 then begin if x2>x1 then _hline(x1,x2,y1,color) else _hline(x2,x1,y1,color); exit; end; {vypocet rozdilu souradnic a kroku:} if x2>x1 then begin dx:=x2-x1; krokx:=1; end else begin dx:=x1-x2; krokx:=-1; end; if y2>y1 then begin dy:=y2-y1; kroky:=1; end else begin dy:=y1-y2; kroky:=-1; end; {Zadny rozdil souradnic urcite neni 0, protoze to by odchytily predchozi dve podminky a procedura by uz touhle dobou davno skoncila. Takze se ted o takovy pripad nemusime starat.} _putpixel(x1,y1,color,style); {prvni bod cary} if dx>=dy then begin {cara je spis vodorovnejsi, x je ridici promenna} pom:=dx shr 1; {pocatecni hodnota pomocne promenne} repeat inc(x1,krokx); {zmenime x o 1} inc(pom,dy); {pricteme k pomocne dy (mensi rozdil)} if pom>=dx then begin {kdyz je vesti nez dx (ten vetsi rozdil)...} dec(pom,dx); {...vetsi rozdil odecteme...} inc(y1,kroky); {...a zmenime y o 1} end; _putpixel(x1,y1,color,style); {nakreslime bod} until x1=x2; {dokud nejsme na koncovem bodu} end else begin {cara je spis svislejsi, ridici je y} pom:=dy shr 1; repeat {postup stejny, jen jsou prehozene souradnice} inc(y1,kroky); inc(pom,dx); if pom>=dy then begin dec(pom,dy); inc(x1,krokx); end; _putpixel(x1,y1,color,style); until y1=y2; end; End;{_line} procedure __Line(x1,y1,x2,y2:integer; color,style:byte); Begin if ClipLine(x1,y1,x2,y2) then _Line(x1,y1,x2,y2,color,style); End;{__line} procedure _MaskedLine(x1,y1,x2,y2:integer; color,style:byte; mask:word); var dx,dy,krokX,krokY:integer; pom:word; Begin {Tady uz se neda pouzit rychla vodorovna cara, takze pro vsechny pripady pouzijeme obecny Bresenhamuv algoritmus.} dx:=abs(x2-x1); dy:=abs(y2-y1); if x2x1 then krokx:=1 else krokx:=0; if y2y1 then kroky:=1 else kroky:=0; {prvni bod cary:} asm rol mask,1 {rotujeme masku o jeden bit doleva} jnc @dira1 {kdyz nenastalo preteceni, odrotovali jsme nulu, takze se nic nekresli} push x1 {ulozime prvni parametr pro _putpixel - x} push y1 {druhy parametr - y} push word ptr color {treti parametr - barva (na zasobnik jdou ukladat jen wordy, tak se musi pretypovat)} push word ptr style {ctvrty parametr - styl} call _putpixel {zavolame _putpixel} @dira1: end; if dx>=dy then begin pom:=dx shr 1; repeat inc(x1,krokx); inc(pom,dy); if pom>=dx then begin dec(pom,dx); inc(y1,kroky); end; asm rol mask,1 jnc @dira2 push x1 push y1 push word ptr color push word ptr style call _putpixel @dira2: end; until x1=x2; end else begin pom:=dy shr 1; repeat inc(y1,kroky); inc(pom,dx); if pom>=dy then begin dec(pom,dy); inc(x1,krokx); end; asm rol mask,1 jnc @dira3 push x1 push y1 push word ptr color push word ptr style call _putpixel @dira3: end; until y1=y2; end; End;{_maskedline} procedure __MaskedLine(x1,y1,x2,y2:integer; color,style:byte; Mask:word); var px1,py1:integer; Begin px1:=x1; py1:=y1; if ClipLine(x1,y1,x2,y2) then begin {jestli cara zacina za okrajem okna, musime posunout i masku:} if (px1<>x1)or(py1<>y1) then asm {az na zaverecne Rol neni assembler nutny, ale proc se nepocvicit :-)} mov CX,x1 sub CX,px1 jns @xKladne neg CX @xKladne: {CX = abs(x1-px1) = deltaX} mov DX,y1 sub DX,py1 jns @yKladne neg DX @yKladne: {DX = abs(y1-py1) = deltaY} cmp CX,DX jg @MamePosun mov CX,DX @MamePosun: {CX = max(deltaX,deltaY) = o kolik budeme masku posouvat} and CX,15 {maska ma 16 bitu, posouvat ji o vic nema smysl} rol mask,CL end; _MaskedLine(x1,y1,x2,y2,color,style,mask); end; End;{__maskedline} procedure __ThickLine(x1,y1,x2,y2:integer; Width:word; Color,Style:byte); var uhel,posun1,posun2:real; xA,yA,xB,yB,xC,yC,xD,yD,odx,dox:integer; y:longint; Begin if width=0 then exit; if width=1 then begin __line(x1,y1,x2,y2,Color,Style); exit; end; width:=width shr 1; {odtedka je to pulka} {pripadne kulate konce:} if style and _roundends<>0 then begin __ellipse(x1,y1,width,width,color,style); __ellipse(x2,y2,width,width,color,style); end; {specialni pripady:} if x1=x2 then begin {svisla} if (style and _roundends=0)or(style and _filled<>0) then __rectangle(x1-width,y1,x1+width,y2,color,style) else begin __vline(x1-width,y1,y2,color,style); __vline(x1+width,y1,y2,color,style); end; exit; end; if y1=y2 then begin {vodorovna} if (style and _roundends=0)or(style and _filled<>0) then __rectangle(x1,y1-width,x2,y2+width,color,style) else begin __hline(x1,x2,y1-width,color,style); __hline(x1,x2,y2+width,color,style); end; exit; end; {V obecne poloze je tlusta cara vlastne nakloneny obdelnik. Jeho rohy:} uhel:=arctan((y2-y1)/(x2-x1)); {pripad x2=x1 uz je odchyceny, deleni nulou nehrozi} posun1:=width*sin(uhel); posun2:=width*cos(uhel); xA:=round(x1-posun1); yA:=round(y1+posun2); xB:=round(x1+posun1); yB:=round(y1-posun2); xC:=round(x2-posun1); yC:=round(y2+posun2); xD:=round(x2+posun1); yD:=round(y2-posun2); {prazdny obrys jsou jenom cary z rohu do rohu:} if style and _filled=0 then begin __line(xa,ya,xc,yc,color,style); __line(xb,yb,xd,yd,color,style); if style and _roundends=0 then begin __line(xa,ya,xb,yb,color,style); __line(xc,yc,xd,yd,color,style); end; exit; end; {Vyplnenou variantu skladame z vodorovnych car interpolovanych mezi jednotlivymi vrcholy. Serazeni vrcholu podle y (zjednoduseny quicksort; na ctyri uplne libovolna cisla by nestacil, na vrcholy obdelnika ano):} if yA>yD then begin xchange(xA,xD); xchange(yA,yD); end; if yB>yC then begin xchange(xB,xC); xchange(yB,yC); end; if yA>yB then begin xchange(xA,xB); xchange(yA,yB); end; if yC>yD then begin xchange(xC,xD); xchange(yC,yD); end; {usek A..B (trojuhelnik nahore):} __putpixel(xa,ya,color,style); if yb>ya then for y:=yA+1 to yB do begin odx:=xa+(y-ya)*(xb-xa) div (yb-ya); dox:=xa+(y-ya)*(xc-xa) div (yc-ya); if doxyb then for y:=yb+1 to yc do begin odx:=xb+(y-yb)*(xd-xb) div (yd-yb); dox:=xa+(y-ya)*(xc-xa) div (yc-ya); if doxyc then for y:=yc+1 to yd do begin odx:=xb+(y-yb)*(xd-xb) div (yd-yb); dox:=xc+(y-yc)*(xd-xc) div (yd-yc); if dox0 then begin __HLine(centerX-x,centerX+x,centerY+y,color,style); __HLine(centerX-x,centerX+x,centerY-y,color,style); end else begin __PutPixel(centerx+x,centery+y,color,style); __PutPixel(centerx-x,centery+y,color,style); __PutPixel(centerx+x,centery-y,color,style); __PutPixel(centerx-x,centery-y,color,style); end; if d>0 then begin dec(y); dec(dy,tas); dec(d,dy); end; inc(x); inc(dx,tbs); d:=d+bs+dx; end; d:=d+((3*(as-bs) div 2-(dx+dy)) div 2); while y>0 do begin if style and _filled<>0 then begin __HLine(centerX-x,centerX+x,centerY+y,color,style); __HLine(centerX-x,centerX+x,centerY-y,color,style); end else begin __PutPixel(centerx+x,centery+y,color,style); __PutPixel(centerx-x,centery+y,color,style); __PutPixel(centerx+x,centery-y,color,style); __PutPixel(centerx-x,centery-y,color,style); end; if d<0 then begin inc(x); inc(dx,tbs); inc(d,dx); end; dec(y); dec(dy,tas); d:=d+as-dy; end; if style and _filled<>0 then __HLine(centerX-x,centerX+x,centerY,color,style) else begin __PutPixel(centerx+x,centery,color,style); __PutPixel(centerx-x,centery,color,style); end; End;{__ellipse} procedure _Bar(x1,y1,x2,y2,color:word); assembler; var sirka,incr:word; Asm {$ifdef blbuvzdornost} mov AX,x1 cmp AX,x2 js @xOK mov AX,x1 mov BX,x2 {jestli x1>x2, prohodime je} mov x1,BX mov x2,AX @xOK: mov AX,y1 cmp AX,y2 js @yOK mov AX,y1 mov BX,y2 {jestli y1>y2, prohodime je} mov y1,BX mov y2,AX @yOK: {$endif} mov AX,__lhy mov BX,_zapisovacisegment add y1,AX mov ES,BX {ES = cilovy segment} add y2,AX {pro virtualni obrazovku} mov BX,color inc y2 {aby se to pak lip pocitalo} mov BH,BL mov AX,_maxx mov color,BX {barva ma ted hodnotu v obou bytech} sub AX,x2 mov BX,x2 {*} add AX,x1 sub BX,x1 mov incr,AX {incr = kolik se musi pridat k ofsetu na konci radku, abychom se dostali na zacatek dalsiho} inc BX mov AX,_Maxx mov sirka,BX {sirka spocitana} inc AX mul y1 add AX,x1 adc DX,0 {DX = banka} mov DI,AX {DI = ofset zacatku radku} @zacatek: {zacatek cyklu} mov BX,DI mov CX,DX add BX,sirka adc CX,0 dec BX sbb CX,0 {CX = banka bodu na konci radku} cmp DX,curbank je @neprepinej push DX call _SwitchBank @neprepinej: {pocatecni banka nastavena} cmp CX,curbank {je banka na konci radku stejna jako na zacatku?} je @najednou {je -> vykresli se cely radek najednou} mov CX,$FFFF sub CX,DI inc CX {CX = sirka prvni casti} mov AX,sirka sub AX,CX push AX {zasobnik = sirka druhe casti} mov AX,color db $66; shl AX,16 mov AX,color {EAX = barva} mov BX,CX shr CX,2 db $66; rep stosw and BX,3 mov CX,BX rep stosb mov AX,curbank inc AX push AX call _switchbank {druha banka nastavena} pop CX jmp @jedeme @najednou: mov CX,sirka @jedeme: {CX = sirka zbytku radku} mov AX,color db $66; shl AX,16 mov AX,color {EAX = barva} mov BX,CX shr CX,2 db $66; rep stosw and BX,3 mov CX,BX rep stosb mov DX,curbank add DI,incr {DI = ofset zacatku dalsiho radku} adc DX,0 {DX = banka -''-} inc y1 mov AX,y1 cmp AX,y2 jne @zacatek End;{_bar} procedure __Bar(x1,y1,x2,y2:integer; Color,Style:byte); var i:integer; Begin asm mov AX,x1; cmp AX,x2 js @xOK mov AX,x1; mov BX,x2 mov x1,BX; mov x2,AX @xOK: mov AX,y1; cmp AX,y2 js @yOK mov AX,y1; mov BX,y2 mov y1,BX; mov y2,AX @yOK: end; if (x1>_MaxClipX)or(y1>_MaxClipY)or(x2<_MinClipX)or(y2<_MinClipY) then Exit; if x1<_MinClipX then x1:=_MinClipX; if y1<_MinClipY then y1:=_MinClipY; if x2>_MaxClipX then x2:=_MaxClipX; if y2>_MaxClipY then y2:=_MaxClipY; if style and _xor=0 then _bar(x1,y1,x2,y2,color) else for i:=y1 to y2 do _xorhline(x1,x2,i,color); End;{__bar} procedure _MaskedBar(x1,y1,x2,y2,colors:word; var mask); var i,sirka,sirka2:word; m:byte; pom:array[0..3] of word; {qword} poms,pomo:word;{segment a ofset pole pom} Begin {$ifdef blbuvzdornost} asm mov AX,x1 cmp AX,x2 js @xOK mov AX,x1 mov BX,x2 {jestli x1>x2, prohodime je} mov x1,BX mov x2,AX @xOK: mov AX,y1 cmp AX,y2 js @yOK mov AX,y1 mov BX,y2 {jestli y1>y2, prohodime je} mov y1,BX mov y2,AX @yOK: end; {$endif} poms:=seg(pom); pomo:=ofs(pom); {v asm mi to nejak neslo} sirka:=x2-x1+1; inc(y1,__lhy); inc(y2,__lhy); for i:=y1 to y2 do begin m:=_8bytearray(mask)[i and 7]; asm {vykresleni radku} mov CX,x1 and CX,7 rol m,CL {upraveni masky podle souradnic - aby navazovala} mov AX,poms mov DI,pomo {ES:DI = adresa pom} mov ES,AX mov CX,8 mov AX,colors {AL = barva popredi, AH = barva pozadi} @PripravaDat: rol m,1 jc @BarvaPopredi mov ES:[DI],AH {pixel v barve pozadi} jmp @KonecVyberuBarvy @BarvaPopredi: mov ES:[DI],AL {pixel v barve popredi} @KonecVyberuBarvy: inc DI loop @PripravaDat {ted je v Pom jeden radek masky, co byte, to pixel} mov BX,_zapisovacisegment mov ES,BX {ES = cilovy segment} mov AX,_Maxx inc AX mul i add AX,x1 adc DX,0 {DX = banka zacatku radku} mov DI,AX {DI = ofset zacatku radku} mov BX,DI mov CX,DX add BX,sirka adc CX,0 dec BX {BX = ofset bodu na konci radku} sbb CX,0 {CX = banka toho bodu} {ted je v DI ofset zacatku radku, v DX jeho banka a v BX a CX to same pro konec radku (ten ofset v BX nepotrebuju a stejne ho _Switchbank prepise)} cmp DX,curbank {prepnuti do banky pro zacatek radku} je @neprepinej push DX call _SwitchBank @neprepinej: cmp CX,curbank {je banka na konci radku stejna jako na zacatku?} je @najednou {je => hop dal ***} {neni => nakresli se prvni cast radku v prvni bance, pak se prepne o banku dal a nakresli se zbytek:} mov CX,$FFFF sub CX,DI inc CX {CX = pocet pixelu v prvni bance} mov AX,sirka sub AX,CX mov sirka2,AX {sirka2 = pocet pixelu ve druhe bance} {kresleni po qwordech (8 bytu najednou):} mov BX,CX shr CX,3 jz @nic1 @PoQwordech1: fild qword ptr pom {kopiruj pole na zasobnik koprocesoru} fistp qword ptr ES:[DI] {presun pole ze zasobniku na obrazovku} add DI,8 loop @PoQwordech1 @nic1: {zbytek po bytech:} mov DX,DS mov AX,colors mov CX,BX and CX,7 push CX {schovat na potom} mov AX,poms mov DS,AX mov SI,pomo rep movsb mov DS,DX {v posledni iteraci DI preteklo a je v nem 0, coz presne chceme} inc curbank push curbank call _switchbank {prepnuti o banku dal (DI je 0, takze budeme kreslit na zacatek dalsi banky)} {odrotovani masky, aby druha cast radku navazovala na prvni:} pop CX or CL,CL jz @NetrebaRotovati rol m,CL mov AX,poms mov ES,AX mov BX,pomo {ES:BX = adresa pom} mov AX,colors mov CX,8 @PripravaDat2: rol m,1 jc @BarvaPopredi2 mov ES:[BX],AH {pixel v barve pozadi} jmp @KonecVyberuBarvy2 @BarvaPopredi2: mov ES:[BX],AL {pixel v barve popredi} @KonecVyberuBarvy2: inc BX loop @PripravaDat2 mov AX,$A000 mov ES,AX @NetrebaRotovati: mov CX,sirka2 {CX = pocet pixelu ve druhe bance} jmp @jedeme @najednou: mov CX,sirka {CX = pocet pixelu} @jedeme: {kresleni:} mov BX,CX shr CX,3 jz @nic2 @PoQwordech2: fild qword ptr pom fistp qword ptr ES:[DI] add DI,8 loop @PoQwordech2 @nic2: mov DX,DS mov AX,colors mov CX,BX and CX,7 mov AX,poms mov DS,AX mov SI,pomo rep movsb mov DS,DX {radek je vykreslen} end; end; End;{_maskedbar} procedure __MaskedBar(x1,y1,x2,y2:integer; colors:word; var mask); var maska:_8bytearray; {lokalni kopie masky pro pripad, ze se bude muset pri orezu posouvat} posunX,posunY:word; {posun masky v pripade orezu vlevo nebo nahore} i:byte; Begin asm {kontrola poradi souradnic} mov AX,x1; cmp AX,x2 js @xOK mov AX,x1; mov BX,x2 mov x1,BX; mov x2,AX @xOK: mov AX,y1; cmp AX,y2 js @yOK mov AX,y1; mov BX,y2 mov y1,BX; mov y2,AX @yOK: end; if (x1>_MaxClipX)or(y1>_MaxClipY)or(x2<_MinClipX)or(y2<_MinClipY) then Exit; {orez souradnic a vypocet posunu masky:} if x1<_MinClipX then begin posunx:=(_minclipx-x1) and 7; x1:=_MinClipX; end else posunx:=0; if y1<_MinClipY then begin posuny:=(_minclipy-y1) and 7; y1:=_MinClipY; end else posuny:=0; if x2>_MaxClipX then x2:=_MaxClipX; if y2>_MaxClipY then y2:=_MaxClipY; {priprava masky:} if posuny=0 then maska:=_8bytearray(mask) else begin {rotace nahoru} move(_8bytearray(mask)[posuny],maska[0],8-posuny); move(mask,maska[8-posuny],posuny); end; if posunx<>0 then asm {rotace doleva} mov AX,SS mov ES,AX lea DI,maska {ES:DI->maska} mov CX,posunx mov DX,8 @cyklus: mov AL,[ES:DI] rol AL,CL stosb dec DX jnz @cyklus end; {a konecne vykresleni:} _maskedBar(x1,y1,x2,y2,colors,maska); End;{__maskedbar} procedure __Box(x1,y1,x2,y2:integer; TLColor,BRColor,FillColor,Style:byte); Begin asm mov AX,x1 cmp AX,x2 js @xOK mov AX,x1; mov BX,x2 mov x1,BX; mov x2,AX @xOK: mov AX,y1 cmp AX,y2 js @yOK mov AX,y1; mov BX,y2 mov y1,BX; mov y2,AX @yOK: end; __HLine(x1,x2,y1,tlcolor,style); __VLine(x1,y1,y2,tlcolor,style); __VLine(x2,y1,y2,brcolor,style); __HLine(x1,x2,y2,brcolor,style); if (style and _filled<>0)and(x2-x1>=2)and(y2-y1>=2) then __Bar(succ(x1),succ(y1),pred(x2),pred(y2),fillcolor,style); End;{__box} procedure __MaskedBox(x1,y1,x2,y2:integer; TLColor,BRColor:byte; FillColors:word; Style:byte; var Mask); Begin asm mov AX,x1 cmp AX,x2 js @xOK mov AX,x1; mov BX,x2 mov x1,BX; mov x2,AX @xOK: mov AX,y1 cmp AX,y2 js @yOK mov AX,y1; mov BX,y2 mov y1,BX; mov y2,AX @yOK: end; __HLine(x1,x2,y1,tlcolor,style); __VLine(x1,y1,y2,tlcolor,style); __VLine(x2,y1,y2,brcolor,style); __HLine(x1,x2,y2,brcolor,style); if (style and _filled<>0)and(x2-x1>=2)and(y2-y1>=2) then __maskedbar(succ(x1),succ(y1),pred(x2),pred(y2),fillcolors,mask); End;{__MaskedBox} procedure _Fill(color:word); assembler; var PrvniBanka, {na ktere bance obrazovka zacina} VelikostPrvni, {kolik B je v te prvni bance} PocetCelych, {kolik celych bank mezi prvni a posledni neuplnou budeme barvit} VelikostPosledni, {kolik B je v posledni neuplne bance na konci obrazovky} LHOfset:word; {ofset leveho horniho rohu obrazovky v prvni bance} barvy:array[0..3] of word; {qword} Asm {rozkopirovani barvy do 8 B a priprava segmentu VRAM:} mov AX,color mov AH,AL lea BX,barvy mov [SS:BX],AX mov [SS:BX+2],AX mov [SS:BX+4],AX; mov DX,_zapisovacisegment mov [SS:BX+6],AX; mov ES,DX {ES = segment pro videopamet} {kolik bank se vejde na obrazovku:} mov AX,_maxx; mov BX,_maxy inc AX; inc BX {AX=sirka, BX=vyska} mul BX {sirka*vyska: DX=pocet celych bank, AX=zbytek} mov prvnibanka,DX {\predbezne pro druhou stranku} mov lhofset,AX {/ } {na ktere strance jsme:} mov CX,__lhy or CX,CX jnz @DruhaStranka {Na prvni strance zaciname celou bankou a bud mame same cele (1024x768), nebo je posledni necela.} mov velikostprvni,CX {=0} mov prvnibanka,CX mov lhofset,CX jmp @VelikostiJsouSpocitane @DruhaStranka: {Na druhe strance zaciname bud druhou pulkou posledni neuplne banky z prvni stranky, nebo novou bankou (1024x768):} xor CX,CX {velikost cele banky (65536) bez nejvyssiho bitu} sub CX,AX {Bud je AX<>0, pak CX podteklo a je v nem spravna velikost. Nebo je AX=0 a pak je CX stale 0, coz je taky spravne} sbb DX,-1 {pri podteceni se pocet celych bank nemeni, ale jestli to nepodteklo, bude o jednu celou banku vic, tak musime DX zvysit o 1} mov velikostprvni,CX {A ted jak velka bude ta posledni neuplna banka. Ted mame DX=pocet celych bank a AX=velikost zbytku, cili DXAX=velikost cele obrazovky v B. DXAX-velikostprvni = DXAX-(65536-AX) = DXAX+AX-65536 = tohle:} add AX,AX adc DX,0 dec DX @VelikostiJsouSpocitane: mov pocetcelych,DX mov velikostposledni,AX {prepnuti do prvni banky:} mov BX,prvnibanka cmp BX,CurBank je @neprepinej push BX call _switchbank @neprepinej: {vyplneni prvni banky:} mov CX,velikostprvni or CX,CX jz @PrvniNeni mov DI,lhofset shr CX,3 @barveni1: fild qword ptr barvy fistp qword ptr [ES:DI] add DI,8 loop @barveni1 mov CX,velikostprvni and CX,7 mov AX,word ptr barvy rep stosb {rozepisovani na stosd a stosb je zbytecne, pouzije se to jenom dvakrat za celou proceduru} {na druhou banku:} inc curbank push curbank call _switchbank @PrvniNeni: {vyplneni celych bank:} @ProKazdouCelou: xor DI,DI mov CX,8192 {= 64 KB / sizeof(qword)} @barveni2: fild qword ptr barvy fistp qword ptr [ES:DI] add DI,8 loop @barveni2 inc curbank push curbank call _switchbank dec pocetcelych jnz @ProKazdouCelou {vyplneni posledni banky:} mov CX,velikostposledni or CX,CX jz @PosledniNeni xor DI,DI shr CX,3 @barveni3: fild qword ptr barvy fistp qword ptr [ES:DI] add DI,8 loop @barveni3 mov CX,velikostposledni and CX,7 mov AX,word ptr barvy rep stosb @PosledniNeni: End;{_fill} procedure __Fill(color:word); Begin _bar(_minclipx,_minclipy,_maxclipx,_maxclipy,color); End;{__fill} procedure __Rectangle(x1,y1,x2,y2:word; color,style:byte); Begin if y1>y2 then asm mov AX,y1 mov BX,y2 mov y1,BX mov y2,AX end; if style and _filled<>0 then __bar(x1,y1,x2,y2,color,style) else begin __hline(x1,x2,y1,color,style); if y2-y1>1 then begin {rohy musime vybarvit jenom jednou, aby pri xoru nemizely} __vline(x1,y1+1,y2-1,color,style); __vline(x2,y1+1,y2-1,color,style); end; __hline(x1,x2,y2,color,style); end; End;{__rectangle} procedure __Triangle(x1,y1,x2,y2,x3,y3:integer; Color,Style:byte); var ymin,xmin,ymid,xmid,ymax,xmax,xmid2:longint; i:integer; Begin {prazdny trojuhelnik jsou jenom tri cary:} if style and _filled=0 then begin __Line(x1,y1,x2,y2,color,style); __Line(x2,y2,x3,y3,color,style); __Line(x3,y3,x1,y1,color,style); exit; end; {S vyplni je to trochu slozitejsi. Serazeni vrcholu podle y:} if y1>y2 then begin xchange(y1,y2); xchange(x1,x2); end; if y1>y3 then begin xchange(y1,y3); xchange(x1,x3); end; if y2>y3 then begin xchange(y2,y3); xchange(x2,x3); end; ymin:=y1; xmin:=x1; ymid:=y2; xmid:=x2; ymax:=y3; xmax:=x3; if ymax=ymin then begin {vsechny body ve stejne vysce - je to vodorovna cara a ne trojuhelnik} if x1>x2 then xchange(x1,x2); if x1>x3 then xchange(x1,x3); if x2>x3 then xchange(x2,x3); __hline(x1,x3,y1,color,style); exit; end; if (x1=x2)and(x2=x3) then begin {vsechny body pod sebou - je to svisla cara} __vline(x1,y1,y3,color,style); exit; end; xmid2:=(xmax-xmin)*(ymid-ymin) div (ymax-ymin)+xmin; {bod na protejsi strane ve stejne vysce jako prostredni vrchol} {prvni podtrojuhelnik od horniho vrcholu k prostrednimu:} if ymin<>ymid then for i:=ymin to ymid do __HLine((xmid-xmin)*(i-ymin) div (ymid-ymin)+xmin, (xmid2-xmin)*(i-ymin) div (ymid-ymin)+xmin,i,color,style); {a druhy od prostrednimu k dolnimu:} if ymid<>ymax then for i:=ymid to ymax do __HLine((xmax-xmid)*(i-ymid) div (ymax-ymid)+xmid, (xmax-xmid2)*(i-ymid) div (ymax-ymid)+xmid2,i,color,style); End;{__triangle} procedure __Polygon(var VertexList; NumberOfVertices:word; Color,Style:byte); var i:word; Begin {nejdriv osetrime nesmysly:} if (numberofvertices=0) or (numberofvertices>16382) then exit; {jeden vrchol je jenom bod:} {^^^^^=64 KB / sizeof(dva integery)} if numberofvertices=1 then __PutPixel(_VertexArray(vertexlist)[1].x,_VertexArray(vertexlist)[1].y,color,style) {dva vrcholy jsou cara:} else if numberofvertices=2 then __Line(_VertexArray(vertexlist)[1].x,_VertexArray(vertexlist)[1].y, _VertexArray(vertexlist)[2].x,_VertexArray(vertexlist)[2].y, color,style) {bez vyplne je to uzavrena serie car:} else if style and _filled=0 then begin for i:=1 to pred(numberofvertices) do __line(_vertexarray(vertexlist)[i].x,_vertexarray(vertexlist)[i].y, _vertexarray(vertexlist)[succ(i)].x,_vertexarray(vertexlist)[succ(i)].y, color,style); __line(_vertexarray(vertexlist)[numberofvertices].x,_vertexarray(vertexlist)[numberofvertices].y, _vertexarray(vertexlist)[1].x,_vertexarray(vertexlist)[1].y, color,style); end {tri a vic vrcholu s vyplni je serie trojuhelniku:} else repeat __Triangle(_VertexArray(vertexlist)[1].x,_VertexArray(vertexlist)[1].y, _VertexArray(vertexlist)[numberofvertices-1].x,_VertexArray(vertexlist)[numberofvertices-1].y, _VertexArray(vertexlist)[numberofvertices].x,_VertexArray(vertexlist)[numberofvertices].y, color,style); dec(numberofvertices); until numberofvertices=2; End;{__polygon} {pro Floodfill:} const MaxZ=8;{maximalni pocet zasobniku} type PolePixelu=array[0..0] of record x,y:word; end; UkNaPolePixelu=^polepixelu; tZasobniky=array[1..maxz] of record data:uknapolepixelu; velikost:word; {velikost zasobniku [B]} max:word; {maximalni pouzitelny index} vrchol:word; {index volne pozice na vrcholu zasobniku} end; uZasobniky=^tzasobniky; const PosledniZasobnik:byte=0; {cislo prave pouzivaneho zasobniku} Zasobniky:uzasobniky=nil; function NovyZasobnik:boolean; {vytvori novy zasobnik a vraci true, jestli se to povedlo} Begin novyzasobnik:=false; if poslednizasobnikmaxavail then velikost:=maxavail; if velikost<16 then exit; {uz neni pamet} max:=(velikost shr 2)-1; {deleno velikosti jednoho prvku pole plus jeden prvek rezerva kvuli indexovani pole od nuly} vrchol:=0; getmem(data,velikost); inc(poslednizasobnik); novyzasobnik:=true; end; End;{novyzasobnik} procedure _Push(_x,_y:integer); {ulozi bod na zasobnik} Begin if ((poslednizasobnik=0)or(zasobniky^[poslednizasobnik].vrchol>zasobniky^[poslednizasobnik].max)) and (not novyzasobnik) then exit; with zasobniky^[poslednizasobnik] do begin data^[vrchol].x:=_x; data^[vrchol].y:=_y; inc(vrchol); end; End;{_push} procedure ZrusZasobnik; Begin if poslednizasobnik<>0 then begin with zasobniky^[poslednizasobnik] do freemem(data,velikost); dec(poslednizasobnik); end; End;{zruszasobnik} procedure _Pop(var _x,_y:integer); {vyjme bod ze zasobniku a v parametrech vrati jeho souradnice} Begin if poslednizasobnik=0 then exit; if zasobniky^[poslednizasobnik].vrchol=0 then zruszasobnik; if poslednizasobnik=0 then exit; with zasobniky^[poslednizasobnik] do begin dec(vrchol); _x:=data^[vrchol].x; _y:=data^[vrchol].y; end; End;{_pop} procedure __FloodFill(x,y:integer; color,bordercolor:word); var i,_x,_y,leva,prava:integer; okraj:set of byte; {barvy, o ktere se ma vypln zarazit} pixel:byte; Begin if (x>_maxclipx)or(y>_maxclipy)or(x<_minclipx)or(y<_minclipy) then exit; {jsme mimo okno} pixel:=_getpixel(x,y); if bordercolor>255 then begin okraj:=[0..255]-[pixel]; {okrajem je cokoli krome barvy vychoziho pixelu} if color=pixel then exit; end else begin okraj:=[color,bordercolor]; {okraj je zadana barva a drive vybarvena oblast, aby se to nezacyklilo} if pixel in okraj then exit; end; new(zasobniky); poslednizasobnik:=0; _push(x,y); {ulozime pocatecni bod na zasobnik} repeat _pop(_x,_y); {precteme souradnice ze zasobniku} if not (_getpixel(_x,_y) in okraj) then {jo, tady to potrebuje vybarvit} begin if (_y>_minclipy)and not(_getpixel(_x,_y-1) in okraj) then _push(_x,_y-1); {ulozime bod nad nim...} if (_y<_maxclipy)and not(_getpixel(_x,_y+1) in okraj) then _push(_x,_y+1); {...a bod pod nim} leva:=_x; prava:=_x; {tohle je nutne} i:=_x; while (i<_maxclipx)and not(_getpixel(i,_y) in okraj) do {podivame se od toho bodu doprava} begin prava:=i; {posuneme pravou souradnici} inc(i); {o pixel doprava} {kdyz se o radek niz objevi prechod hranice -> volno, musime ten bod taky ulozit:} if (_y<_maxclipy)and(_getpixel(i-1,_y+1) in okraj) and not (_getpixel(i,_y+1) in okraj) then _push(i,_y+1); {to same i o radek vys:} if (_y>_minclipy)and(_getpixel(i-1,_y-1) in okraj) and not (_getpixel(i,_y-1) in okraj) then _push(i,_y-1); end; i:=_x; while (i>_minclipx)and not(_getpixel(i,_y) in okraj) do {podivame se obdobnym zpusobem nalevo} begin leva:=i; dec(i); if (_y<_maxclipy)and(_getpixel(i+1,_y+1) in okraj)and not(_getpixel(i,_y+1) in okraj) then _push(i,_y+1); if (_y>_minclipy)and(_getpixel(i+1,_y-1) in okraj)and not(_getpixel(i,_y-1) in okraj) then _push(i,_y-1); end; _hline(leva,prava,_y,color); {vybarvime radek} end; until poslednizasobnik=0; {dokud jsme ze zasobniku nevytahli posledni bod} dispose(zasobniky); End;{__floodfill} (**************************************************************************** pro texty: *****************************************************************************) type PoleBytu=array[0..0] of byte; {Pomocna datova struktura pro ukladani rastrovych fontu. Delka pole je dynamicka podle vysky znaku. Sam o sobe je tento typ nepouzitelny - - potrebujeme znat vysku pisma, jinak se v nem nic nenajde. Technicke detaily: kazde pismeno je tvoreno nekolika byty, kazdy predstavuje jeden radek (kde je jednicka, tam se pixel vykresli, kde je nula, tam ne). Sirka znaku je pevna - 8 pixelu (tj. 8 bitu v 1 bytu), vyska libovolna. Znakova sada zabere v pameti 256 krat vyska pisma bytu (pro pismo 8x8 pixelu to tedy dela presne 2 KB).} UkNaPB=^polebytu; var __Font:uknapb; {data aktualniho fontu} procedure _SetFont(var f:_font; setdefaults:boolean); Begin __font:=f.glyphdata; __vyska:=f.glyphheight; if setdefaults then begin with f do _settextscale(stdxscale,stdyscale,stdpitch); _settextjustify(0,2); end; End;{_setfont} procedure _SetTextScale(XScale,YScale,Pitch:byte); Begin if xscale<>0 then __xscale:=xscale; if yscale<>0 then __yscale:=yscale; if pitch<>0 then __pitch:=pitch; End;{_settextscale} procedure _SetTextJustify(xJustify,yJustify:byte); Begin __xjustify:=xjustify; __yjustify:=yjustify; End;{_settextjustify} type UkNaNastaveniTextu=^NastaveniTextu; NastaveniTextu=record vyska:byte; data:uknapb; velikostx, velikosty, roztec, zarovnanix, zarovnaniy:byte; dalsi:uknanastavenitextu; end; const prvniNT:uknanastavenitextu=nil; procedure _pushtextsettings; var n:uknanastavenitextu; Begin if maxavail<16 then exit; new(n); with n^ do begin vyska:=__vyska; data:=__font; velikostx:=__xscale; velikosty:=__yscale; roztec:=__pitch; zarovnanix:=__xjustify; zarovnaniy:=__yjustify; dalsi:=prvnint; end; prvnint:=n; End;{_pushtextsettings} procedure _poptextsettings; var v:uknanastavenitextu; Begin if prvnint=nil then exit; with prvnint^ do begin __vyska:=vyska; __font:=data; __xscale:=velikostx; __yscale:=velikosty; __pitch:=roztec; __xjustify:=zarovnanix; __yjustify:=zarovnaniy; end; v:=prvnint; prvnint:=prvnint^.dalsi; dispose(v); End;{_poptextsettings} procedure _loadtextsettings; Begin if prvnint<>nil then with prvnint^ do begin __vyska:=vyska; __font:=data; __xscale:=velikostx; __yscale:=velikosty; __pitch:=roztec; __xjustify:=zarovnanix; __yjustify:=zarovnaniy; end; End;{_loadtextsettings} procedure _LoadFont(var target:_font; var source:file); var velikost:word; b:byte; Begin target.glyphdata:=nil; {jestli se neco pokazi, tohle tady zustane} blockread(source,target.glyphheight,1); velikost:=256*target.glyphheight; {je 256 znaku a kazdy ma tolik bytu, jak je vysoky} if (ioresult<>0) or (velikost>maxavail) then exit; getmem(target.glyphdata,velikost); blockread(source,target.stdpitch,1); blockread(source,b,1); target.stdxscale:=b and 15; target.stdyscale:=b shr 4; blockread(source,target.glyphdata^,velikost); if ioresult<>0 then begin freemem(target.glyphdata,velikost); {kdyz se font nenacetl, nema cenu zbytecne zabirat pamet} target.glyphdata:=nil; end; End;{_loadfont} procedure _LoadFont2(var target:_font; filename:string); var f:file; Begin assign(f,filename); reset(f,1); _loadfont(target,f); close(f); if ioresult<>0 then ; {reset Ioresultu pro pripad chyby pri Close} End;{_loadfont2} function _SaveFont(var source:_font; filename:string):boolean; var f:file; b:byte; Begin _savefont:=false; assign(f,filename); rewrite(f,1); blockwrite(f,source.glyphheight,1); blockwrite(f,source.stdpitch,1); b:=(source.stdyscale shl 4) or (source.stdxscale and 15); blockwrite(f,b,1); blockwrite(f,source.glyphdata^,256*source.glyphheight); close(f); _savefont:=ioresult=0; End;{_savefont} procedure _DisposeFont(var f:_font); Begin if f.glyphdata<>nil then begin freemem(f.glyphdata,f.glyphheight*256); fillchar(f,sizeof(f),0); {aby bylo jasne, ze je prazdno} end; End;{_disposefont} const MaleKody:set of char=['b','z','x','y','r','h','v']; {6znakove} VelkeKody:set of char=['B','Y','R','H','V','0']; {3znakove} procedure ZpracujText(x,y:integer; color,style:byte; message:string; kreslit:boolean); {Projde zadany text, vyhodnoti ridici kody a bud jenom spocita rozmery (kreslit=false), nebo ho rovnou vykresli (kreslit=true). Ignoruje zarovnani textu, vzdycky jede na leve horni.} var PoziceVRetezci:word; {index pro pohyb mezi znaky retezce (word proto, aby nepretekl, kdyz bude retezec 255 znaku dlouhy)} CisloRadku:word; {index pro pohyb mezi radky pismena} IndexY, {index pro kresleni jednotlivych kopii jednoho radku pismena (pro _velikostY>1)} radek:byte; {data - jeden radek pismena (bitove pole)} px,py:integer; {pomocne - aktualni souradnice na obrazovce} i:integer; {ridici promenna do asm cyklu + pro ulozeni cisla z ridiciho kodu} kod:char; {hlavni pismeno ridiciho kodu} znak:word; {pomocna, pro zadavani znaku pres ordinalni cisla (%%z...)} JakToDopadlo:integer; {pro vyhodnoceni cisla z ridiciho kodu (Val)} OfsetRadku:word; {ofset aktualne zpracovavaneho radku (bytu) ve fontu} pvx,pvy,pr,pbarva:byte; piy:integer; {pro ulozeni puvodnich hodnot} delka:word; {sirka souvisleho vybarveneho useku pismena} maxX,maxY,druha,nulaX,nulaY:integer; {pomocne souradnice pro vypocet rozmeru} UzSeKreslilo:boolean; {true po prvnim vykreslenem znaku, false pokud retezec zacina ridicimi kody} Begin if kreslit then begin if (message='')or(__font=nil)or(x+__xscale shl 3-1>_maxclipx)or(y>_maxclipy) then exit; {neni co zobrazovat} end else begin if message='' then begin {neni co merit} _width:=0; _height:=_textheight; _DeltaX:=0; _DeltaY:=0; exit; end; {Vypnute ridici kody retezec neovlivni, takze ho neni potreba prochazet a rozmery se daji spocitat rovnou. To je ale tak vzacny pripad, ze nema smysl ho osetrovat, tak ho nechavam zakomentovany: if _controlcodes=_print then begin _deltax:=0; _deltay:=0; _width:=_textwidth(length(message)); _height:=_textheight; exit; end;} end; if _controlcodes=_use then begin {ulozeni pocatecnich hodnot} pvx:=__xscale; pvy:=__yscale; pr:=__pitch; pbarva:=color; piy:=y; end; PoziceVRetezci:=1; nulax:=x; nulay:=y; _deltax:=x; maxx:=x; _deltay:=y; maxy:=y; uzsekreslilo:=false; repeat {cyklus pro kazdy znak retezce} {osetreni ridicich kodu:} znak:=$FFFF; if (_controlcodes<>_print) {jestli se ridici kody nemaji brat jako normalni text...} and (message[pozicevretezci]='%') {...a nasli jsme znak '%'...} and (pozicevretezci+2<=length(message)) {...a jsou za nim jeste aspon 2 dalsi...} and (message[pozicevretezci+1]='%') {...a druhy je taky '%', tak jsme asi narazili na ridici kod a jdeme ho vyhodnotit.} then begin {zpracovani ridiciho kodu} kod:=message[pozicevretezci+2]; if kod in malekody {male pismeno -> sestipismenny kod} then begin if pozicevretezci+5<=length(message) then {jestli retezec nekonci pred koncem kodu} begin val(copy(message,pozicevretezci+3,3),i,jaktodopadlo); if jaktodopadlo=0 then begin if _controlcodes=_use then case kod of 'b':color:=i; 'x':inc(x,i*_controlcodescale div 100); 'y':inc(y,i*_controlcodescale div 100); 'r':__pitch:=i*_controlcodescale div 100; 'h':__xscale:=i*_controlcodescale div 100; 'v':__yscale:=i*_controlcodescale div 100; 'z':znak:=i; end; inc(pozicevretezci,5); if (kod<>'z')or(_controlcodes=_skip) then begin inc(pozicevretezci); continue; {skok na zaverecny Until} end; end; end; end else if kod in velkekody then begin {velke pismeno nebo nepismeno -> tripismenny kod} if _controlcodes=_use then case kod of 'B':color:=pbarva; 'Y':y:=piy; 'R':__pitch:=pr; 'H':__xscale:=pvx; 'V':__yscale:=pvy; '0':begin color:=pbarva; y:=piy; __pitch:=pr; __xscale:=pvx; __yscale:=pvy; end; end; inc(pozicevretezci,3); continue; end; end;{konec zpracovani kodu} if kreslit and (__xscale<>0) and (__yscale<>0) {jestli neni nulove meritko, kreslime} then asm {priprava pocitadla radku:} mov AX,__vyska mov cisloradku,AX {bude se postupne odcitat az do nuly} {nacteni znaku:} mov AX,znak cmp AX,$FFFF { $FFFF = vytahni ho normalne z retezce, cokoli jineho = uz je nastaveny pres kod} jne @MameZnak xor AX,AX {kvuli vynulovani AH} lea SI,message mov BX,pozicevretezci mov AL,[SS:SI+BX] {precteni znaku z retezce} @MameZnak: {adresa znaku ve fontu:} mul __vyska {ASCII kod znaku * __vyska = ofset prvniho radku znaku ve fontu} les DI,__font add DI,AX mov ofsetradku,DI {yova souradnice LH rohu znaku:} mov AX,y mov py,AX {cyklus pro kazdy radek fontu:} @MameOfsetRadku: mov AL,[ES:DI] {radek z fontu} mov radek,AL {projiti radku bit po bitu:} mov AX,x; mov i,8 {pocitadlo bitu} mov px,AX; mov delka,0 {pocitadlo delky jednickovych useku musi byt na zacatku vynulovane} @ProKazdyBit: rol radek,1 jnc @dira {dokud jsou jednicky, jenom pricitame delku:} mov AX,__xscale add delka,AX jmp @BitVyrizen @dira: {jakmile jednicky skonci, vykreslime nasbirany jednickovy usek:} cmp delka,0 {mame neco nasbirano?} je @JenPosun {ne} @kresleni: mov AX,px push AX {x1} mov BX,py cmp __yscale,1 je @hline {kdyz je pismo ve svislem smeru roztazene, kreslime bar:} push BX {y1} add AX,delka dec AX; add BX,__yscale push AX; {x2} dec BX push BX {y2} push word ptr color push word ptr style call __bar jmp @vykresleno @hline: {kdyz pismo roztazene neni, kreslime jenom caru:} add AX,delka dec AX push AX {x2} push BX {y} push word ptr color push word ptr style call __hline @vykresleno: mov AX,delka add px,AX mov delka,0 @JenPosun: {na obrazovce o jeden (roztazeny) pixel dal:} mov AX,__xscale add px,AX @BitVyrizen: dec i jnz @ProKazdyBit {Prosli jsme vsech 8 bitu, ale mozna nam jeste ceka na zpracovani nascitana delka posledniho jednickoveho useku. V takovem pripade se musime vratit a nechat ho vykreslit:} cmp delka,0 je @RadekOpravduVyrizen mov i,1 {aby bitovy cyklus hned skoncil} jmp @kresleni @RadekOpravduVyrizen: dec cisloradku jz @CelyZnakVykreslen {na dalsi radek na obrazovce:} mov AX,__yscale add py,AX {na dalsi radek ve fontu:} les DI,__font inc ofsetradku mov DI,ofsetradku jmp @MameOfsetRadku @CelyZnakVykreslen: end else if not kreslit then begin {misto vykresleni znaku vypocet jeho rozmeru} if not uzsekreslilo then begin {pripadny posun ridicimi kody na zacatku retezce} _deltax:=x; maxx:=x; _deltay:=y; maxy:=y; uzsekreslilo:=true; end; if x<_deltax then _deltax:=x; {levy okraj znaku} druha:=x+(__xscale shl 3)-1; {pravy okraj} if druha>maxx then maxx:=druha; if y<_deltay then _deltay:=y; {horni okraj} druha:=y+__yscale*__vyska-1; {spodni okraj} if druha>maxy then maxy:=druha; end; inc(x,__pitch); inc(pozicevretezci); until (pozicevretezci>length(message)) or (kreslit and (x>_maxclipx)); if not kreslit then begin {delty jsou minima souradnic, maxy maxima} _width:=maxx-_deltax+1; _height:=maxy-_deltay+1; dec(_deltax,nulax); dec(_deltay,nulay); end; if _controlcodes=_use then begin {obnoveni ulozenych hodnot} __xscale:=pvx; __yscale:=pvy; __pitch:=pr; end; End;{zpracujtext} procedure SpocitejPosuny(var posunX,posunY:word; message:string); {zjisti, o kolik se pri aktualnim zarovnani textu posune doleva a nahoru referencni bod pro vypsani dane zpravy __printem} Begin posunx:=0; posuny:=0; if (__xJustify<>0)or(__yJustify<>2) {jine zarovnani nez normalni leve horni} then begin zpracujtext(0,0,0,0,message,false); case __xjustify of 1:posunx:=_width shr 1; {na stred} 2:posunx:=_width; {vpravo} end; case __yjustify of 0:posuny:=_height; {dolu} 1:posuny:=_height shr 1; {na stred} end; end; End;{spocitejposuny} procedure __print(x,y:integer; color,style:byte; message:string); var posunX,posunY:word; Begin spocitejposuny(posunx,posuny,message); zpracujtext(x-posunx,y-posuny,color,style,message,true); End;{__print} procedure _MeasureText(message:string); var posunX,posunY:word; Begin spocitejposuny(posunx,posuny,message); zpracujtext(0,0,0,0,message,false); dec(_deltax,posunx); dec(_deltay,posuny); End;{_measuretext} function _TextWidth(NumberOfChars:byte):word; Begin if numberofchars=0 then _textwidth:=0 else _textwidth:=(numberofchars-1)*__pitch+__xscale shl 3; End;{_textwidth} function _textheight:word; Begin _textheight:=__yscale*__vyska;{= velikost pixelu * vyska pisma v pixelech} End;{_textheight} procedure __PutTImage(x1,y1:integer; width,height:word; source:pointer); var i,SourcSegment,SourcOfset:word; xshift,yshift,dssave,width2,incr:word; Begin if (x1>_maxclipx)or(y1>_maxclipy) then Exit; xshift:=0; yshift:=0; if x1<_minclipx then begin{vycuhuje levy okraj?} if x1+width<=_minclipx then Exit; xshift:=_minclipx-x1; dec(width,_minclipx-x1); x1:=_minclipx; end; if y1<_minclipy then begin{vycuhuje horni okraj?} if y1+height<=_minclipy then Exit; yshift:=_minclipy-y1; dec(height,_minclipy-y1); y1:=_minclipy; end; sourcsegment:=seg(source^); SourcOfset:=ofs(source^)+yshift*(width+xshift)+xshift; if (x1+width-1)>_MaxclipX then begin{vycuhuje pravy okraj?} inc(xshift,x1+width-1-_MaxclipX); width:=_MaxclipX-x1+1; end; if (y1+height-1)>_MaxclipY then height:=_MaxclipY-y1+1;{vycuhuje dolni okraj?} incr:=_maxx-width+1; i:=y1+__lhy; inc(height,i);{height uz neni vyska, ale yova souradnice posledniho radku +1} {nahrazuje to cyklus for i:=y1 to y1+height-1 do...} asm mov AX,DS mov dssave,AX {ulozeni DS (myslim, ze to s pomocnou promennou bude trochu rychlejsi nez s push+pop)} mov AX,_zapisovacisegment mov ES,AX {ES = cilovy segment} mov AX,sourcofset mov SI,AX {SI = zdrojovy ofset (zacatek prvniho radku)} mov AX,_Maxx inc AX mul i {AX = ofset zacatku radku na obrazovce, DX = banka na tom zacatku} add AX,x1 {AX = ofset bodu, kde bude zacinat radek obrazku} adc DX,0 {DX = banka toho bodu} mov DI,AX {DI = cilovy ofset} {ted je v DI ofset a v DX banka} @zacatek: {zacatek cyklu, ktery probehne pro kazdy radek} mov BX,DI mov CX,DX add BX,width adc CX,0 dec BX {BX = ofset bodu na konci radku, CX = banka toho bodu} {ted je v DI ofset zacatku radku, v DX jeho banka a v BX a CX to same pro konec radku} cmp DX,curbank {prepnuti do banky pro zacatek radku} je @neprepinej mov AX,DX mov curbank,AX mul granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank @neprepinej: cmp CX,curbank {je banka na konci radku stejna jako na zacatku?} je @najednou {je => hop dal ***} {neni => nakresli se prvni cast radku v prvni bance, pak se prepne o banku dal a nakresli se zbytek:} mov CX,$FFFF sub CX,DI inc CX {CX = pocet pixelu v prvni bance} mov AX,width sub AX,CX mov width2,AX {width2 = pocet pixelu ve druhe bance} mov AX,sourcsegment mov DS,AX {DS = zdrojovy segment} @PrvniPulkaRadku: lodsb {zdroj -> AL} or AL,AL {je AL 0 (pruhledna)?} jz @nic1 mov ES:[DI],AL {AL -> obrazovka} @nic1: inc DI {v cili o pixel dal (i kdyz se nic nekreslilo)} loop @PrvniPulkaRadku {v posledni iteraci DI preteklo a je v nem 0, coz presne chceme} mov AX,dssave mov DS,AX {obnoveni DS} mov AX,curbank inc AX {o banku dal} mov curbank,AX mul granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank mov CX,width2 {CX = pocet pixelu ve druhe bance} jmp @jedeme @najednou: {***} mov CX,width {CX = pocet pixelu} @jedeme: or CX,CX jz @nic {aby se cyklus neprovedl vubec, pokud je CX=0} mov AX,sourcsegment mov DS,AX {DS = opet zdrojovy segment} @ZbytekRadku: lodsb {zdroj -> AL} or AL,AL jz @nic2 mov ES:[DI],AL {AL -> obrazovka} @nic2: inc DI loop @ZbytekRadku mov AX,dssave mov DS,AX {obnoveni DS} @nic: {radek je vykreslen} add SI,xshift {ve zdroji o radek dal} mov DX,curbank add DI,incr {na obrazovce o radek dal} adc DX,0 {ted je v DI ofset a v DX banka, presne tak, jak to je na zacatku cyklu potreba} inc i mov AX,i cmp AX,height {uz jsme nakreslili posledni radek?} jne @zacatek {ne => jdeme na dalsi} end; End;{__puttimage} procedure __PutRTImage(x1,y1:integer;width,height:word; source:pointer); {trochu slozitejsi Puttimage - ze zdroje se musi cist obracene} var i,SourcSegment,SourcOfset,xshift,yshift,dssave,width2,incr:word; Begin if (x1>_maxclipx)or(y1>_maxclipy) then Exit; xshift:=0; yshift:=0; if x1<_minclipx then begin{vycuhuje levy okraj?} if x1+width<=_minclipx then Exit; xshift:=_minclipx-x1; dec(width,_minclipx-x1); x1:=_minclipx; end; if y1<_minclipy then begin{vycuhuje horni okraj?} if y1+height<=_minclipy then Exit; yshift:=_minclipy-y1; dec(height,_minclipy-y1); y1:=_minclipy; end; sourcsegment:=seg(source^); SourcOfset:=ofs(source^)+yshift*(width+xshift)-xshift; if (x1+width-1)>_MaxclipX then begin{vycuhuje pravy okraj?} inc(xshift,x1+width-1-_MaxclipX); width:=_MaxclipX-x1+1; end; if (y1+height-1)>_MaxclipY then height:=_MaxclipY-y1+1;{vycuhuje dolni okraj?} incr:=_maxx-width+1; i:=y1+__lhy; inc(height,i);{height uz neni vyska, ale yova souradnice posledniho radku +1} {nahrazuje to cyklus for i:=y1 to y1+height-1 do...} asm mov AX,DS mov dssave,AX {ulozeni DS} mov AX,_zapisovacisegment mov ES,AX {ES = cilovy segment} mov AX,sourcofset add AX,width mov SI,AX {SI = zdrojovy ofset (bod za koncem prvniho radku)} mov AX,_Maxx inc AX mul i {AX = ofset zacatku radku obrazovky, DX = banka na tom zacatku} add AX,x1 {AX = ofset bodu, kde bude zacinat radek obrazku} adc DX,0 {DX = banka toho bodu} mov DI,AX {DI = cilovy ofset} {ted je v DI ofset a v DX banka} @zacatek: {zacatek cyklu, ktery probehne pro kazdy radek} mov BX,DI mov CX,DX add BX,width adc CX,0 dec BX {BX = ofset bodu na konci radku, CX = banka toho bodu} {ted je v DI ofset zacatku radku, v DX jeho banka a v BX a CX to same pro konec radku} cmp DX,curbank {prepnuti do banky pro zacatek radku} je @neprepinej mov AX,DX mov CurBank,AX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank @neprepinej: cmp CX,curbank {je banka na konci radku stejna jako na zacatku?} je @najednou {je => hop dal ***} {neni => nakresli se prvni cast radku v prvni bance, pak se prepne o banku dal a nakresli se zbytek:} mov CX,$FFFF sub CX,DI inc CX {CX = pocet pixelu v prvni bance} mov AX,width sub AX,CX mov width2,AX {width2 = pocet pixelu ve druhe bance} mov AX,sourcsegment mov DS,AX {DS = zdrojovy segment} @PrvniPulkaRadku: dec SI {slo by to i pres std a cld, ale takhle mi to pripada jednodussi} mov AL,DS:[SI] {zdroj -> AL} or AL,AL {je AL 0 (pruhledna)?} jz @nic1 mov ES:[DI],AL {AL -> obrazovka} @nic1: inc DI {v cili o pixel dal (i kdyz se nic nekreslilo)} loop @PrvniPulkaRadku {v posledni iteraci DI preteklo a je v nem 0, coz presne chceme} mov AX,dssave mov DS,AX {obnoveni DS} mov AX,curbank inc AX {prepnuti o banku dal (DI je 0, takze budeme kreslit na zacatek dalsi banky)} mov CurBank,AX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank mov CX,width2 {CX = pocet pixelu ve druhe bance} jmp @jedeme @najednou: mov CX,width {CX = pocet pixelu} @jedeme: or CX,CX jz @nic mov AX,sourcsegment mov DS,AX {DS = opet zdrojovy segment} @ZbytekRadku: dec SI mov AL,DS:[SI] {zdroj -> AL} or AL,AL jz @nic2 mov ES:[DI],AL {AL -> obrazovka} @nic2: inc DI loop @ZbytekRadku {SI je ted na zacatku radku ve zdroji} mov AX,dssave mov DS,AX {obnoveni DS} @nic: {radek je vykreslen} add SI,xshift {ve zdroji o radek dal} add SI,width add SI,width {(ze zacatku jednoho radku za konec dalsiho radku)} mov DX,curbank add DI,incr {na obrazovce o radek dal} adc DX,0 {ted je v DI ofset a v DX banka, presne tak, jak to je na zacatku cyklu potreba} inc i mov AX,i cmp AX,height {uz jsme nakreslili posledni radek?} jne @zacatek {ne => jdeme na dalsi} end; End;{__putrtimage} procedure __PutImage(x1,y1:integer; width,height:word; source:pointer); {Podobna Puttimage, lisi se jen kopirovacim cyklem: misto pixel po pixelu s testovanim jeho hodnoty se kopiruje po qwordech, dwordech a bytech, aby to bylo rychlejsi.} var xshift,yshift,sourcsegment,sourcofset,incr,i,DSsave,width2:word; Begin if (x1>_maxclipx)or(y1>_maxclipy) then Exit; xshift:=0; yshift:=0; if x1<_minclipx then begin if x1+width<=_minclipx then Exit; xshift:=_minclipx-x1; dec(width,_minclipx-x1); x1:=_minclipx; end; if y1<_minclipy then begin if y1+height<=_minclipy then Exit; yshift:=_minclipy-y1; dec(height,_minclipy-y1); y1:=_minclipy; end; sourcsegment:=seg(source^); SourcOfset:=ofs(source^)+yshift*(width+xshift)+xshift; if (x1+width-1)>_MaxclipX then begin inc(xshift,x1+width-1-_MaxclipX); width:=_MaxclipX-x1+1; end; if (y1+height-1)>_MaxclipY then height:=_MaxclipY-y1+1; incr:=_maxx-width+1; i:=y1+__lhy; inc(height,i); asm mov AX,DS mov dssave,AX mov AX,_zapisovacisegment mov ES,AX mov AX,sourcofset mov SI,AX mov AX,_maxx inc AX mul i add AX,x1 adc DX,0 mov DI,AX @zacatek: mov BX,DI mov CX,DX add BX,width adc CX,0 dec BX sbb CX,0 cmp DX,curbank je @neprepinej mov AX,DX mov CurBank,AX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank @neprepinej: cmp CX,curbank je @najednou mov CX,$FFFF sub CX,DI inc CX mov AX,width sub AX,CX mov width2,AX mov AX,sourcsegment mov DS,AX {presun po qwordech:} mov BX,CX shr CX,4 jz @MeneNez16_1 @smycka1: fild qword ptr DS:[SI] {1. qword na zasobnik FPU} fild qword ptr DS:[SI+8] {2. -''- } fistp qword ptr ES:[DI+8] {2. qword ze zasobniku} fistp qword ptr ES:[DI] {1. -''- } add SI,16 add DI,16 loop @smycka1 @MeneNez16_1: {presun po dwordech:} mov CX,BX and CX,15 mov BX,CX shr CX,2 db $66; rep movsw {presun po bytech:} mov CX,BX and CX,3 rep movsb mov AX,dssave mov DS,AX mov AX,curbank inc AX mov CurBank,AX mul Granularity mov DX,AX mov AX,$4F05 mov BX,_zapisovaciokno call __switchbank mov CX,width2 jmp @jedeme @najednou: mov CX,width @jedeme: mov AX,sourcsegment mov DS,AX mov BX,CX shr CX,4 jz @MeneNez16_2 @smycka2: fild qword ptr DS:[SI] fild qword ptr DS:[SI+8] fistp qword ptr ES:[DI+8] fistp qword ptr ES:[DI] add SI,16 add DI,16 loop @smycka2 @MeneNez16_2: mov CX,BX and CX,15 mov BX,CX shr CX,2 db $66; rep movsw mov CX,BX and CX,3 rep movsb mov AX,dssave mov DS,AX add SI,xshift mov DX,curbank add DI,incr adc DX,0 inc i mov AX,i cmp AX,height jne @zacatek end; End;{__putimage} procedure _GetImage(x1,y1,x2,y2:word; target:pointer); assembler; {Podobna Putimage, ale s prohozenym zdrojem a cilem. Jeste zjednodusena tim, ze se nestara o vycuhovani obrazku z obrazovky a ze je jenom 32bitova. Ponekud ji komplikuje cachrovani se ctecim oknem.} var i,dssave,width,width2,incr,rbank:word; Asm {nejdriv pojistka proti zapisu do nuloveho segmentu (nil):} les DI,target mov AX,ES or AX,AX jz @konec {$ifdef blbuvzdornost} mov AX,x1 cmp AX,x2 js @xOK mov AX,x1 mov BX,x2 mov x1,BX mov x2,AX @xOK: mov AX,y1 cmp AX,y2 js @yOK mov AX,y1 mov BX,y2 mov y1,BX mov y2,AX @yOK: {$endif} {zjisteni aktualni banky:} mov CX,_cteciokno cmp CX,_zapisovaciokno je @StejnaOkna call _getrbank mov rbank,AX jmp @CteciBankaZjistena @StejnaOkna: mov BX,curbank mov rbank,BX @CteciBankaZjistena: {rbank = aktualni banka ve ctecim okne} mov AX,__lhy add y1,AX add y2,AX mov AX,y1 mov i,AX inc y2 les DI,target mov AX,x2 sub AX,x1 inc AX mov width,AX mov AX,_maxx sub AX,width inc AX mov incr,AX mov AX,DS mov dssave,AX mov AX,_Maxx inc AX mul i add AX,x1 adc DX,0 mov SI,AX @zacatek: mov BX,SI mov CX,DX add BX,width adc CX,0 dec BX sbb CX,0 cmp DX,rbank je @neprepinej push DX mov rbank,DX call _SwitchRBank @neprepinej: cmp CX,rbank je @najednou mov CX,$FFFF sub CX,SI inc CX mov AX,width sub AX,CX mov width2,AX mov AX,_ctecisegment mov DS,AX mov BX,CX shr CX,2 db $66; rep movsw and BX,3 mov CX,BX rep movsb mov AX,dssave mov DS,AX mov AX,rbank inc AX mov rbank,AX push AX call _switchRbank mov CX,width2 jmp @jedeme @najednou: mov CX,width @jedeme: mov AX,_ctecisegment mov DS,AX mov BX,CX shr CX,2 db $66; rep movsw and BX,3 mov CX,BX rep movsb mov AX,dssave mov DS,AX mov DX,rbank add SI,incr adc DX,0 inc i mov AX,i cmp AX,y2 jne @zacatek {synchronizace banky v zapisovacim okne, pokud je okno jenom jedno:} mov CX,_cteciokno cmp CX,_zapisovaciokno jne @konec mov BX,rbank mov curbank,BX @konec: End;{_getimage} (*************************************************************************** Ruzne ****************************************************************************) procedure _VSync; assembler; Asm mov DX,$3DA @repeat: in AL,DX test AL,8 jz @repeat End;{_vsync} procedure _VSyncStart; assembler; Asm mov DX,$3DA @repeat1: in AL,DX test AL,8 jnz @repeat1 @repeat2: in AL,DX test AL,8 jz @repeat2 End;{_vsyncstart} procedure _SetWindow(minx,miny,maxx,maxy:integer); Begin if minx>maxx then xchange(minx,maxx); if miny>maxy then xchange(miny,maxy); if minx<0 then _minclipx:=0 else _minclipx:=minx; if miny<0 then _minclipy:=0 else _minclipy:=miny; if maxx>_maxx then _maxclipx:=_maxx else _maxclipx:=maxx; if maxy>_maxy then _maxclipy:=_maxy else _maxclipy:=maxy; End;{_setwindow} procedure _SetDefaultWindow; Begin _MinClipX:=0; _MinClipY:=0; _MaxClipX:=_MaxX; _MaxClipY:=_MaxY; End;{_setdefaultwindow} (**************************************************************************** Ovladani virtualni obrazovky *****************************************************************************) procedure _SetDisplayOrigin(x,y:word); assembler; Asm mov AX,$4F07 xor BX,BX mov CX,x mov DX,y int $10 End;{_setdisplayorigin} procedure _SetActivePage(PageNumber:byte); Begin __lhy:=succ(_maxy)*pagenumber; End;{_setap} procedure _SetVisualPage(PageNumber:byte); Begin _setdisplayorigin(0,succ(_maxy)*pagenumber); End;{_setvp} procedure _TogglePaging; assembler; Asm mov AX,_maxy inc AX xor __lhy,AX {visual page zustava, active se prepne} not _pagingactive End;{_togglepaging} procedure _ResetPages; Begin __lhy:=0; _setdisplayorigin(0,0); _pagingactive:=false; End;{resetpages} procedure _swap; assembler; Asm xor BX,BX xor CX,CX {pro hybani obrazovkou} mov DX,$03DA @cekani1: {cekani na navrat paprsku} in AL,DX test AL,8 jz @cekani1 mov AX,__lhy or AX,AX jz @ActiveNa1 {visual na 1:} mov AX,$4F07 mov DX,__lhy {obrazovka dolu} int $10 {active na 0:} xor AX,AX mov __lhy,AX {__lhy nahoru} jmp @prepnuto {hotovo} @ActiveNa1: {visual na 0:} mov AX,$4F07 xor DX,DX {obrazovka nahoru} int $10 {active na 1:} mov AX,_maxy inc AX mov __lhy,AX {__lhy dolu} @prepnuto: {call _vsyncstart {zaverecne cekani na paprsek (nekdy mi problikavalo to, co se kreslilo bezprostredne po volani _swapu, ale byl to natolik vzacny pripad, ze nestoji za to kvuli tomu takhle zpomalovat swapovani)} End;{_swap} (**************************************************************************** Rizeni spotreby *****************************************************************************) function _getallpmmodes:byte; assembler; Asm xor BX,BX mov AX,$4F10 xor DI,DI {\ ES a DI musi byt oboje 0 (rezervovano)} mov ES,BX {/ } int $10 cmp AX,$4F je @OK xor BX,BX {pri neuspechu vratime nulu, tj. "nepodporovano nic"} @OK: mov AL,BH End;{_getallpmmodes} function _getpmmode:byte; assembler; Asm mov AX,$4F10 mov BX,2 int $10 cmp AX,$4F je @OK xor BX,BX @OK: mov AL,BH End;{_getpmmode} procedure _SetPMMode(mode:byte); assembler; Asm mov AX,$4F10 mov BL,1 mov BH,mode int $10 End;{_setpmmode} (**************************************************************************** Rychle pruhledne obrazky *****************************************************************************) function _GetSprite(x1,y1,x2,y2:integer; target:pointer; Maxsize:word; transparentcolor:byte):boolean; label nevyjde; var buffer:^_8bytearray; {pro nacitani radku (jakekoli pole bytu indexovane od 0, pouzije se jenom jako sablona)} zacatek,konec, {pro pohyb v nactenem radku} index:word; {pro pohyb ve vystupnich datech} y,i:integer; {pomocne promenne} Begin {$ifdef blbuvzdornost} if x1>x2 then xchange(x1,x2); if y1>y2 then xchange(y1,y2); {$endif} _getsprite:=false; fillchar(target^,2,0); {pri neuspechu tam ta nula zustane} if (x2-x1+1>maxavail) or (maxsize<=2) then exit; {malo pameti na buffer nebo nedostatek pridelene pameti} getmem(buffer,x2-x1+1); {budeme cist cele radky a pak se v nich hrabat (podstatne rychlejsi nez getpixel)} index:=2; {na zacatku si nechavame 2 B na ulozeni velikosti} y:=y1; repeat {cyklus pro radky} _getimage(x1,y,x2,y,buffer); zacatek:=0; repeat {zpracovani jednoho radku} while (zacatek<=x2-x1)and(buffer^[zacatek]=transparentcolor) do inc(zacatek); if zacatek<=x2-x1 then begin {OK, jeste jsme na radku} konec:=zacatek; while (konectransparentcolor) do inc(konec); if index+konec-zacatek+7>maxsize then goto nevyjde; {nestaci pridelena pamet} {x:} i:=x1+zacatek; move(i,_8bytearray(target^)[index],2); inc(index,2); {y:} move(y,_8bytearray(target^)[index],2); inc(index,2); {delka:} i:=konec-zacatek+1; move(i,_8bytearray(target^)[index],2); inc(index,2); {data:} move(buffer^[zacatek],_8bytearray(target^)[index],i); inc(index,i); {hotovo, na radku se posuneme za konec useku:} zacatek:=konec+1; end; until zacatek>x2-x1; inc(y); until y>y2; _getsprite:=true; {jestli jsme jeste tady, podarilo se nacist vsechno} nevyjde: {sem skocime, kdyz v prubehu procedury dojde pamet pro vystupni data} move(index,target^,2); {na zacatek vystupu ulozime spocitanou delku} freemem(buffer,x2-x1+1); End;{_getsprite} procedure __PutSprite(x,y:integer; source:pointer); type uw=^word; ui=^integer; var index:word; Begin index:=2; while index