{
    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.