Vlib
unit vlib;
interface
uses crt;
const scr:pointer=ptr($a000,0);
type pal=array[0..767] of byte;
var pal_akt,pal_des:pal;
tlo:pointer;
zmienna:word;
procedure Init;
procedure Clinit;
procedure GetBk;
procedure FreeBk;
procedure WaitVbl;
procedure Plot(xe,ye:integer;c:byte);
function GetPlot(xe,ye:integer):byte;
procedure GetPal(var p:pal);
procedure SetPal(p:pal);
procedure SetColor(nr,Rpal,Gpal,Bpal:byte);
procedure GetColor(nr:byte;var Rpal,Gpal,Bpal:byte);
procedure Fader;
procedure Spread(nr1,r1,g1,b1,nr2,r2,g2,b2:byte);
procedure Cls(color:byte);
procedure Bar(x1,y1,x2,y2:word;color:byte);
procedure Box(x1,y1,x2,y2:word;color:byte);
procedure Line(x1,y1,x2,y2:word;color:byte);
procedure LineH(x1,x2,y:word;c:byte);
procedure LineV(x,y1,y2:word;c:byte);
procedure Circle(xc,yc,rc:word;cc:byte);
procedure Circle_Fill(xc,yc,rc:word;cc:byte);
procedure Beep(Hz,t:word);
procedure Kasza(zakr:byte);
function Click:boolean;
function GetKey:char;
implementation
procedure Init;
begin
asm
mov ax,13h
int 10h
end;
DirectVideo:=false;
port[$3ce]:=6;
port[$3cf]:=1;
end;
procedure Clinit;
begin
asm
mov ax,3h
int 10h
end;
end;
procedure GetBk;
begin
GetMem(tlo,64000);
move(mem[$0A000:0000],mem[seg(tlo^):ofs(tlo^)],64000);
end;
procedure FreeBk;
begin
FreeMem(tlo,64000);
end;
procedure WaitVbl;
begin
repeat until (port[$3DA] and 8)=8;
repeat until (port[$3DA] and 8)=0;
end;
procedure plot(xe,ye:integer;c:byte);assembler;
asm
mov ax,$A000
mov es,ax
mov dx,ye
mov di,xe
shl dx,6
add di,dx
shl dx,2
add di,dx
mov al,c
mov es:[di],al
end;
function getplot(xe,ye:integer):byte;
begin
asm
mov ax,$A000
mov es,ax
mov dx,ye
mov di,xe
shl dx,6
add di,dx
shl dx,2
add di,dx
mov al,es:[di]
mov @Result,al
end;
end;
procedure GetPal(var p:pal); assembler;
asm
mov dx,3c8h
xor al,al
out dx,al
inc dx
mov cx,768
les di,p
rep insb
end;
procedure SetPal(p:pal); assembler;
asm
push ds
push ds
mov ax,ds
mov es,ax
mov di,offset pal_akt
lds si,p
mov cx,768/4
db 66h; rep movsw
pop ds
mov dx,3c8h
xor al,al
out dx,al
mov si,offset pal_akt
mov cx,768
mov dx,$3c9
rep outsb
pop ds
end;
procedure SetColor(nr,Rpal,Gpal,Bpal:byte);
begin
pal_akt[(nr shl 2)-nr+0]:=Rpal;
pal_akt[(nr shl 2)-nr+1]:=Gpal;
pal_akt[(nr shl 2)-nr+2]:=Bpal;
port[$3c8]:=nr;
port[$3c9]:=Rpal;
port[$3c9]:=Gpal;
port[$3c9]:=Bpal;
end;
procedure GetColor(nr:byte;var Rpal,Gpal,Bpal:byte);
begin
port[$3c7]:=nr;
Rpal:=port[$3c9];
Gpal:=port[$3c9];
Bpal:=port[$3c9];
end;
procedure Fader;
var l1,l2:word;
pal_fad:pal;
begin
move(pal_akt,pal_fad,768);
for l1:=1 to 64 do begin
for l2:=0 to 767 do begin
pal_akt[l2]:=round((pal_des[l2]-pal_fad[l2])*l1 shr 6)+pal_fad[l2];
end;
WaitVbl;
asm
push ds
mov dx,3c8h
xor al,al
out dx,al
mov si,offset pal_akt
mov cx,768
mov dx,$3c9
rep outsb
pop ds
end;
end;
end;
procedure Spread(nr1,r1,g1,b1,nr2,r2,g2,b2:byte);
var lc:integer;
Rp,Gp,Bp:byte;
macroM:real;
begin
if nr2<nr1 then
begin
rp:=r1;
gp:=g1;
bp:=b1;
r1:=r2;
g1:=g2;
b1:=b2;
r2:=rp;
g2:=gp;
b2:=bp;
lc:=nr1;
nr1:=nr2;
nr2:=lc;
end;
for lc:=nr1 to nr2 do begin
macroM:=(lc-nr1)/(nr2-nr1);
Rp:=round(r1+(r2-r1)*macroM);
Gp:=round(g1+(g2-g1)*macroM);
Bp:=round(b1+(b2-b1)*macroM);
pal_akt[(lc shl 2)-lc+0]:=Rp;
pal_akt[(lc shl 2)-lc+1]:=Gp;
pal_akt[(lc shl 2)-lc+2]:=Bp;
end;
asm
push ds
mov dx,3c8h
xor al,al
out dx,al
mov si,offset pal_akt
mov cx,768
mov dx,$3c9
rep outsb
pop ds
end;
end;
procedure Cls(color:byte);assembler;
asm
mov ax,0a000h
mov es,ax
xor di,di
db 66h
xor ax,ax
mov al,color
mov ah,al
mov bx,ax
db 66h
shl ax,16
mov ax,bx
mov cx,16000
db 66h
rep stosW
end;
procedure Bar(x1,y1,x2,y2:word;color:byte);assembler;
asm
mov ax,$A000
mov es,ax
mov dx,y1
mov di,x1
xchg dh,dl
add di,dx
shr dx,2
add di,dx
mov cx,y2
sub cx,y1
inc cx
mov ah,color
mov al,ah
@Y: mov bx,cx
mov cx,x2
sub cx,x1
inc cx
rep stosB
add di,319
sub di,x2
add di,x1
mov cx,bx
Loop @Y
end;
procedure Box(x1,y1,x2,y2:word;color:byte);
begin
LineH(x1,x2,y1,color);
LineH(x1,x2,y2,color);
LineV(x1,y1,y2,color);
LineV(x2,y1,y2,color);
end;
procedure Line(x1,y1,x2,y2:word;color:byte);
var
wsk1,wsk2,podpr:word;
begin
asm
push si
push di
push es
mov ax,$a000
mov es,ax
mov si,320
mov cx,x2
sub cx,x1
jz @@VL
jns @@pdr1
neg cx
mov bx,x2
xchg bx,x1
mov x2,bx
mov bx,y2
xchg bx,y1
mov y2,bx
@@pdr1:
mov bx,y2
sub bx,y1
jz @@HL
jns @@pdr3
neg bx
neg si
@@pdr3:
push si
mov podpr,offset @@LL1
cmp bx,cx
jle @@pdr4
mov podpr,offset @@HL1
xchg bx,cx
@@pdr4:
shl bx,1
mov wsk1,bx
sub bx,cx
mov si,bx
sub bx,cx
mov wsk2,bx
push cx
mov ax,y1
mov bx,x1
xchg ah,al
add bx,ax
shr ax,1
shr ax,1
add bx,ax
mov di,bx
pop cx
inc cx
pop bx
jmp podpr
@@VL:
mov ax,y1
mov bx,y2
mov cx,bx
sub cx,ax
jge @@pdr31
neg cx
mov ax,bx
@@pdr31:
inc cx
mov bx,x1
push cx
xchg ah,al
add bx,ax
shr ax,1
shr ax,1
add bx,ax
pop cx
mov di,bx
dec si
mov al,color
@@pdr32:
stosb
add di,si
loop @@pdr32
jmp @@Exit
@@HL:
push cx
mov ax,y1
mov bx,x1
xchg ah,al
add bx,ax
shr ax,1
shr ax,1
add bx,ax
mov di,bx
pop cx
inc cx
mov al,color
rep stosb
jmp @@Exit
@@LL1:
mov al,color
@@pdr11:
stosb
or si,si
jns @@pdr12
add si,wsk1
loop @@pdr11
jmp @@Exit
@@pdr12:
add si,wsk2
add di,bx
loop @@pdr11
jmp @@Exit
@@HL1:
mov al,color
@@pdr21:
stosb
add di,bx
@@pdr22:
or si,si
jns @@pdr23
add si,wsk1
dec di
loop @@pdr21
jmp @@Exit
@@pdr23:
add si,wsk2
loop @@pdr21
@@Exit:
pop es
pop di
pop si
end;
end;
procedure LineH(x1,x2,y:word;c:byte);assembler;
asm
mov ax,x1
cmp ax,x2
jb @ok
xchg ax,x2
mov x1,ax
@ok:
mov ax,0A000h
mov es,ax
mov dx,y
mov di,x1
xchg dh,dl
add di,dx
shr dx,2
add di,dx
mov cx,x2
sub cx,x1
inc cx
mov al,c
rep Stosb
end;
procedure LineV(x,y1,y2:word;c:byte);assembler;
asm
mov ax,0A000h
mov es,ax
mov dx,y1
mov di,x
xchg dh,dl
add di,dx
shr dx,2
add di,dx
mov cx,y2
sub cx,y1
inc cx
mov al,c
@p:
StosB
add di,319
loop @p
end;
procedure Circle(xc,yc,rc:word;cc:byte);
begin
if rc=0 then begin plot(xc,yc,cc); exit; end;
asm
push ds
mov cx,0
mov ax,rc
mov dx,1
sub dx,rc
@do:
push dx
push $a000
pop es
mov dx,yc
mov di,xc
xchg dh,dl
add di,dx
shr dx,2
add di,dx
{push yc+y}
push di
mov dx,ax
shl dx,6
add di,dx
shl dx,2
add di,dx
mov dl,cc
mov bx,cx
mov es:[di+bx],dl
not bx
inc bx
mov es:[di+bx],dl
pop di
{push yc-y}
push di
mov dx,ax
not dx
inc dx
shl dx,6
add di,dx
shl dx,2
add di,dx
mov dl,cc
mov bx,cx
mov es:[di+bx],dl
not bx
inc bx
mov es:[di+bx],dl
pop di
{push yc+x}
push di
mov dx,cx
shl dx,6
add di,dx
shl dx,2
add di,dx
mov dl,cc
mov bx,ax
mov es:[di+bx],dl
not bx
inc bx
mov es:[di+bx],dl
pop di
{push yc-x}
push di
mov dx,cx
not dx
inc dx
shl dx,6
add di,dx
shl dx,2
add di,dx
mov dl,cc
mov bx,ax
mov es:[di+bx],dl
not bx
inc bx
mov es:[di+bx],dl
pop di
pop dx
inc cx
cmp dx,0
jl @subd
dec ax
mov bx,cx
sub bx,ax
shl bx,1
add dx,bx
inc dx
jmp @cont
@subd:
mov bx,cx
shl bx,1
add dx,bx
inc dx
@cont:
cmp cx,ax
jna @do
pop ds
end;
end;
procedure Circle_Fill(xc,yc,rc:word;cc:byte);
begin
if rc=0 then begin plot(xc,yc,cc); exit; end;
asm
push ds
mov cx,0
mov ax,rc
mov dx,1
sub dx,rc
@do:
push dx
les di,scr
mov dx,yc
mov di,xc
xchg dh,dl
add di,dx
shr dx,2
add di,dx
{push yc+y}
push di
mov dx,ax
shl dx,6
add di,dx
shl dx,2
add di,dx
sub di,cx
push ax
push cx
shl cx,1
inc cx
mov al,cc
rep stosB
pop cx
pop ax
pop di
{push yc-y}
push di
mov dx,ax
not dx
inc dx
shl dx,6
add di,dx
shl dx,2
add di,dx
sub di,cx
push ax
push cx
shl cx,1
inc cx
mov al,cc
rep stosB
pop cx
pop ax
pop di
{push yc+x}
push di
mov dx,cx
shl dx,6
add di,dx
shl dx,2
add di,dx
sub di,ax
push ax
push cx
mov cx,ax
shl cx,1
inc cx
mov al,cc
rep stosB
pop cx
pop ax
pop di
{push yc-x}
push di
mov dx,cx
not dx
inc dx
shl dx,6
add di,dx
shl dx,2
add di,dx
sub di,ax
push ax
push cx
mov cx,ax
shl cx,1
inc cx
mov al,cc
rep stosB
pop cx
pop ax
pop di
pop dx
inc cx
cmp dx,0
jl @subd
dec ax
mov bx,cx
sub bx,ax
shl bx,1
add dx,bx
inc dx
jmp @cont
@subd:
mov bx,cx
shl bx,1
add dx,bx
inc dx
@cont:
cmp cx,ax
jna @do
pop ds
end;
end;
procedure Beep(Hz,t:word);
begin
Sound(Hz);
delay(t);
nosound;
end;
procedure Kasza(zakr:byte);
var kx,ky:word;
begin
for ky:=0 to 199 do for kx:=0 to 319 do Plot(kx,ky,random(zakr));
end;
function Click:boolean;
begin
Click:=keypressed;
end;
function GetKey:char;
begin
GetKey:=Readkey;
end;
begin
end.
