VGA Memory access with Pascal and ASM

 ┌──────────────────────────────────────────────────────────────────────────┐
 │ APPLICATION            │ DATE       │ AUTHOR              │ READY-TO-USE │
 ├────────────────────────┼────────────┼─────────────────────┼──────────────┤
 │ VGA Applications       │ 12/03/1995 │ Mihai MATEI         │     YES      │
 ├──────────────────────────────────────────────────────────────────────────┤
 │ DESCRIPTION                                                              │
 │                                                                          │
 │ Programe ce utilizeaza VGA. (realizate dupa un articol din PC Report)    │
 │                                                                          │
 └──────────────────────────────────────────────────────────────────────────┘

Download executable: VGA2

uses crt;
const vga=$A000;
var pall,pall2:array[0..255,1..3] of byte;

procedure setvga;
begin
asm
mov ax,0013h
int 10h
end;
end;

procedure settext;
begin
asm
mov ax,0003h
int 10h
end;
end;

procedure waitretrace;assembler;
label
  1, 2;
asm
   mov dx,3DAh
@1:
    in al,dx
    and al,08h
    jnz @1
@2:
    in al,dx
    and al,08h
    jz @2
end;

procedure getpal(colorno : byte; var r,g,b : byte);
begin
  port[$3c7] := colorno;
  r:=port[$3c9];
  g:=port[$3c9];
  b:=port[$3c9];
end;

procedure pal(colorno:byte;r,g,b:byte);
begin
 port[$3c8]:=colorno;
 port[$3c9]:=r;
 port[$3c9]:=g;
 port[$3c9]:=b;
end;

procedure putpixel(x,y:integer;col:byte);
begin
mem[vga:x+(y*320)]:=col;
end;

procedure line(a,b,c,d,col:integer);
function sgn(a:real):integer;
begin
  if a>0 then sgn:=+1;
  if a<0 then sgn:=-1;
  if a=0 then sgn:=0;
end;
var u,s,v,d1x,d1y,d2x,d2y,m,n:real;
    i:integer;
begin
  u:= c-a;
  v:=d-b;
  d1x:=sgn(u);
  d1y:=sgn(v);
  d2x:=sgn(u);
  d2y:=0;
  m:=abs(u);
  n:=abs(v);
  if not (m>n) then
  begin
    d2x:=0;
    d2y:=sgn(v);
    m:=abs(v);
    n:=abs(u);
  end;
s:=int(m/2);
for i:=0 to round(m) do
begin
putpixel(a,b,col);
s:=s+n;
if not (s<m) then
begin
s:=s-m;
a:=a+round(d1x);
b:=b+round(d1y);
end
else
begin
 a:=a+round(d2x);
 b:=b+round(d2y);
end;
end;
end;

procedure palplay;
var tmp:array[1..3] of byte;
loop1:byte;
begin
 move(pall[200],tmp,3);
 move(pall[0],pall[1],200*3);
 move(tmp,pall[0],3);
 waitretrace;
 for loop1:=1 to 255 do
 pal(loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
end;

procedure setupscreen;
var loop:integer;
begin
 fillchar(pall,sizeof(pall),0);
 for loop:=0 to 200 do begin
  pall[loop,1]:=loop mod 64;
 end;
 for loop:=1 to 320 do begin
 line(319,199,320-loop,0,(loop mod 199)+1);
 palplay;
 end;
end;

procedure grabpallette;
var loop1:integer;
begin
 for loop1:=0 to 255 do
  getpal(loop1,pall2[loop1,1],pall2[loop1,2],pall2[loop1,3]);
end;

procedure blackout;
var loop1:integer;
begin
 waitretrace;
 for loop1:=0 to 255 do
  pal(loop1,0,0,0);
end;

procedure hiddenscreensetup;
var loop1,loop2:integer;
begin
for loop1:=0 to 319 do
 for loop2:=0 to 199 do
  putpixel(loop1,loop2,144);
  line(10,10,150,10,loop1);
end;

procedure fadeup;
var loop1,loop2:integer;
    tmp:array[1..3] of byte;
begin
 for loop1:=1 to 64 do begin
waitretrace;
 for loop2:=0 to 255 do begin
  getpal(loop2,tmp[1],tmp[2],tmp[3]);
  if tmp[1]<pall2[loop2,1] then inc(tmp[1]);
  if tmp[2]<pall2[loop2,2] then inc(tmp[2]);
  if tmp[3]<pall2[loop2,3] then inc(tmp[3]);
  pal(loop2,tmp[1],tmp[2],tmp[3]);
 end;
end;
end;

procedure fadedown;
var loop1,loop2:integer;
    tmp:array[1..3] of byte;
begin
 for loop1:=1 to 64 do begin
 waitretrace;
 for loop2:=0 to 255 do begin
  getpal(loop2,tmp[1],tmp[2],tmp[3]);
  if tmp[1]>0 then dec (tmp[1]);
  if tmp[2]>0 then dec (tmp[2]);
  if tmp[3]>0 then dec (tmp[3]);
  pal(loop2,tmp[1],tmp[2],tmp[3]);
  end
 end;

end;

procedure restorepallette;
var loop1:integer;
begin
waitretrace;
for loop1:=0 to 255 do
pal(loop1,pall2[loop1,1],pall2[loop1,2],pall2[loop1,3]);
end;

begin
clrscr;
setvga;
grabpallette;
setupscreen;
repeat
palplay;
until keypressed;
readln;
blackout;
hiddenscreensetup;
fadeup;
readln;
fadedown;
readln;
restorepallette;
settext;
end.