[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]
{ see the demo at the end of this unit }
(*
*****************************************************************************
Copyright (C) 1995 Lionel CORDESSES
This source is a part of a program that allows you to read and display
a color or a black and white JPEG picture . I wrote the full source in
order to understand how it works . Some parts are translated from C
language to Pascal (the reverse DCT for instance ).
I used many sources of informations:
- "The JPEG Still Picture Compression Standart" by G.K.Wallace,
- C sources and doc from the Independent JPEG Group's software,
- C sources and doc from the Portable Video Research Group (PVRG)
code,
- the FAQ about JPEG,
- "JPEG Compression" by C.Cavigioli (ANALOG DEVICE application note
AN-336B )
- and many others ...
You can use , modified and distribute this source as long as credit is
given.
*****************************************************************************
*)
{
****************************************************************************
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.
June 1995
****************************************************************************
}
unit usvesa3;
interface
uses dos,crt;
var
use_16,use_32:boolean;
x_size:word;
Function write_fast_16(x1,y,x2,indice:word;var rouge,vert,bleu):boolean;
Function get_time:longint;
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)}
Function write_fast_16_BRG(x1,y,x2:word;var image):boolean;
implementation
var
reg:registers;
vgran,curbank:word;
add_bank:Procedure;
tps1,tps2:longint;
heure,minute,seconde,sec100:word;
bytes:word;
{$ifdef msdos}
Procedure setbank(bank:byte);far;
var banque:word;
begin
banque:=bank*longint(64) div vgran;
asm
mov bx, 0
mov dx, banque
call [add_bank]
mov bx, 1
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:=bank;
end;
{$endif}
Function setvesa(mode:word):byte;
begin
asm
mov ax,4F02h
mov bx,mode
int 10h
sub ax,004Fh
mov @RESULT,al
end;
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;
char_width,
char_high,
planes,
bits_per_pixel:byte;
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;
{ nb pixel per lines }
if pro=1 then
x_size:=vesa_info.bytes ;
add_bank:=vesa_info.add_proc; { change bank far ptr }
{ x_size:=vesa_info.bytes;}
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 }
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
shl bx,1
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 get_time:longint;
var heure,minute,seconde,sec100:word;
begin
gettime(heure,minute,seconde,sec100);
get_time:=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;
Function write_fast_16(x1,y,x2,indice:word;var rouge,vert,bleu):boolean;
var coord1,coord2:longint;
couleur:byte;
i,from,i_mem,x_pixel:word;
begin
write_fast_16:=false;
coord1:=longint(y)*longint(x_size)+longint(x1)*3; {R+V+B=3 bytes }
coord2:=coord1+longint((x2-x1)+1)*3;
(* is the first point in current bank ???? *)
if (coord1 shr 16)<> curbank then setbank(coord1 shr 16);
(* if the first and the last points are in the same 64k bank *)
if ((coord1 shr 16)=(coord2 shr 16)) and (use_16=true) then
begin
i:=indice;
i_mem:=0;
from:=(coord1 mod 65536);
{ x_pixel:=(x2-x1+1);}
x_pixel:=(x2-x1);
asm
push ds
les di,bleu
add di,i
mov si,from
mov cx,x_pixel
mov ax,sega000
mov ds,ax
@@xloop_b:
mov al,[es:di]
mov [ds:si],al
inc di
add si,3
dec cx
jnz @@xloop_b
pop ds
mov si,from
inc si
mov cx,x_pixel
push ds
les di,vert
add di,i
mov ax,sega000
mov ds,ax
@@xloop_g:
mov al,[es:di]
mov [ds:si],al
inc di
add si,3
dec cx
jnz @@xloop_g
pop ds
mov si,from
inc si
inc si
mov cx,x_pixel
push ds
les di,rouge
add di,i
mov ax,sega000
mov ds,ax
@@xloop_r:
mov al,[es:di]
mov [ds:si],al
inc di
add si,3
dec cx
jnz @@xloop_r
pop ds
end;
write_fast_16:=true;
end;
end;
Function write_fast_16_BRG(x1,y,x2:word;var image):boolean;
var coord1,coord2:longint;
couleur:byte;
i,from,x_pixel:word;
begin
write_fast_16_BRG:=false;
coord1:=(longint(y)*longint(x_size)+longint(x1))*1;
coord2:=coord1+longint((x2-x1)+1)*3;
(* is the first point in current bank ???? *)
if (coord1 shr 16)<> curbank then setbank(coord1 shr 16);
(* if the first and the last points are in the same 64k bank *)
if ((coord1 shr 16)=(coord2 shr 16)) and (use_16=true) then
begin
from:=(coord1 mod 65536);
x_pixel:=(x2-x1+1)*3 div 4;
asm
push ds
mov cx,x_pixel
mov di,from
mov es,SegA000
lds si,image
cld
{ @boucle:
mov ax,[ds:si]
mov [es:di],ax
add si,2
add di,2
dec cx
jnz @boucle}
{ rep movsw}
db 0f3h, 066h, 0a5h { rep movsd }
pop ds
end;
write_fast_16_BRG:=true;
end;
end;
end.
{ -------------------------- DEMO PROGRAM ------------------------ }
(*
*****************************************************************************
Copyright (C) 1995 Lionel CORDESSES
This source is a part of a program that allows you to read and display
a color or a black and white JPEG picture . I wrote the full source in
order to understand how it works . Some parts are translated from C
language to Pascal (the reverse DCT for instance ).
I used many sources of informations:
- "The JPEG Still Picture Compression Standart" by G.K.Wallace,
- C sources and doc from the Independent JPEG Group's software,
- C sources and doc from the Portable Video Research Group (PVRG)
code,
- the FAQ about JPEG,
- "JPEG Compression" by C.Cavigioli (ANALOG DEVICE application note
AN-336B )
- and many others ...
You can use , modified and distribute this source as long as credit is
given.
*****************************************************************************
*)
{
*****************************************************************************
Sample program for the unit Usvesa3.
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.
June 1995
*****************************************************************************
}
program VesaDemo;
{$f+}
uses dos,crt,usvesa3;
var n:byte;
x,y,i:word;
ch:char;
funckey:boolean;
code:byte;
tps1,tps2:longint;
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_32;
begin
clrscr;
writeln('Testing VESA mode 640x480 32768 colors');
writeln('Press a key ...');
repeat
touche(funckey,code)
until (code<>0) or (funckey=true);
n:=setmode($110);
if n=0 then
begin
textmode(co80);
writeln('WARNING:no VESA driver or unsupported mode !!! ');
halt(1);
end;
tps1:=get_time;
for y:=0 to 255 do
for x:=0 to 255 do
setpix_16(x,y,x,y,255-x);
tps2:=get_time;
wrtxt(10,300,'Mode VESA 110h 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;
tps1:=get_time;
for y:=0 to 255 do
for x:=0 to 255 do
setpix_16(x,y,x,y,255-x);
tps2:=get_time;
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_32;
test_16;
textmode(co80);
writeln;
writeln('VESATST.EXE (C) 1995 Lionel Cordesses ');
end.
[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]