mirror of https://github.com/deater/tb1.git
1048 lines
23 KiB
ObjectPascal
1048 lines
23 KiB
ObjectPascal
unit SVmwGraph; {Super Vmw Graphics Unit}
|
|
{$X+}{$G+}
|
|
{$L graph32.obj}
|
|
|
|
INTERFACE
|
|
|
|
CONST VGA = $a000;
|
|
|
|
var unfadered:array[0..255] of byte;
|
|
unfadeblue:array[0..255] of byte;
|
|
unfadegreen:array[0..255] of byte;
|
|
fontline:array[0..255] of byte;
|
|
charset:array[0..255,0..15] of byte;
|
|
charheight:byte;
|
|
fontseg,fontoff:word;
|
|
|
|
|
|
|
|
|
|
|
|
function Mode13SavePicPacked(x1,y1,x2,y2,numcolors:integer;where:word;filename:string):byte;
|
|
function Mode13LoadPicPacked(x1,y1:integer;where:word;LoadPal,LoadPic:boolean;FileName:string):byte;
|
|
procedure cls32(col:byte;where:word);
|
|
procedure flipd320(source,dest:word);
|
|
procedure flipd240(hm,va,va2:word);
|
|
procedure flipd50(fromwhere,off1,whereto,off2:word);
|
|
|
|
Procedure SetMCGA;
|
|
Procedure SetText; { This procedure returns you to text mode. }
|
|
Procedure LoadFont(namest:string);
|
|
|
|
Procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
|
|
Procedure Putpixel240 (X,Y : Integer; Col : Byte; where:word);
|
|
function getpixel(x,y,where:word):byte;
|
|
Procedure Pal(Col,R,G,B : Byte);
|
|
Procedure GetPal(Col : Byte; Var R,G,B : Byte);
|
|
procedure WaitRetrace;
|
|
procedure outtextlineover(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
procedure outtextline(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
procedure outtextxy(st:string;x,y,col,background:integer;where:word;overwrite:boolean);
|
|
procedure outsmalltextlineover(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
procedure outsmalltextline(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
procedure outsmalltextxy(st:string;x,y,col,background:integer;where:word;overwrite:boolean);
|
|
function sgn(a:real):integer;
|
|
procedure line(a,b,c,d,col:integer;where:word);
|
|
procedure horizontalline(FromX1,ToX2,AtY,col:integer;where:word);
|
|
procedure verticalline(FromY1,ToY2,AtX,col:integer;where:word);
|
|
procedure fade;
|
|
procedure unfade;
|
|
procedure box(x1,y1,x2,y2,col:integer;where:word);
|
|
procedure vdelay(howlong:integer);
|
|
procedure setupvmwgraph;
|
|
procedure setuptb1;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
{Errors: 0=No Errors
|
|
1=File Not Found
|
|
2=Not a Paintpro File (no PAINTPROVX.XX header)
|
|
3=Improper Version (less then 6)
|
|
}
|
|
IMPLEMENTATION
|
|
|
|
uses nvmwgraph;
|
|
|
|
|
|
function Mode13SavePicPacked(x1,y1,x2,y2,numcolors:integer;where:word;filename:string):byte;
|
|
|
|
{**** Saves an image, with corners x1,y1 and x2,y2
|
|
and number of colors NUMCOLORS, and at segment
|
|
where ($A000 for vga) to the paintpro file
|
|
filename ****}
|
|
{x2 y2 should be plus one (320,200 not 319,199}
|
|
|
|
var buffer:array[0..2] of byte;
|
|
header:string[15];
|
|
f:file;
|
|
col,x,y,xsize,ysize,i,oldcol,numacross:integer;
|
|
byte1,byte2,byte3,temp:byte;
|
|
r,g,b:byte;
|
|
second1,zz:integer;
|
|
|
|
procedure integer23bytes(inter1,inter2:integer);
|
|
var temp1,temp2,temp3:integer;
|
|
temp:byte;
|
|
begin
|
|
{asm
|
|
mov ax,inter1
|
|
shl ax,1
|
|
shl ax,1 this assembly will accomplish
|
|
shl ax,1 what the below will. Basically
|
|
shl ax,1 it takes two, 16 bit integers,
|
|
mov temp1,ah strips off the top 4 bits of each,
|
|
sub ah,ah (makin two, 12 bit integers) and
|
|
shr ax,1 joins these into three 8 bit bytes
|
|
shr ax,1
|
|
shr ax,1 for this assmebly to work, however
|
|
shr ax,1 temp1,temp2, etc must be byte, not
|
|
mov temp,al integer
|
|
mov ax,inter2
|
|
mov temp3,al
|
|
shr ax,1
|
|
shr ax,1
|
|
shr ax,1
|
|
shr ax,1
|
|
mov ah,temp
|
|
shl ax,1
|
|
shl ax,1 in the below, shl is shift left
|
|
shl ax,1 (in C the equivelant is <<)
|
|
shl ax,1 and shr is shift right ( >> )
|
|
mov temp2,ah
|
|
end;
|
|
|
|
}
|
|
temp1:=(inter1 AND $7FFF);
|
|
temp1:=temp1 shr 4;
|
|
temp3:=(inter2 AND $7FFF);
|
|
temp2:= ((inter1 and $000F) shl 4)+ ((inter2 AND $0F00) shr 8);
|
|
|
|
buffer[0]:=temp1;
|
|
buffer[1]:=temp2;
|
|
buffer[2]:=temp3;
|
|
blockwrite(f,buffer,1);
|
|
end;
|
|
|
|
|
|
begin
|
|
Mode13SavePicPacked:=0; {*Clear the errors}
|
|
assign(f,filename); {*Open the file}
|
|
{$I-}
|
|
rewrite(f,3); {*Turn off i/o and open file}
|
|
{$I+}
|
|
if Ioresult<>0 then Mode13SavePicPacked:=1;
|
|
if Ioresult<>0 then exit; {*If error, file not found}
|
|
header:='PAINTPROV6.0';
|
|
for i:=0 to 3 do begin {*Write header}
|
|
buffer[0]:=ord(header[(i*3)+1]);
|
|
buffer[1]:=ord(header[(i*3)+2]);
|
|
buffer[2]:=ord(header[(i*3)+3]);
|
|
blockwrite(f,buffer,1);
|
|
end;
|
|
|
|
xsize:=abs(x2-x1); {*Write xsize and ysize}
|
|
ysize:=abs(y2-y1);
|
|
integer23bytes(xsize,ysize);
|
|
integer23bytes(numcolors,0); {*Write number of colors and a blank}
|
|
|
|
for i:=0 to (numcolors-1) do {*Save the pallete (24 bit, rgb)}
|
|
begin
|
|
getpal(i,buffer[0],buffer[1],buffer[2]);
|
|
buffer[0]:=buffer[0]* 4; {*Multiplied by 4 because}
|
|
buffer[1]:=buffer[1] * 4; {mode 13h is only 18 bit}
|
|
buffer[2]:=buffer[2] * 4;
|
|
blockwrite(f,buffer,1);
|
|
end;
|
|
zz:=(y2-y1);
|
|
y:=y1;
|
|
numacross:=0; {this does RLE encoding}
|
|
second1:=0; {see doc file}
|
|
oldcol:=getpixel(x1,y,where);
|
|
while y<=y2 do begin
|
|
x:=x1;
|
|
while x<=x2 do begin
|
|
col:=getpixel(x,y,where);
|
|
if (col=oldcol) and (numacross<2046) then inc(numacross)
|
|
else begin {*compresses 1 color stretches}
|
|
if numacross=1 then begin
|
|
if second1=0 then begin
|
|
second1:=oldcol+2048;
|
|
end
|
|
else begin
|
|
integer23bytes(second1,oldcol+2048);
|
|
second1:=0;
|
|
end
|
|
|
|
end
|
|
else begin
|
|
if second1<>0 then
|
|
integer23bytes(second1-2048,1);
|
|
integer23bytes(oldcol,numacross);
|
|
second1:=0;
|
|
end;
|
|
numacross:=1;
|
|
end;
|
|
inc(x);
|
|
oldcol:=col;
|
|
end;
|
|
inc(y);
|
|
end;
|
|
integer23bytes(col,numacross);
|
|
|
|
close(f);
|
|
end;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
function Mode13LoadPicPacked(x1,y1:integer;where:word;LoadPal,LoadPic:boolean;FileName:string):byte;
|
|
|
|
{*Loads a paintpro image, filename, at location x1,y1
|
|
to offset where (vga=$A000) and loadspal if LOADPAL=true
|
|
Loadsapicture if Loadpic=true and returns error}
|
|
|
|
var buffer:array[0..299] of byte;
|
|
result,buffpointer:integer;
|
|
f:file;
|
|
col,x,y,xsize,ysize,i,oldcol,
|
|
numcolors,tempint1,tempint2,numacross:integer;
|
|
header:string;
|
|
lastread:boolean;
|
|
tempbyte,r,g,b:byte;
|
|
|
|
|
|
procedure sixbytes2twoint;
|
|
|
|
var temp1,temp2,temp3:byte;
|
|
int1,int2:integer;
|
|
|
|
begin
|
|
temp1:=buffer[buffpointer];
|
|
temp2:=buffer[buffpointer+1];
|
|
temp3:=buffer[buffpointer+2];
|
|
inc(buffpointer,3);
|
|
if (buffpointer>=result) then
|
|
if (result=300) then begin
|
|
blockread(f,buffer,300,result);
|
|
buffpointer:=0;
|
|
end
|
|
else lastread:=true;
|
|
asm
|
|
mov ah,temp1 {splits 3 bytes (24 bits)}
|
|
mov al,temp2 {into two 12 bit integers}
|
|
shr ax,4 {and then pads them into}
|
|
mov int1,ax {two 16 bit integers}
|
|
mov ah,temp2
|
|
mov al,temp3
|
|
shl ah,4
|
|
shr ah,4
|
|
mov int2,ax
|
|
end;
|
|
tempint1:=int1;
|
|
tempint2:=int2;
|
|
end;
|
|
|
|
|
|
|
|
begin
|
|
lastread:=false;
|
|
Mode13LoadPicPacked:=0; {*Clear errors}
|
|
header:='';
|
|
buffpointer:=0;
|
|
assign(f,filename);
|
|
{$I-}
|
|
reset(f,1); {*Check that file is there}
|
|
{$I+}
|
|
if IOresult<>0 then begin {*Error if not}
|
|
Mode13LoadPicPacked:=1;
|
|
end
|
|
else begin
|
|
|
|
blockread(f,buffer,300,result);
|
|
|
|
for i:=1 to 9 do header:=concat(header,chr(buffer[i-1]));
|
|
|
|
|
|
if header<> 'PAINTPROV' then Mode13LoadPicPacked:=2;
|
|
if header<> 'PAINTPROV' then exit; {*Error if not Paintpro header}
|
|
|
|
header:='';
|
|
|
|
header:=concat(header,chr(buffer[9]),chr(buffer[10]),chr(buffer[11]));
|
|
|
|
if header<>'6.0' then Mode13LoadPicPacked:=3; {*Error if wron version}
|
|
if header<>'6.0' then exit;
|
|
buffpointer:=12;
|
|
|
|
sixbytes2twoint;
|
|
xsize:=tempint1;
|
|
ysize:=tempint2;
|
|
sixbytes2twoint;
|
|
numcolors:=tempint1;
|
|
|
|
|
|
|
|
for i:=0 to (numcolors-1) do begin
|
|
r:=(buffer[buffpointer] div 4);
|
|
g:=(buffer[buffpointer+1] div 4);
|
|
b:=(buffer[buffpointer+2] div 4);
|
|
inc(buffpointer,3);
|
|
if (buffpointer>=result) then
|
|
if (result=300) then begin
|
|
blockread(f,buffer,300,result);
|
|
buffpointer:=0;
|
|
end
|
|
else
|
|
|
|
lastread:=true;
|
|
if loadpal then pal(i,r,g,b);
|
|
end;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
x:=x1;
|
|
y:=y1;
|
|
if loadpic=true then begin
|
|
while (lastread=false) do begin
|
|
sixbytes2twoint;
|
|
|
|
if tempint1>2047 then begin
|
|
putpixel(x,y,(tempint1-2048),where);
|
|
inc(x);
|
|
if x>=xsize+x1+1 then begin
|
|
x:=x1; inc(y); end;
|
|
putpixel(x,y,(tempint2-2048),where);
|
|
inc(x);
|
|
if x>=xsize+x1+1 then begin
|
|
x:=x1; inc(y); end;
|
|
end
|
|
|
|
else begin
|
|
col:=tempint1;
|
|
numacross:=tempint2;
|
|
while ((x+numacross)>=(xsize+x1+1)) do begin
|
|
horizontalline(x,x1+xsize,y,col,where);
|
|
numacross:=numacross-((xsize+1)-x);
|
|
x:=x1;
|
|
inc(y);
|
|
end;
|
|
if numacross<>0 then horizontalline(x,x+numacross,y,col,where);
|
|
x:=x+numacross;
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
close(f);
|
|
end;
|
|
end;
|
|
|
|
procedure cls32(col:byte;where:word);EXTERNAL;
|
|
procedure flipd320(source,dest:word);EXTERNAL;
|
|
procedure flipd240(hm,va,va2:word);EXTERNAL;
|
|
procedure flipd50(fromwhere,off1,whereto,off2:word);EXTERNAL;
|
|
|
|
|
|
|
|
|
|
Procedure SetMCGA; { This procedure gets you into 320x200x256 mode. }
|
|
BEGIN
|
|
asm
|
|
mov ax,0013h
|
|
int 10h
|
|
end;
|
|
END;
|
|
|
|
Procedure SetText; { This procedure returns you to text mode. }
|
|
BEGIN
|
|
asm
|
|
mov ax,0003h
|
|
int 10h
|
|
end;
|
|
END;
|
|
|
|
Procedure LoadFont(namest:string);
|
|
var buff:array[0..15] of byte;
|
|
f:file;
|
|
i,fonty:integer;
|
|
|
|
begin
|
|
assign(f,namest);
|
|
{$I-}
|
|
reset(f,16);
|
|
{$I+}
|
|
if Ioresult<>0 then writeln(#7);
|
|
if Ioresult<>0 then exit;
|
|
|
|
fonty:=0;
|
|
while (not eof(F)) and (fonty<4097) do
|
|
begin
|
|
blockread(f,buff,1);
|
|
for i:=0 to 15 do
|
|
charset[fonty div 16,i]:=buff[i];
|
|
inc(fonty,16);
|
|
end;
|
|
close(f);
|
|
end;
|
|
|
|
|
|
Procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
|
|
{ This puts a pixel on the screen by writing directly to memory. }
|
|
BEGIN
|
|
Asm
|
|
push ds
|
|
push es
|
|
mov ax,[where]
|
|
mov es,ax
|
|
mov bx,[X]
|
|
mov dx,[Y]
|
|
push bx {; and this again for later}
|
|
mov bx, dx {; bx = dx}
|
|
mov dh, dl {; dx = dx * 256}
|
|
xor dl, dl
|
|
shl bx, 1
|
|
shl bx, 1
|
|
shl bx, 1
|
|
shl bx, 1
|
|
shl bx, 1
|
|
shl bx, 1 {; bx = bx * 64}
|
|
add dx, bx {; dx = dx + bx (ie y*320)}
|
|
pop bx {; get back our x}
|
|
add bx, dx {; finalise location}
|
|
mov di, bx
|
|
{; es:di = where to go}
|
|
xor al,al
|
|
mov ah, [Col]
|
|
mov es:[di],ah
|
|
pop es
|
|
pop ds
|
|
End;
|
|
END;
|
|
|
|
Procedure Putpixel240 (X,Y : Integer; Col : Byte; where:word);
|
|
BEGIN
|
|
Asm
|
|
push ds
|
|
push es
|
|
mov ax,[where]
|
|
mov es,ax
|
|
mov bx,[y]
|
|
shl bx,4
|
|
mov dx,bx {; and this again for later}
|
|
shl bx, 1 {; bx = dx}
|
|
add dx, bx {; dx = dx * 256}
|
|
shl bx,1
|
|
add dx,bx
|
|
shl bx, 1
|
|
add dx, bx
|
|
add dx,[x] {; bx = bx * 64}
|
|
{; dx = dx + bx (ie y*320)}
|
|
{; get back our x}
|
|
{; finalise location}
|
|
mov di, dx
|
|
{; es:di = where to go}
|
|
xor al,al
|
|
mov ah, [Col]
|
|
mov es:[di],ah
|
|
pop es
|
|
pop ds
|
|
End;
|
|
END;
|
|
|
|
function getpixel(x,y,where:word):byte;
|
|
begin
|
|
getpixel:=mem[where:x+(y*320)];
|
|
end;
|
|
|
|
Procedure Pal(Col,R,G,B : Byte);
|
|
{ This sets the Red, Green and Blue values of a certain color }
|
|
Begin
|
|
asm
|
|
mov dx,3c8h
|
|
mov al,[col]
|
|
out dx,al
|
|
inc dx
|
|
mov al,[r]
|
|
out dx,al
|
|
mov al,[g]
|
|
out dx,al
|
|
mov al,[b]
|
|
out dx,al
|
|
end;
|
|
End;
|
|
|
|
procedure WaitRetrace; assembler;
|
|
{ This waits for a vertical retrace to reduce snow on the screen }
|
|
label
|
|
l1, l2;
|
|
asm
|
|
mov dx,3DAh
|
|
l1:
|
|
in al,dx
|
|
and al,08h
|
|
jnz l1
|
|
l2:
|
|
in al,dx
|
|
and al,08h
|
|
jz l2
|
|
end;
|
|
|
|
Procedure GetPal(Col : Byte; Var R,G,B : Byte);
|
|
{ This gets the Red, Green and Blue values of a certain color }
|
|
Var
|
|
rr,gg,bb : Byte;
|
|
Begin
|
|
asm
|
|
mov dx,3c7h
|
|
mov al,col
|
|
out dx,al
|
|
|
|
add dx,2
|
|
|
|
in al,dx
|
|
mov [rr],al
|
|
in al,dx
|
|
mov [gg],al
|
|
in al,dx
|
|
mov [bb],al
|
|
end;
|
|
r := rr;
|
|
g := gg;
|
|
b := bb;
|
|
end;
|
|
|
|
|
|
|
|
|
|
procedure outtextlineover(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
label gus1,gus4,gus5,gus7,gus8,gus3;
|
|
var i,len:word;
|
|
|
|
begin
|
|
len:=length(St);
|
|
for i:=1 to (len div 2)+1 do begin
|
|
fontline[(i-1)*2]:=charset[ord(st[(i*2)]),line];
|
|
fontline[((i-1)*2)+1]:=charset[ord(st[(i*2)-1]),line];
|
|
end;
|
|
asm
|
|
push ds
|
|
push si
|
|
push es
|
|
push di
|
|
mov ax,[fontseg]
|
|
mov ds,ax
|
|
mov ax,[fontoff]
|
|
mov si,ax
|
|
mov dh,[col]
|
|
mov dl,[background]
|
|
mov ax,[y] {multiplies y value by 320}
|
|
shl ax,5
|
|
mov cx,ax
|
|
shl ax,1
|
|
shl cx,3
|
|
add ax,cx
|
|
add ax,[x] {adds the x-value to get offset}
|
|
mov di,ax
|
|
mov ax,[where]
|
|
mov es,ax
|
|
mov bx,[len]
|
|
gus1:
|
|
cmp bx,02
|
|
jnge gus4
|
|
mov cx,16
|
|
lodsw
|
|
jmp gus5
|
|
gus4:
|
|
mov cx,8
|
|
lodsw
|
|
gus5:
|
|
shl ax,1
|
|
push ax
|
|
jc gus7
|
|
mov al,dl
|
|
jmp gus8
|
|
gus7:
|
|
mov al,dh
|
|
gus8:
|
|
xor ah,ah
|
|
stosb
|
|
pop ax
|
|
loop gus5
|
|
cmp bx,2
|
|
jng gus3
|
|
dec bx
|
|
dec bx
|
|
|
|
jmp gus1
|
|
gus3:
|
|
pop di
|
|
pop es
|
|
pop si
|
|
pop ds
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure outtextline(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
label gus1,gus4,gus6,gus5,gus7,gus8,gus3;
|
|
var i,len:word;
|
|
|
|
begin
|
|
len:=length(St);
|
|
for i:=1 to (len div 2)+1 do begin
|
|
fontline[(i-1)*2]:=charset[ord(st[(i*2)]),line];
|
|
fontline[((i-1)*2)+1]:=charset[ord(st[(i*2)-1]),line];
|
|
end;
|
|
asm
|
|
push ds
|
|
push si
|
|
push es
|
|
push di
|
|
mov ax,[fontseg]
|
|
mov ds,ax
|
|
mov ax,[fontoff]
|
|
mov si,ax
|
|
mov dh,[col]
|
|
mov bl,[background]
|
|
mov ax,[y] {multiplies y value by 320}
|
|
shl ax,5
|
|
mov cx,ax
|
|
shl ax,1
|
|
shl cx,3
|
|
add ax,cx
|
|
add ax,[x] {adds the x-value to get offset}
|
|
mov di,ax
|
|
mov ax,[where]
|
|
mov es,ax
|
|
mov bx,[len]
|
|
|
|
gus1:
|
|
|
|
cmp bx,02
|
|
|
|
jnge gus4
|
|
mov cx,16
|
|
lodsw
|
|
jmp gus5
|
|
gus4:
|
|
mov cx,8
|
|
lodsw
|
|
gus5:
|
|
shl ax,1
|
|
push ax
|
|
jc gus7
|
|
inc di
|
|
jmp gus8
|
|
gus7:
|
|
mov al,dh
|
|
xor ah,ah
|
|
stosb
|
|
gus8:
|
|
pop ax
|
|
loop gus5
|
|
cmp bx,2
|
|
jng gus3
|
|
dec bx
|
|
dec bx
|
|
jmp gus1
|
|
gus3:
|
|
pop di
|
|
pop es
|
|
pop si
|
|
pop ds
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure outtextxy(st:string;x,y,col,background:integer;where:word;overwrite:boolean);
|
|
label l0105;
|
|
var l,len,i,xadd,yadd,lineon:integer;
|
|
n,k,o,min,max,qwerty:byte;
|
|
begin
|
|
for lineon:=0 to (charheight-1) do
|
|
if overwrite then
|
|
outtextlineover(st,x,y+lineon,col,background,lineon,where)
|
|
else
|
|
outtextline(st,x,y+lineon,col,background,lineon,where);
|
|
|
|
end;
|
|
|
|
|
|
|
|
procedure OutSmallTextLineOver(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
label gus1,gus4,gus5,gus7,gus8,gus3;
|
|
var i,len:word;
|
|
|
|
begin
|
|
len:=length(St);
|
|
for i:=1 to (len div 2)+1 do begin
|
|
fontline[(i-1)*2]:=charset[(ord(st[(i*2)]))+128,line];
|
|
fontline[((i-1)*2)+1]:=charset[(ord(st[(i*2)-1]))+128,line];
|
|
end;
|
|
asm
|
|
push ds
|
|
push si
|
|
push es
|
|
push di
|
|
mov ax,[fontseg]
|
|
mov ds,ax
|
|
mov ax,[fontoff]
|
|
mov si,ax
|
|
mov dh,[col]
|
|
mov dl,[background]
|
|
mov ax,[y] {multiplies y value by 320}
|
|
shl ax,5
|
|
mov cx,ax
|
|
shl ax,1
|
|
shl cx,3
|
|
add ax,cx
|
|
add ax,[x] {adds the x-value to get offset}
|
|
mov di,ax
|
|
mov ax,[where]
|
|
mov es,ax
|
|
mov bx,[len]
|
|
gus1:
|
|
xor ax,ax
|
|
cmp bx,02
|
|
jnge gus4
|
|
mov cx,10
|
|
lodsb
|
|
push bx
|
|
mov bl,al
|
|
xor bh,bh
|
|
lodsb
|
|
shl ax,5
|
|
add ax,bx
|
|
shl ax,3
|
|
pop bx
|
|
jmp gus5
|
|
gus4:
|
|
mov cx,5
|
|
lodsw
|
|
gus5:
|
|
shl ax,1
|
|
push ax
|
|
jc gus7
|
|
mov al,dl
|
|
jmp gus8
|
|
gus7:
|
|
mov al,dh
|
|
gus8:
|
|
xor ah,ah
|
|
stosb
|
|
pop ax
|
|
loop gus5
|
|
cmp bx,2
|
|
jng gus3
|
|
dec bx
|
|
dec bx
|
|
jmp gus1
|
|
gus3:
|
|
pop di
|
|
pop es
|
|
pop si
|
|
pop ds
|
|
end;
|
|
end;
|
|
|
|
procedure outsmalltextline(st:string;x,y:integer;col,background:byte;line:integer;where:word);
|
|
label gus1,gus4,gus6,gus5,gus7,gus8,gus3;
|
|
var i,len:word;
|
|
|
|
begin
|
|
len:=length(St);
|
|
for i:=1 to (len div 2)+1 do begin
|
|
fontline[(i-1)*2]:=charset[(ord(st[(i*2)]))+128,line];
|
|
fontline[((i-1)*2)+1]:=charset[(ord(st[(i*2)-1]))+128,line];
|
|
end;
|
|
asm
|
|
push ds
|
|
push si
|
|
push es
|
|
push di
|
|
mov ax,[fontseg]
|
|
mov ds,ax
|
|
mov ax,[fontoff]
|
|
mov si,ax
|
|
mov dh,[col]
|
|
mov bl,[background]
|
|
mov ax,[y] {multiplies y value by 320}
|
|
shl ax,5
|
|
mov cx,ax
|
|
shl ax,1
|
|
shl cx,3
|
|
add ax,cx
|
|
add ax,[x] {adds the x-value to get offset}
|
|
mov di,ax
|
|
mov ax,[where]
|
|
mov es,ax
|
|
mov bx,[len]
|
|
|
|
gus1:
|
|
xor ax,ax
|
|
cmp bx,02
|
|
jnge gus4
|
|
mov cx,10
|
|
lodsb
|
|
push bx
|
|
mov bl,al
|
|
xor bh,bh
|
|
lodsb
|
|
shl ax,5
|
|
add ax,bx
|
|
shl ax,3
|
|
pop bx
|
|
jmp gus5
|
|
gus4:
|
|
mov cx,5
|
|
lodsw
|
|
gus5:
|
|
shl ax,1
|
|
push ax
|
|
jc gus7
|
|
inc di
|
|
jmp gus8
|
|
gus7:
|
|
mov al,dh
|
|
xor ah,ah
|
|
stosb
|
|
gus8:
|
|
pop ax
|
|
loop gus5
|
|
cmp bx,2
|
|
jng gus3
|
|
dec bx
|
|
dec bx
|
|
jmp gus1
|
|
gus3:
|
|
pop di
|
|
pop es
|
|
pop si
|
|
pop ds
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure outsmalltextxy(st:string;x,y,col,background:integer;where:word;overwrite:boolean);
|
|
label l0105;
|
|
var l,len,i,xadd,yadd,lineon:integer;
|
|
n,k,o,min,max,qwerty:byte;
|
|
begin
|
|
for lineon:=0 to 4 do
|
|
if overwrite then
|
|
outsmalltextlineover(st,x,y+lineon,col,background,lineon,where)
|
|
else
|
|
outsmalltextline(st,x,y+lineon,col,background,lineon,where);
|
|
|
|
end;
|
|
|
|
|
|
|
|
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;
|
|
|
|
procedure line(a,b,c,d,col:integer;where:word);
|
|
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,where);
|
|
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 horizontalline(FromX1,ToX2,AtY,col:integer;where:word);
|
|
|
|
begin
|
|
asm
|
|
push es
|
|
push di
|
|
|
|
mov ax,[aty] {multiplies y value by 320}
|
|
shl ax,5
|
|
mov cx,ax
|
|
shl ax,1
|
|
shl cx,3
|
|
add ax,cx
|
|
add ax,[fromx1] {adds the x-value to get offset}
|
|
mov di,ax
|
|
mov ax,[where]
|
|
mov es,ax
|
|
|
|
mov cx,[tox2]
|
|
sub cx,[fromx1] {how long line is}
|
|
|
|
xor ax,ax {load color}
|
|
mov ax,col
|
|
rep stosb {draw it}
|
|
pop di
|
|
pop es
|
|
end;
|
|
end;
|
|
|
|
procedure verticalline(FromY1,ToY2,AtX,col:integer;where:word);
|
|
label mree2,mree3,mree,mree4;
|
|
begin
|
|
asm
|
|
push es
|
|
push di
|
|
xor dx,dx
|
|
mov bx,[toy2] {this mess saves you}
|
|
mov ax,[fromy1] {if you put a y1 value}
|
|
{lower than y2. It is}
|
|
cmp bx,ax {probably unnecessary}
|
|
jz mree3
|
|
jl Mree2
|
|
sub bx,ax {how long line is}
|
|
mov dx,bx
|
|
|
|
jmp mree3
|
|
mree2:
|
|
sub ax,bx
|
|
mov dx,ax
|
|
mov ax,[toy2]
|
|
mree3:
|
|
|
|
|
|
|
|
{mov ax,[FromY1]} {multiplies y value by 320}
|
|
shl ax,5
|
|
mov cx,ax
|
|
shl ax,1
|
|
shl cx,3
|
|
add ax,cx
|
|
add ax,[atX] {adds the x-value to get offset}
|
|
mov di,ax
|
|
mov ax,[where]
|
|
mov es,ax
|
|
|
|
|
|
mov cx,dx
|
|
inc cx
|
|
|
|
xor ax,ax {load color}
|
|
mov ax,col
|
|
|
|
Mree:
|
|
stosb {draw it}
|
|
add di,319
|
|
loop mree
|
|
mree4:
|
|
pop di
|
|
pop es
|
|
end;
|
|
end;
|
|
|
|
procedure fade;
|
|
var i,j:integer;
|
|
r,g,b:byte;
|
|
begin
|
|
for i:=0 to 255 do begin
|
|
getpal(i,r,g,b);
|
|
unfadered[i]:=r;
|
|
unfadeblue[i]:=b;
|
|
unfadegreen[i]:=g;
|
|
end;
|
|
for i:=0 to 63 do begin
|
|
for j:=0 to 255 do begin
|
|
getpal(j,r,g,b);
|
|
if r>0 then dec(r);
|
|
if g>0 then dec(g);
|
|
if b>0 then dec(b);
|
|
pal(j,r,g,b);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure unfade;
|
|
var i,j:integer;
|
|
r,g,b:byte;
|
|
begin
|
|
for i:=0 to 63 do begin
|
|
for j:=0 to 255 do begin
|
|
getpal(j,r,g,b);
|
|
if r<unfadered[j] then inc(r);
|
|
if g<unfadegreen[j] then inc(g);
|
|
if b<unfadeblue[j] then inc(b);
|
|
pal(j,r,g,b);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
|
|
procedure box(x1,y1,x2,y2,col:integer;where:word);
|
|
begin
|
|
line(x1,y1,x1,y2,col,where);
|
|
horizontalline(x1,x2,y2,col,where);
|
|
line(x2,y2,x2,y1,col,where);
|
|
horizontalline(x1,x2,y1,col,where);
|
|
end;
|
|
|
|
procedure vdelay(howlong:integer);
|
|
var i:integer;
|
|
begin
|
|
for i:=1 to howlong do waitretrace;
|
|
end;
|
|
|
|
procedure setupvmwgraph;
|
|
begin
|
|
loadfont('8x8font.tb1');
|
|
charheight:=8;
|
|
fontseg:=seg(fontline[0]);
|
|
fontoff:=ofs(fontline[0]);
|
|
end;
|
|
|
|
procedure setuptb1;
|
|
begin
|
|
loadfont('tbfont.tb1');
|
|
charheight:=8;
|
|
fontseg:=seg(fontline[0]);
|
|
fontoff:=ofs(fontline[0]);
|
|
end;
|
|
|
|
|
|
begin
|
|
end.
|