[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]
{
I modified the unit written by Sean Wenzel in order to speed
up the decoding of a picture . I wrote several parts using the ASM
capability of BP 7.0,but I did not change the NextCode procedure at
the beginning.
As I was interested in any improvement,I decided to use an external
procedure written in assembly language (named ASMGIF3.ASM) : I was
a little bit disappointed:it is not faster (not noticeable ...).
You can find :
- GIFUTIL9.PAS :the new unit ONLY for 256 colors !!!!!!
- GIFTST.PAS :an example based on the one written by Sean Wenzel.
- ASMGIF3.ASM :the ASM source of NextByte.
You can use,modified an distribute this source as long as credit is given.
Lionel CORDESSES
from FRANCE.
November 1994
E-Mail:
cordesse@opgc.univ-bpclermont.fr
"The Graphics Interchange Format(c) is the Copyright property of
CompuServe Incorporated. GIF(sm) is a Service Mark property of
CompuServe Incorporated."
}
unit GifUtil9;
{$R-} { range checking off } { Put them on if you like but it slows down }
{$S-} { stack checking off } { The decoding (almost doubles it!) }
{$I-} { i/o checking off }
interface
var status:byte;
procedure general(nom:string);
implementation
uses usvesa, Crt;
type
TDataSubBlock = record
Size: byte; { size of the block -- 0 to 255 }
Data: array[1..255] of byte; { the data }
end;
const
BlockTerminator: byte = 0; { terminates stream of data blocks }
type
THeader = record
Signature: array[0..2] of char; { contains 'GIF' }
Version: array[0..2] of char; { '87a' or '89a' }
end;
TLogicalScreenDescriptor = record
ScreenWidth: word; { logical screen width }
ScreenHeight: word; { logical screen height }
PackedFields: byte; { packed fields - see below }
BackGroundColorIndex: byte; { index to global color table }
AspectRatio: byte; { actual ratio = (AspectRatio + 15) / 64 }
end;
const
{ logical screen descriptor packed field masks }
lsdGlobalColorTable = $80; { set if global color table follows L.S.D. }
lsdColorResolution = $70; { Color resolution - 3 bits }
lsdSort = $08;
{ set if global color table is sorted - 1 bit }
lsdColorTableSize = $07; { size of global color
table - 3 bits }
{ Actual size =
2^value+1 - value is 3 bits }
type
TColorItem = record { one item a a color table }
Red: byte;
Green: byte;
Blue: byte;
end;
TColorTable = array[0..255] of TColorItem; { the color table }
const
ImageSeperator: byte = $2C;
type
TImageDescriptor = record
Seperator: byte; { fixed value
of ImageSeperator }
ImageLeftPos: word; {Column in pixels in respect to
left edge of logical screen }
ImageTopPos: word;{row in pixels in respect to top of
logical screen }
ImageWidth: word; { width of image in pixels }
ImageHeight: word; { height of image in pixels }
PackedFields: byte; { see below }
end;
const
{ image descriptor bit masks }
idLocalColorTable = $80; { set if a local color table follows }
idInterlaced = $40; { set if image
is interlaced }
idSort = $20;
{ set if color table is sorted }
idReserved = $0C; {
reserved - must be set to $00 }
idColorTableSize = $07; { size of color table as above }
Trailer: byte = $3B; { indicates the end of the GIF data stream }
{ other extension blocks not currently supported by this unit
- Graphic Control extension
- Comment extension I'm not sure what will happen if these blocks
- Plain text extension are encountered but it'll be interesting
- application extension }
const
ExtensionIntroducer: byte = $21;
MAXSCREENWIDTH = 800;
type
TExtensionBlock = record
Introducer: byte; { fixed
value of ExtensionIntroducer }
ExtensionLabel: byte;
BlockSize: byte;
end;
PCodeItem = ^TCodeItem;
TCodeItem = record
Code1, Code2: byte;
end;
const
MAXCODES = 4095; { the maximum number of different codes
0 inclusive }
const
{ error constants }
geNoError = 0; { no errors found }
geNoFile = 1; { gif file not found }
geNotGIF = 2; { file is not a gif file }
geNoGlobalColor = 3; { no Global Color table found }
geImagePreceded = 4; { image descriptor preceeded by other unknown data }
geEmptyBlock = 5; { Block has no data }
geUnExpectedEOF = 6; { unexpected EOF }
geBadCodeSize = 7; { bad code size }
geBadCode = 8; { Bad code was found }
geBitSizeOverflow = 9; { bit size went beyond 12 bits }
type
stream_ptr=^stream_type;
stream_type=record
Header: THeader;
{ gif file header }
LogicalScreen: TLogicalScreenDescriptor; { gif screen descriptor }
end;
var fichier:file;
stream:stream_type;
TableSize: word; { number of entrys in the color table }
GlobalColorTable: TColorTable; { global color table }
LocalColorTable: TColorTable; { local color table }
ImageDescriptor: TImageDescriptor; { image descriptor }
UseLocalColors: boolean; { true if local colors in use }
Interlaced: boolean; { true if image is interlaced }
InterlacePass: byte; { interlace pass number }
LZWCodeSize: byte; { minimum size of the LZW
codes in bits }
BitsLeft,BytesLeft: integer;{ bits left in byte - bytes left in block }
BadCodeCount: word; { bad code counter }
CurrCodeSize: integer; { Current size of code in bits }
ClearCode: integer; { Clear code value }
EndingCode: integer; { ending code value }
Slot: word; { position that the next new code is to be
added }
TopSlot: word; { highest slot position for the
current code size }
HighCode: word; { highest code that does not require decoding
}
NextByte: integer; { the index to the next byte in the
datablock array }
CurrByte: byte; { the current byte }
CurrentX, CurrentY: integer; { current screen locations }
ImageData: TDataSubBlock; { variable to store incoming gif data }
DecodeStack: array[0..MAXCODES] of byte; { stack for the decoded codes }
Prefix: array[0..MAXCODES] of word; { array for code prefixes }
Suffix: array[0..MAXCODES] of byte; { array for code suffixes }
LineBuffer: array[0..MAXSCREENWIDTH] of byte; { array for buffer line
output }
table:array[0..767] of byte;
indice_sp:integer; { index to the decode stack }
indice:word;
Retour: longint; { temporary return value }
{$L asmgif3}
function Power(A, N: integer): integer; { returns A raised to the
power of N }
begin
Power := 1 shl n;
end;
procedure TGif_Error(What: integer);
begin
Status := What;
if What=geNoFile then halt(1);
end;
{ TGif }
procedure TGif_Init(AGIFName: string);
begin
if Pos('.',AGifName) = 0 then { if the filename has no
extension add one }
AGifName := AGifName + '.gif';
{ New(stream, 2048);}
assign(fichier,agifname);
{$i-}
reset(fichier,1);
if ioresult<>0 then tgif_Error(geNoFile);
blockRead(fichier,stream, sizeof(Theader)); { read the header }
if stream.Header.Signature <> 'GIF' then tgif_Error(geNotGIF);
{ is vaild signature }
blockRead(fichier,stream.LogicalScreen, sizeof(TLogicalScreenDescriptor));
if stream.LogicalScreen.PackedFields and lsdGlobalColorTable =
lsdGlobalColorTable then
begin
TableSize :=
trunc(Power(2,(stream.LogicalScreen.PackedFields and lsdColorTableSize)+1));
blockread(fichier,GlobalColorTable,
TableSize*sizeof(TColorItem)); { read Global Color Table }
end
else
tgif_Error(geNoGlobalColor);
blockread(fichier,ImageDescriptor, sizeof(ImageDescriptor)); {
read image descriptor }
if ImageDescriptor.Seperator <> ImageSeperator then
{ verify that it is the descriptor }
tgif_Error(geImagePreceded);
if ImageDescriptor.PackedFields and idLocalColorTable =
idLocalColorTable then
begin
{ if local color table }
TableSize :=
trunc(Power(2,(ImageDescriptor.PackedFields and idColorTableSize)+1));
blockread(fichier,LocalColorTable,
TableSize*sizeof(TColorItem)); { read Local Color Table }
UseLocalColors := True;
end
else
UseLocalColors := false;
if ImageDescriptor.PackedFields and idInterlaced = idInterlaced then
begin
Interlaced := true;
InterlacePass := 0;
end;
Status := 0;
writeln('nb coul: ',tablesize);
end;
procedure TGif_Done;
begin
close(fichier);
end;
procedure InitCompressionStream;
var
I: integer;
n:byte;
begin
{ Initialize the graphics display }
blockread(fichier,LZWCodeSize, sizeof(byte));{ get minimum code size }
if not (LZWCodeSize in [2..9]) then { valid code sizes 2-9 bits }
tgif_Error(geBadCodeSize);
CurrCodeSize := succ(LZWCodeSize); { set the initial code size }
ClearCode := 1 shl LZWCodeSize; { set the clear code }
EndingCode := succ(ClearCode); { set the ending code }
HighCode := pred(ClearCode); { set the
highest code not needing decoding }
BytesLeft := 0; { clear other variables }
BitsLeft := 0;
CurrentX := 0;
CurrentY := 0;
end;
{$f-}
procedure TGif_ReadSubBlock;
begin
blockread(fichier,ImageData.Size, sizeof(ImageData.Size)); {
get the data block size }
if ImageData.Size = 0 then tgif_Error(geEmptyBlock); { check
for empty block }
blockread(fichier,ImageData.Data, ImageData.Size); { read in the block }
NextByte := 1; { reset next byte }
BytesLeft := ImageData.Size;
{ reset bytes left }
end;
const
CodeMask: array[0..12] of longint = ( { bit masks for use with Next code }
0,
$0001, $0003,
$0007, $000F,
$001F, $003F,
$007F, $00FF,
$01FF, $03FF,
$07FF, $0FFF);
{$f-}
function NextCode: word;external; { returns a code of the proper bit size }
procedure write_pal(var pal;start,quant:word);
begin
asm
push ds
lds si,pal
mov dx,3c8h
cld
mov cx,quant
mov bx,start
@deb1:
mov al,bl
out dx,al
inc dx
lodsb
out dx,al
lodsb
out dx,al
lodsb
out dx,al
dec dx
inc bl
loop @deb1
pop ds
end;
end;
procedure InitGraphics;
var
n:byte;
x,y,i:word;
begin
{ you can change the $101 value for other VESA modes }
n:=setmode($101);
if n =0 then
begin
Writeln('vesa error ');
Halt(1);
end;
{ the following loop sets up the RGB palette }
x:=0;
if not UseLocalColors then
begin
for I := 0 to TableSize - 1 do
begin
table[x]:=GlobalColorTable[I].Red div 4;
inc(x);
table[x]:=GlobalColorTable[i].Green div 4;
inc(x);
table[x]:=GlobalColorTable[I].Blue div 4;
inc(x);
end;
write_pal(table[0],0,tablesize);
end
else
begin
x:=0;
for I := 0 to TableSize - 1 do
begin
table[x]:=localColorTable[I].Red div 4;
inc(x);
table[x]:=localColorTable[i].Green div 4;
inc(x);
table[x]:=localColorTable[I].Blue div 4;
inc(x);
end;
write_pal(table[0],0,tablesize);
end;
{
for x:=0 to 255 do
for y:=0 to 255 do
setpix(x,y,x);}
end;
procedure DrawLine;
var
I: integer;
begin
if not write_fast(0,CurrentY,ImageDescriptor.ImageWidth,
LineBuffer[0]) then
for I := 0 to ImageDescriptor.ImageWidth do
setpix(I, CurrentY, LineBuffer[I]);
inc(CurrentY);
if InterLaced then { Interlace support }
begin
case InterlacePass of
0: CurrentY := CurrentY + 7;
1: CurrentY := CurrentY + 7;
2: CurrentY := CurrentY + 3;
3: CurrentY := CurrentY + 1;
end;
if CurrentY >= ImageDescriptor.ImageHeight then
begin
inc(InterLacePass);
case InterLacePass of
1: CurrentY := 4;
2: CurrentY := 2;
3: CurrentY := 1;
end;
end;
end;
end;
{ this procedure initializes the graphics mode and actually decodes the
GIF image }
procedure Decode(Beep: boolean);
{ local procedure that decodes a code and puts it on the decode stack }
procedure DecodeCode(var code:word);assembler;
asm
les di,code
mov bx,word ptr [es:di]
mov si,indice_sp
cmp bx,HighCode
jbe @@fin
@@boucle:
mov al,[offset word ptr Suffix+bx] { al:=suffix[code] }
mov [Offset word ptr DecodeStack+si],al { decodestack:=al }
inc si
shl bx,1 { array of word }
mov bx,[Offset word ptr Prefix+bx] {code:=prefix[code }
cmp bx,word ptr HighCode
ja @@boucle
@@fin:
mov [Offset word ptr DecodeStack+si],bx
inc si
mov indice_sp,si
mov word ptr [es:di],bx
end;
var
TempOldCode, OldCode: word;
BufCnt: word; { line buffer counter }
Code, C: word;
CurrBuf: word; { line buffer index }
begin
InitGraphics; { Initialize the graphics mode and RGB palette }
InitCompressionStream; { Initialize decoding paramaters }
OldCode := 0;
indice_sp := 0;
BufCnt := ImageDescriptor.ImageWidth; { set the Image Width }
CurrBuf := 0;
C := NextCode; { get
the initial code - should be a clear code }
while C <> EndingCode do { main loop until ending code is found }
begin
if C = ClearCode then { code is a clear code - so clear }
begin
CurrCodeSize := LZWCodeSize + 1;{ reset the code size }
Slot := EndingCode + 1;
{ set slot for next new code }
TopSlot := 1 shl CurrCodeSize; { set max slot number }
while C = ClearCode do
C := NextCode; { read
until all clear codes gone - shouldn't happen }
if C = EndingCode then
begin
tgif_Error(geBadCode); { ending code
after a clear code }
break;
{ this also should never happen }
end;
if C >= Slot { if the code is beyond preset
codes then set to zero }
then c := 0;
OldCode := C;
DecodeStack[indice_sp] := C;
{ output code to decoded stack }
inc(indice_sp);
{ increment decode stack index }
end
else { the code is not a clear code or an ending code
so it must }
begin { be a code code - so decode the code }
Code := C;
if Code < Slot then { is the code in the table? }
begin
DecodeCode(Code);
{ decode the code }
if Slot <= TopSlot then
begin { add
the new code to the table }
Suffix[Slot] := Code;
{ make the suffix }
PreFix[slot] := OldCode;
{ the previous code - a link to the data }
inc(Slot);
{ increment slot number }
OldCode := C;
{ set oldcode }
end;
if Slot >= TopSlot then { have reached
the top slot for bit size }
begin { increment code bit size }
if CurrCodeSize < 12 then { new
bit size not too big? }
begin
TopSlot := TopSlot shl
1; { new top slot }
inc(CurrCodeSize)
{ new code size }
end
else
tgif_Error(geBitSizeOverflow); { encoder made a boo boo }
end;
end
else
begin { the code is not in the table }
if Code <> Slot then
{ code is not the next available slot }
tgif_Error(geBadCode); { so error out }
{ the code does not exist so make a new
entry in the code table
and then translate the new code }
TempOldCode := OldCode; { make a copy
of the old code }
while OldCode > HighCode do { translate
the old code and place it }
begin
{ on the decode stack }
DecodeStack[indice_sp] :=
Suffix[OldCode]; { do the suffix }
OldCode := Prefix[OldCode];
{ get next prefix }
end;
DecodeStack[indice_sp] := OldCode;
{ put the code onto the decode stack }
{ but DO NOT increment stack index }
{ the decode stack is not incremented
because because we are only
translating the oldcode to get
the first character }
if Slot <= TopSlot then
begin { make new code entry }
Suffix[Slot] := OldCode;
{ first char of old code }
Prefix[Slot] := TempOldCode; {
link to the old code prefix }
inc(Slot); {
increment slot }
end;
if Slot >= TopSlot then { slot is too big }
begin { increment code size }
if CurrCodeSize < 12 then
begin
TopSlot := TopSlot shl
1; { new top slot }
inc(CurrCodeSize)
{ new code size }
end
else
tgif_Error(geBitSizeOverFlow);
end;
DecodeCode(Code); { now that the table
entry exists decode it }
OldCode := C; { set the new old code }
end;
end;
{ the decoded string is on the decode stack so pop it
off and put it
into the line buffer }
asm
mov cx,BufCnt
mov si,CurrBuf
mov bx,indice_sp
cmp bx,0
je @@fin
@@boucle:
dec bx
mov al,[offset byte ptr DecodeStack+bx]
mov [offset byte ptr LineBuffer+si],al
inc si
dec cx
jnz @@suite
pusha
push di
call DrawLine
pop di
popa
mov si,0
mov cx,[offset ImageDescriptor.ImageWidth]
@@suite:
cmp bx,0
ja @@boucle
@@fin:
mov BufCnt,cx
mov indice_sp,bx
mov CurrBuf,si
end;
C := NextCode; { get the next code and go at is some more }
end; { now that wasn't all that bad was it? }
if Beep then
if Status = 0 then
begin
Sound(200); { Beep if status is ok }
Delay(0);
NoSound;
end
else
begin
Sound(1100); { Boop if status is not ok }
Delay(0);
NoSound;
end;
end;
procedure general(nom:string);
begin
tgif_init(nom);
decode(true);
tgif_done;
end;
end.
{
cut here
----------------------------------------------------------------------------
}
program Gift;
{
Gifutil9 sample program
November 1994
}
uses GifUtil9, CRT, Dos;
var
A: string;
Hours, Minutes, Seconds, Sec100: word;
H, M, S, S100: word;
tps1,tps2:longint;
function donne_heure:longint;
var heure,minute,seconde,sec100:word;
begin
gettime(heure,minute,seconde,sec100);
donne_heure:=heure*3600*100+minute*60*100+seconde*100+sec100;
end;
begin
Writeln('Sample program for using GIFUTIL9.PAS unit');
Writeln;
Writeln('Based on code written by Sean Wenzel ');
Writeln('Modified by Lionel Cordesses ( FRANCE )');
Writeln('Only tested with 256 colors GIF pictures ...');
Writeln('Press ENTER ');
Readln;
if ParamCount <> 1 then
begin
Writeln('use: gift <gifname>[.gif] to run...');
Exit;
end;
GetTime(Hours, Minutes, Seconds, Sec100);
tps1:=donne_heure;
general(ParamStr(1));
tps2:=donne_heure;
GetTime(H, M, S, S100);
readln;
textmode(co80);
writeln('time: ',tps2-tps1);
while not(KeyPressed) do;
writeln('"The Graphics Interchange Format(c) is the Copyright property of');
writeln('CompuServe Incorporated. GIF(sm) is a Service Mark property of ');
writeln('CompuServe Incorporated."');
end.
{ cut here
-----------------------------------------------------------------------------
}
;ASMGIF3 for GIFUTILxx.pas Lionel CORDESSES (November 1994 )
.model large,pascal
data segment public
data ends
radix 10
P386
NOSMART
dataseg
extrn NextByte:word;
extrn BitsLeft:word;
extrn BytesLeft:word;
extrn ImageData:near ptr dword;
extrn CurrByte:byte;
extrn retour:dword;
extrn CurrCodeSize:word;
extrn CodeMask:near ptr dword;
.code
extrn tgif_ReadSubBlock
NextCode PROC near
public NextCode
mov ax,[BitsLeft]
cmp ax,0
jg @@suite1
mov ax,[BytesLeft]
cmp ax,0
jg @@suite2
; if buffer is empty
pusha
push di
call near ptr Tgif_ReadSubBlock
pop di
popa
@@suite2:
mov bx,[NextByte]
mov al,byte ptr [offset ImageData+bx] ;
mov [CurrByte],al
inc bx
mov [NextByte],bx
mov [BitsLeft],8
dec [BytesLeft]
@@suite1:
mov eax,0
mov al,[CurrByte]
mov cx,8
mov dx,[BitsLeft]
sub cx,dx
shr eax,cl
mov cx,dx ;save BitsLeft in CX
mov edx,eax
mov bx,[NextByte]
@@while:
cmp [CurrCodeSize],cx
jng @@fin2
cmp [BytesLeft],0
jg @@suite4
; if buffer is empty
pusha
push di
call near ptr Tgif_ReadSubBlock
pop di
popa
mov bx,[NextByte]
@@suite4:
mov eax,0
mov al,byte ptr [offset ImageData+bx] ;
mov [CurrByte],al
inc bx
shl eax,cl
or edx,eax
add cx,8
dec [BytesLeft]
jmp @@while
@@fin2:
mov [NextByte],bx
mov bx,[CurrCodeSize]
sub cx,bx
mov [BitsLeft],cx
shl bx,2 ; longint = 4 Bytes !!!!
lea di,[CodeMask]
mov eax,[di+bx]
and edx,eax
; mov [retour],edx
mov ax,dx
ret
;tasm_shl endp
NextCode endp
end
{ cut here
-----------------------------------------------------------------------------
Here is the ASMGIF3.OBJ file in .XX format
}
*XX3402-001268-171194--72--85-08325-----ASMGIF3.OBJ--1-OF--1
U02+5oAuL27EL2l7HplHJYR-L3J5GINQEJBBFoZ4Amt-IoogW0+++++QJ5JmMawUELBnNKpW
P4Jm60-KNL7nOKxi61AiAda67k-+uJ6yMFoTEndQEZ-QH2ZDL3BKFo3QJIR7FZl-Iop5GIMn
9Y3HHSS6+k-+uImK+U++O6U1+20VZ7MH++l-Iop5GIMnLpF3K3E2Eox2FNuM-k-6eU+0+k3d
ZUk+-Jx2EJF--2F-J250a+Q+G+++-+I-1tM4++F2EJF-FdU5+4U+++M-+T4K0++4F2RGHpJE
Wtc2++Tz+ZeA0k+6HaJsR27tR4I+9cU2+21U0YeA0k+6EaZoQolZNbE+F6U2+21U0YeA1++7
EbZoNLBANKNo+Aq6-+-+s+d8X+k+0IZhMKRZF43oME+0W+E+EC+8Gck9++V1RL7mEbZoNE+l
W+E+EC+6H6k7++NmNLFjRL6+l6U2+21U12WA1k+AErJmQYBjN4JHOLdZ+8S6-+-+s+d8X+g+
02BjN4JBMLBf+3e6-+-+s+d8X-E+2LFbOKNTIaJVN3BpMY7gPqBf+9K6-+-+s+d8Y+w+++26
HaJsR2BjN4I++++yW+I+EC2R+1K6-+-+cU4FW+I+ECc2+2K60+-+slU+-U+e-MU7+21X4E++
+0E+1sU7+21X4U+++0E-1MU9+21X4k+++0A++++AW+g+ECAQ++++6k+2++S60k-+slo++++X
++2+0MU9+21X5U+++0A+-E+2W+c+ECAT++6+3Ek+0MUc+21c+-x1CZl0I3lAGIxQIpN5EJlJ
FoZ4L23HHIR7FXAiEJBBIXtV5SSIsk+++G+++++V++A+6U+4+0E+0U+Z++o+7U+E+0Y+3++e
+-I+8k+K+0k+4E+h+-c+A++P+16+5k+n+0A+BE+a+1M+7k+r+0g+C++l+1g+BE+w+1g+DE+y
+1s+EE+z+2I+E+-5+22+GU-0+2k+Ek-D+2M+Ik-5+3Q+GE-P+2c+M+-A+4E+HE-Z+2s+NU-D
+4Y+I+-e+32+Ok-J+4w+Jk-p+3U+SE-N+5k+L+-x+3o+U+-T+6A+M+04+46+WU-Z+6k+NU0E
+4Q+Z+-c+7M+OE0O+4c+bE-f+82+P+0Y+4s+dk-j+8Y+ZMUG+21a02-+IpJ7J2Im4E+++Fg+
lsUG+21a02-+IpJ7J2Il4E+++HI+fcUF+21a-o-+JoV7H2IN+++-Ik1IW-6+ECM6E2-HJIZI
FHEN+++-Pk-lW-++ECM4E2-4GIsm4E+++Mk+-sUG+21a02t3K3F1HoF35E+++E++k80i++2+
+82++1o++5whY70V+++x++-z0N0EM3Tc++-TMMgS++08Vk++cU++EsYS++15-U++0+1z1U++
NfU+++++c+++iEU+WlM++0j8NhDcWwdaWx095U++CEs++5snY701DU+++5wBY7-UJyU++3xV
Wls++4Os+++++6e5++0W++-1NhDUNUjEUw26zks++Cj5WFs++6gS+++fmsYC++1-sk8BDU++
Ncg-NWDEWw91Jdlo+AE-3U20l+gK+EC23kM-0QER3U2-l02K+EH27-M--QEd3U2-l0oK+E92
AlM-+wEw3U23l2AK+E92IFM-+QFJ3U25l3oK+EC2NkM-0QFh3U2-l5QK+EH2SVM--QG63U21
l6sK+E52YVM--wGM3U20l7wK+EVLWU6++5E+
***** END OF BLOCK 1 *****
{ cut here
----------------------------------------------------------------------------
}
unit usvesa;
{
****************************************************************************
Here is an other VESA unit !!!!!!
It is based on various sources ( DVPEG,John Bridges VGAKIT,
SWAG an many others ).
You can use,modified an distribute this source as long as credit
is given.
Supported modes:
- 256 colors
- 32768 colors
- 16 millions colors
The demo program for this unit is DemoVesa.
Lionel Cordesses
From FRANCE.
November 1994
****************************************************************************
}
{$f+}
interface
uses dos,crt;
var
use_16,use_32:boolean;
x_size:word;
function write_fast(x1,y,x2:word;var entree):boolean;
procedure getpix_16(x,y:word;var rouge,vert,bleu:byte);
procedure find_black(max_color:word;var black,white:byte);
function setmode(mode:word):byte; { return 0 if bad, 1 if OK }
procedure setpix(x,y,col:word);
procedure setpix_16(x,y:word;rouge,vert,bleu:byte);
function getpix(x,y:word):byte;
procedure wrtxt(x,y:word;txt:string);{write TXT to pos (X,Y)}
implementation
var
reg:registers;
vgran,curbank:word;
add_bank:procedure;
tps1,tps2:longint;
heure,minute,seconde,sec100:word;
{$ifdef msdos}
procedure setbank(bank:byte);far;
var banque:word;
begin
banque:=bank*longint(64) div vgran;
asm
mov bl, 0
mov dx, banque
call [add_bank]
end;
curbank:=bank;
end;
{$else}
procedure setbank(bank:byte{word});far;
var banque:word;
begin
reg.ax:=$4f05;
reg.bx:=0;
reg.dx:=bank*longint(64) div vgran;
intr($10,reg);
reg.ax:=$4f05;
reg.bx:=1;
intr($10,reg);
curbank:=255;{bank;}
end;
{$endif}
function setvesa(mode:word):byte;
begin
asm
mov ax,4F02h
mov bx,mode
int 10h
sub ax,004Fh
(* mov al,0
cmp ah,1 { if ah=1 that is bad ==>false }
je @fin
mov al,1 {false }
@fin:*)
mov @RESULT,al
end;
{ reg.ax:=$4f02;
reg.bx:=mode;
intr($10,reg);
setvesa:=reg.al;}
{ textmode(co80);
write(reg.ah,' ',reg.al);
readln;}
end;
{$ifdef msdos}
function setmode(mode:word):byte; { 0 if bad,1 if OK}
type type_vesarec=array[0..555] of byte;
ves_ptr=^type_vesarec;
type
long=record
lo,hi:word;
end;
var pro:byte;
vesarec:ves_ptr;
vesa_info:record
debut:array[0..3] of byte;
granularite:word;
winsize,
winaseg,
winbseg:word;
add_proc:procedure;
bytes:word;
width,
height:word;
reste:array[0..250] of byte;
end;
begin
setmode:=1;
getmem(vesarec,556);
pro:=setvesa(mode);
fillchar(vesarec^[0],256,0); { set all to zero }
reg.ax:=$4f01;
reg.cx:=mode;
reg.es:=long(vesarec).hi;
reg.di:=long(vesarec).lo;
intr($10,reg);
if reg.ah=0 then
begin
setmode:=1;
pro:=1;
end
else
begin
setmode:=0;
pro:=0;
end;
move(vesarec^[0],vesa_info.debut[0],256);
if reg.al=0 then
begin
setmode:=1;
pro:=1;
end;
vgran:=vesa_info.granularite;
x_size:=vesa_info.width; { nb pt per lines }
add_bank:=vesa_info.add_proc; { change bank far ptr }
freemem(vesarec,556);
use_16:=false;
use_32:=false;
if mode=$112 then use_16:=true;
if mode=$110 then use_32:=true;
end;
{$endif}
procedure setpix(x,y,col:word);assembler;
var decalage:word;
asm
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
{mov provi,al} { bank }
mov decalage,bx
cmp ax,curbank
jz @nonew
mov ah,0
push cs
push ax
call far ptr setbank { here ax = bank }
@nonew:
mov bx,col
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
end;
procedure getpix_16(x,y:word;var rouge,vert,bleu:byte);assembler;
var l:longint;
provi:byte;
couleur,decalage:word;
asm
mov al,use_16
cmp al,0
je @v32000
mov bx,x
mov ax,bx
shl bx,1
add bx,ax { x*3 }
mov ax,y {removed all range checking on x,y for speed}
shl ax,1
add ax,y { y*3 }
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
jz @nonewa
mov ah,0
push cs
push ax
call far ptr setbank { here ax= bank }
@nonewa:
mov ax,sega000
mov es,ax
mov di,decalage
mov bl,[es:di]
les di,bleu
mov byte ptr [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
mov provi,al
cmp ax,curbank
jz @nonew1
mov ah,0
push cs
push ax
call far ptr setbank { ax = bank }
@nonew1:
mov ax,sega000
mov es,ax
mov di,decalage
mov bl,[es:di]
les di,vert
mov byte ptr [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
cmp ax,curbank
jz @nonew2
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew2:
mov ax,sega000
mov es,ax
mov di,decalage
mov bl,[es:di]
les di,rouge
mov byte ptr [es:di],bl
jmp @fin
@v32000:
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
shl ax, 1
shl bx, 1
adc ax, 0 { pour untiliser un eventuel carry
positionne par precedent ADD }
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
je @nonew
{ mov ah,0}
push cs
push ax
call far ptr setbank { ax = bank }
@nonew:
mov ax,sega000
mov es,ax
mov di,decalage
mov bx,[es:di]
mov al,bl
and al,31
shl al,3
les di,bleu
mov byte ptr [es:di],al
shr bx,5
mov al,bl
and al,31
shl al,3
les di,vert
mov byte ptr [es:di],al
shr bx,5
mov al,bl
and al,31
shl al,3
les di,rouge
mov byte ptr [es:di],al
@fin:
end;
procedure setpix_16(x,y:word;rouge,vert,bleu:byte);
var l:longint;
provi:byte;
couleur,decalage:word;
begin
if use_16=true then
asm
mov bx,x
mov ax,bx
shl bx,1
add bx,ax { x*3 }
mov ax,y {removed all range checking on x,y for speed}
shl ax,1
add ax,y { y*3 }
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
jz @nonew
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew:
mov bl,bleu
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
mov provi,al
cmp ax,curbank
jz @nonew1
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew1:
mov bl,vert
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
cmp ax,curbank
jz @nonew2
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew2:
mov bl,rouge
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
end;
if use_32=true then
asm
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
shl ax, 1
shl bx, 1
adc ax, 0 { pour untiliser un eventuel carry
positionne par precedent ADD }
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
je @nonew
{ mov ah,0}
push cs
push ax
call far ptr setbank { ax= bank }
@nonew:
mov al,rouge
shr al,3
mov ah,0
shl ax,10
mov bl,vert
shr bl,3
mov bh,0
shl bx,5
add ax,bx
mov bl,bleu
shr bl,3
mov bh,0
add bx,ax
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bx
end;
end;
Procedure Move16(Var Source,Dest;Count:Word); Assembler;
Asm
PUSH DS
LDS SI,SOURCE
LES DI,DEST
MOV AX,COUNT
MOV CX,AX
SHR CX,1
REP MOVSW
TEST AX,1
JZ @end
MOVSB
@end:POP DS
end;
function write_fast(x1,y,x2:word;var entree):boolean;
var coord1,coord2:longint;
couleur:byte;
begin
write_fast:=false;
coord1:=longint(y)*longint(x_size)+x1;
coord2:=coord1+longint((x2-x1)+1);
if (coord1 shr 16)<> curbank then setbank(coord1 shr 16);
if (coord1 shr 16)=(coord2 shr 16) then
begin
move16(entree,mem[sega000:(coord1 mod 65536)],(x2-x1+1));
write_fast:=true;
end;
end;
function donne_heure:longint;
var heure,minute,seconde,sec100:word;
begin
gettime(heure,minute,seconde,sec100);
donne_heure:=heure*3600*100+minute*60*100+seconde*100+sec100;
end;
procedure find_black(max_color:word;var black,white:byte);
var luminance,n:byte;
reg:registers;
table:array[0..767] of byte;
i,x,y:word;
begin
with reg do
begin
ah:=$10;
al:=$17;
bx:=0;
cx:=max_color;
es:=seg(table);
dx:=ofs(table);
intr($10,reg);
end;
i:=0;
white:=0;
black:=255;
for n:=0 to max_color-1 do
begin
luminance:=round(((0.59*table[i+1])+(0.3*table[i])+
(0.11*table[i+2])));
if luminance>white then
begin
white:=luminance;
x:=n;
end;
if luminance<black then
begin
black:=luminance;
y:=n;
end;
inc(i,3);
end;
i:=0;
black:=y;
white:=x;
end;
procedure wrtxt(x,y:word;txt:string);{write TXT to pos (X,Y)}
type
pchar=array[char] of array[0..15] of byte;
var
p:^pchar;
c:char;
i,j,z,b:integer;
noir,blanc:byte;
begin
reg.ax:=$1130;
reg.bh:=6;
intr($10,reg);
p:=ptr(reg.es,reg.bp);
if (use_16=false) and (use_32=false) then
find_black(256,noir,blanc)
else
begin
noir:=0;
blanc:=255;
end;
for z:=1 to length(txt) do
begin
c:=txt[z];
for j:=0 to 15 do
begin
b:=p^[c][j];
for i:=x+7 downto x do
begin
if (use_16=false) and (use_32=false) then
begin
if odd(b) then setpix(i,y+j,blanc)
else setpix(i,y+j,noir);
end
else
begin
if odd(b) then setpix_16(i,y+j,blanc,blanc,blanc)
else setpix_16(i,y+j,noir,noir,noir);
end;
b:=b shr 1;
end;
end;
inc(x,8);
end;
end;
function getpix(x,y:word):byte;assembler;
var decalage:word;
asm
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
{mov provi,al} { bank }
mov decalage,bx
cmp ax,curbank
jz @nonew
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew:
mov ax,sega000
mov es,ax
mov di,decalage
mov al,[es:di]
end;
end.
{
This is the second part of a message for SWAG dealing with VESA
cards.
{
****************************************************************************
Here is an other VESA unit !!!!!!
It is based on various sources ( DVPEG,John Bridges VGAKIT,
SWAG an many others ).
You can use,modified an distribute this source as long as credit
is given.
Supported modes:
- 256 colors
- 32768 colors
- 16 millions colors
The demo program for this unit is DemoVesa.
Lionel Cordesses
From FRANCE.
November 1994
E-Mail:
cordesse@opgc.univ-bpclermont.fr
****************************************************************************
}
unit usvesa;
{$f+}
interface
uses dos,crt;
var
use_16,use_32:boolean;
x_size:word;
function write_fast(x1,y,x2:word;var entree):boolean;
procedure getpix_16(x,y:word;var rouge,vert,bleu:byte);
procedure find_black(max_color:word;var black,white:byte);
function setmode(mode:word):byte; { return 0 if bad, 1 if OK }
procedure setpix(x,y,col:word);
procedure setpix_16(x,y:word;rouge,vert,bleu:byte);
function getpix(x,y:word):byte;
procedure wrtxt(x,y:word;txt:string);{write TXT to pos (X,Y)}
implementation
var
reg:registers;
vgran,curbank:word;
add_bank:procedure;
tps1,tps2:longint;
heure,minute,seconde,sec100:word;
{$ifdef msdos}
procedure setbank(bank:byte);far;
var banque:word;
begin
banque:=bank*longint(64) div vgran;
asm
mov bl, 0
mov dx, banque
call [add_bank]
end;
curbank:=bank;
end;
{$else}
procedure setbank(bank:byte{word});far;
var banque:word;
begin
reg.ax:=$4f05;
reg.bx:=0;
reg.dx:=bank*longint(64) div vgran;
intr($10,reg);
reg.ax:=$4f05;
reg.bx:=1;
intr($10,reg);
curbank:=255;{bank;}
end;
{$endif}
function setvesa(mode:word):byte;
begin
asm
mov ax,4F02h
mov bx,mode
int 10h
sub ax,004Fh
(* mov al,0
cmp ah,1 { if ah=1 that is bad ==>false }
je @fin
mov al,1 {false }
@fin:*)
mov @RESULT,al
end;
{ reg.ax:=$4f02;
reg.bx:=mode;
intr($10,reg);
setvesa:=reg.al;}
{ textmode(co80);
write(reg.ah,' ',reg.al);
readln;}
end;
{$ifdef msdos}
function setmode(mode:word):byte; { 0 if bad,1 if OK}
type type_vesarec=array[0..555] of byte;
ves_ptr=^type_vesarec;
type
long=record
lo,hi:word;
end;
var pro:byte;
vesarec:ves_ptr;
vesa_info:record
debut:array[0..3] of byte;
granularite:word;
winsize,
winaseg,
winbseg:word;
add_proc:procedure;
bytes:word;
width,
height:word;
reste:array[0..250] of byte;
end;
begin
setmode:=1;
getmem(vesarec,556);
pro:=setvesa(mode);
fillchar(vesarec^[0],256,0); { set all to zero }
reg.ax:=$4f01;
reg.cx:=mode;
reg.es:=long(vesarec).hi;
reg.di:=long(vesarec).lo;
intr($10,reg);
if reg.ah=0 then
begin
setmode:=1;
pro:=1;
end
else
begin
setmode:=0;
pro:=0;
end;
move(vesarec^[0],vesa_info.debut[0],256);
if reg.al=0 then
begin
setmode:=1;
pro:=1;
end;
vgran:=vesa_info.granularite;
x_size:=vesa_info.width; { nb pt per lines }
add_bank:=vesa_info.add_proc; { change bank far ptr }
freemem(vesarec,556);
use_16:=false;
use_32:=false;
if mode=$112 then use_16:=true;
if mode=$110 then use_32:=true;
end;
{$endif}
procedure setpix(x,y,col:word);assembler;
var decalage:word;
asm
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
{mov provi,al} { bank }
mov decalage,bx
cmp ax,curbank
jz @nonew
mov ah,0
push cs
push ax
call far ptr setbank { here ax = bank }
@nonew:
mov bx,col
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
end;
procedure getpix_16(x,y:word;var rouge,vert,bleu:byte);assembler;
var l:longint;
provi:byte;
couleur,decalage:word;
asm
mov al,use_16
cmp al,0
je @v32000
mov bx,x
mov ax,bx
shl bx,1
add bx,ax { x*3 }
mov ax,y {removed all range checking on x,y for speed}
shl ax,1
add ax,y { y*3 }
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
jz @nonewa
mov ah,0
push cs
push ax
call far ptr setbank { here ax= bank }
@nonewa:
mov ax,sega000
mov es,ax
mov di,decalage
mov bl,[es:di]
les di,bleu
mov byte ptr [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
mov provi,al
cmp ax,curbank
jz @nonew1
mov ah,0
push cs
push ax
call far ptr setbank { ax = bank }
@nonew1:
mov ax,sega000
mov es,ax
mov di,decalage
mov bl,[es:di]
les di,vert
mov byte ptr [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
cmp ax,curbank
jz @nonew2
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew2:
mov ax,sega000
mov es,ax
mov di,decalage
mov bl,[es:di]
les di,rouge
mov byte ptr [es:di],bl
jmp @fin
@v32000:
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
shl ax, 1
shl bx, 1
adc ax, 0 { if carry }
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
je @nonew
{ mov ah,0}
push cs
push ax
call far ptr setbank { ax = bank }
@nonew:
mov ax,sega000
mov es,ax
mov di,decalage
mov bx,[es:di]
mov al,bl
and al,31
shl al,3
les di,bleu
mov byte ptr [es:di],al
shr bx,5
mov al,bl
and al,31
shl al,3
les di,vert
mov byte ptr [es:di],al
shr bx,5
mov al,bl
and al,31
shl al,3
les di,rouge
mov byte ptr [es:di],al
@fin:
end;
procedure setpix_16(x,y:word;rouge,vert,bleu:byte);
var l:longint;
provi:byte;
couleur,decalage:word;
begin
if use_16=true then
asm
mov bx,x
mov ax,bx
shl bx,1
add bx,ax { x*3 }
mov ax,y {removed all range checking on x,y for speed}
shl ax,1
add ax,y { y*3 }
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
jz @nonew
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew:
mov bl,bleu
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
mov provi,al
cmp ax,curbank
jz @nonew1
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew1:
mov bl,vert
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
add decalage,1
mov ah,0
mov al,provi
adc ax,0
cmp ax,curbank
jz @nonew2
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew2:
mov bl,rouge
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bl
end;
if use_32=true then
asm
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
shl ax, 1
shl bx, 1
adc ax, 0 { if carry }
mov provi,al { bank }
mov decalage,bx
cmp ax,curbank
je @nonew
{ mov ah,0}
push cs
push ax
call far ptr setbank { ax= bank }
@nonew:
mov al,rouge
shr al,3
mov ah,0
shl ax,10
mov bl,vert
shr bl,3
mov bh,0
shl bx,5
add ax,bx
mov bl,bleu
shr bl,3
mov bh,0
add bx,ax
mov ax,sega000
mov es,ax
mov di,decalage
mov [es:di],bx
end;
end;
Procedure Move16(Var Source,Dest;Count:Word); Assembler;
Asm
PUSH DS
LDS SI,SOURCE
LES DI,DEST
MOV AX,COUNT
MOV CX,AX
SHR CX,1
REP MOVSW
TEST AX,1
JZ @end
MOVSB
@end:POP DS
end;
function write_fast(x1,y,x2:word;var entree):boolean;
var coord1,coord2:longint;
couleur:byte;
begin
write_fast:=false;
coord1:=longint(y)*longint(x_size)+x1;
coord2:=coord1+longint((x2-x1)+1);
if (coord1 shr 16)<> curbank then setbank(coord1 shr 16);
if (coord1 shr 16)=(coord2 shr 16) then
begin
move16(entree,mem[sega000:(coord1 mod 65536)],(x2-x1+1));
write_fast:=true;
end;
end;
function donne_heure:longint;
var heure,minute,seconde,sec100:word;
begin
gettime(heure,minute,seconde,sec100);
donne_heure:=heure*3600*100+minute*60*100+seconde*100+sec100;
end;
procedure find_black(max_color:word;var black,white:byte);
var luminance,n:byte;
reg:registers;
table:array[0..767] of byte;
i,x,y:word;
begin
with reg do
begin
ah:=$10;
al:=$17;
bx:=0;
cx:=max_color;
es:=seg(table);
dx:=ofs(table);
intr($10,reg);
end;
i:=0;
white:=0;
black:=255;
for n:=0 to max_color-1 do
begin
luminance:=round(((0.59*table[i+1])+(0.3*table[i])+
(0.11*table[i+2])));
if luminance>white then
begin
white:=luminance;
x:=n;
end;
if luminance<black then
begin
black:=luminance;
y:=n;
end;
inc(i,3);
end;
i:=0;
black:=y;
white:=x;
end;
procedure wrtxt(x,y:word;txt:string);{write TXT to pos (X,Y)}
type
pchar=array[char] of array[0..15] of byte;
var
p:^pchar;
c:char;
i,j,z,b:integer;
noir,blanc:byte;
begin
reg.ax:=$1130;
reg.bh:=6;
intr($10,reg);
p:=ptr(reg.es,reg.bp);
if (use_16=false) and (use_32=false) then
find_black(256,noir,blanc)
else
begin
noir:=0;
blanc:=255;
end;
for z:=1 to length(txt) do
begin
c:=txt[z];
for j:=0 to 15 do
begin
b:=p^[c][j];
for i:=x+7 downto x do
begin
if (use_16=false) and (use_32=false) then
begin
if odd(b) then setpix(i,y+j,blanc)
else setpix(i,y+j,noir);
end
else
begin
if odd(b) then setpix_16(i,y+j,blanc,blanc,blanc)
else setpix_16(i,y+j,noir,noir,noir);
end;
b:=b shr 1;
end;
end;
inc(x,8);
end;
end;
function getpix(x,y:word):byte;assembler;
var decalage:word;
asm
mov bx,x
mov ax,y {removed all range checking on x,y for speed}
mul x_size {640 bytes wide in most cases}
add bx,ax
adc dx,0
mov ax, dx { what a $#%%# stupid microprocessor}
adc ax, 0
{mov provi,al} { bank }
mov decalage,bx
cmp ax,curbank
jz @nonew
mov ah,0
push cs
push ax
call far ptr setbank { ax= bank }
@nonew:
mov ax,sega000
mov es,ax
mov di,decalage
mov al,[es:di]
end;
end.
{ cut here
----------------------------------------------------------------------------
}
program VesaDemo;
{
*****************************************************************************
Sample program for the unit Usvesa.
Only 2 mode tested here:
- 256 colors
- 16 millions colors
You can change the
"n:=setmode($112);" and write :
"n:=setmode($110);" .
I am sure that you will see the difference between 32768 an 16 millions
colors !!!
Lionel Cordesses
From FRANCE.
November 1994
*****************************************************************************
}
{$f+}
uses dos,crt,usvesa;
var n:byte;
x,y,i:word;
ch:char;
funckey:boolean;
code:byte;
procedure touche(var funckey:boolean;var code:byte);
var ch:char;
begin
while keypressed do
ch:=readkey;
repeat
until not keypressed;
ch:=readkey;
if ch<>#0 then funckey:=false
else
begin
funckey:=true;
ch:=readkey;
end;
code:=ord(ch);
end;
procedure test_256;
begin
clrscr;
writeln('Testing VESA mode 640x480 256 colors');
writeln('Press a key ...');
repeat
touche(funckey,code)
until (code<>0) or (funckey=true);
n:=setmode($101);
if n=0 then
begin
textmode(co80);
writeln('WARNING:no VESA driver or unsupported mode !!! ');
halt(1);
end;
for x:=0 to 255 do
for y:=0 to 255 do
setpix(x,y,x);
wrtxt(10,300,'Mode VESA 101h OK : Press a key to quit ...');
repeat
touche(funckey,code)
until (code<>0) or (funckey=true);
textmode(co80);
end;
procedure test_16;
begin
clrscr;
writeln('Testing VESA mode 640x480 16 millions colors');
writeln('Press a key ...');
repeat
touche(funckey,code)
until (code<>0) or (funckey=true);
n:=setmode($112);
if n=0 then
begin
textmode(co80);
writeln('WARNING:no VESA driver or unsupported mode !!! ');
halt(1);
end;
for y:=0 to 255 do
for x:=0 to 255 do
setpix_16(x,y,x,y,255-x);
wrtxt(10,300,'Mode VESA 112h OK : Press a key to quit ...');
repeat
touche(funckey,code)
until (code<>0) or (funckey=true);
textmode(co80);
end;
begin
test_256;
test_16;
textmode(co80);
end.
[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]