mirror of https://github.com/deater/tb1.git
1073 lines
22 KiB
ObjectPascal
1073 lines
22 KiB
ObjectPascal
unit NVMWgraph; {the new vmw graph unit}
|
|
{$X+} {$G+}
|
|
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;
|
|
|
|
Procedure SetMCGA;
|
|
Procedure SetText; { This procedure returns you to text mode. }
|
|
Procedure LoadFont(namest:string);
|
|
Procedure Cls (Col : Byte; Where:word);
|
|
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 flip(source,dest:Word);
|
|
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;
|
|
function SavePicSuperPacked(x1,y1,x2,y2,maxcolors:integer;where:word;filename:string):byte;
|
|
function LoadPicSuperPacked(x1,y1:integer;where:word;LoadPal,LoadPic:boolean;FileName:string):byte;
|
|
function oldloadpicsuperpacked(x1,y1:integer;where:word;fil:string):byte;
|
|
procedure box(x1,y1,x2,y2,col:integer;where:word);
|
|
procedure vdelay(howlong:integer);
|
|
procedure setupvmwgraph;
|
|
procedure setuptb1;
|
|
|
|
{Errors for save and load:
|
|
0=No error
|
|
1=File Not Found
|
|
2=Improper file type (No PAINTPROVX.XX header)
|
|
3=Improper version
|
|
4=Too Many Colors
|
|
5=Picture Too Big
|
|
}
|
|
|
|
|
|
IMPLEMENTATION
|
|
|
|
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 Cls (Col : Byte; Where:word);
|
|
{ This clears the screen to the specified color }
|
|
BEGIN
|
|
asm
|
|
push es
|
|
mov cx, 32000;
|
|
mov es,[where]
|
|
xor di,di
|
|
mov al,[col]
|
|
mov ah,al
|
|
rep stosw
|
|
pop es
|
|
End;
|
|
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 flip(source,dest:Word);
|
|
{ This copies the entire screen at "source" to destination }
|
|
begin
|
|
asm
|
|
push ds
|
|
mov ax, [Dest]
|
|
mov es, ax
|
|
mov ax, [Source]
|
|
mov ds, ax
|
|
xor si, si
|
|
xor di, di
|
|
mov cx, 32000
|
|
rep movsw
|
|
pop ds
|
|
end;
|
|
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;
|
|
|
|
|
|
function SavePicSuperPacked(x1,y1,x2,y2,maxcolors:integer;where:word;filename:string):byte;
|
|
|
|
var buffer:array[0..2] of byte;
|
|
f:file;
|
|
col,x,y,xsize,ysize,i,oldcol,numacross:integer;
|
|
header:string;
|
|
byte1,byte2,byte3,temp:byte;
|
|
r,g,b:byte;
|
|
|
|
procedure integer23bytes(inter1,inter2:integer);
|
|
var temp1,temp2,temp3,temp:byte;
|
|
begin
|
|
asm
|
|
mov ax,inter1
|
|
shl ax,1
|
|
shl ax,1
|
|
shl ax,1
|
|
shl ax,1
|
|
mov temp1,ah
|
|
sub ah,ah
|
|
shr ax,1
|
|
shr ax,1
|
|
shr ax,1
|
|
shr ax,1
|
|
mov temp,al
|
|
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
|
|
shl ax,1
|
|
shl ax,1
|
|
mov temp2,ah
|
|
end;
|
|
buffer[0]:=temp1;
|
|
buffer[1]:=temp2;
|
|
buffer[2]:=temp3;
|
|
blockwrite(f,buffer,1);
|
|
end;
|
|
|
|
begin
|
|
header:='PAINTPROV5.0';
|
|
savepicsuperpacked:=0;
|
|
assign(f,filename);
|
|
{$I-}
|
|
rewrite(f,3);
|
|
{$I+}
|
|
if Ioresult<>0 then savepicsuperpacked:=1;
|
|
if Ioresult<>0 then exit;
|
|
for i:=0 to 3 do begin
|
|
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;
|
|
|
|
for i:=0 to (maxcolors-1) do
|
|
begin
|
|
getpal(i,buffer[0],buffer[1],buffer[2]);
|
|
blockwrite(f,buffer,1);
|
|
end;
|
|
|
|
xsize:=abs(x2-x1);
|
|
ysize:=abs(y2-y1);
|
|
integer23bytes(xsize,ysize);
|
|
integer23bytes(maxcolors,0);
|
|
|
|
for y:=y1 to y2 do begin
|
|
oldcol:=getpixel(x1,y,where); numacross:=1;
|
|
for x:=(x1+1) to x2 do begin
|
|
col:=getpixel(x,y,where);
|
|
if col=oldcol then inc(numacross)
|
|
else begin
|
|
integer23bytes(oldcol,numacross);
|
|
numacross:=1;
|
|
end;
|
|
oldcol:=col;
|
|
end;
|
|
integer23bytes(col,numacross);
|
|
end;
|
|
close(f);
|
|
end;
|
|
|
|
function LoadPicSuperPacked(x1,y1:integer;where:word;LoadPal,LoadPic:boolean;FileName:string):byte;
|
|
|
|
var buffer:array[0..299] of byte;
|
|
result,buffpointer:integer;
|
|
f:file;
|
|
col,x,y,xsize,ysize,i,oldcol,
|
|
maxcolors,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
|
|
mov al,temp2
|
|
shr ax,4
|
|
mov int1,ax
|
|
mov ah,temp2
|
|
mov al,temp3
|
|
shl ah,4
|
|
shr ah,4
|
|
mov int2,ax
|
|
end;
|
|
tempint1:=int1;
|
|
tempint2:=int2;
|
|
end;
|
|
|
|
|
|
|
|
begin
|
|
lastread:=false;
|
|
loadpicsuperpacked:=0;
|
|
header:='';
|
|
buffpointer:=0;
|
|
assign(f,filename);
|
|
{$I-}
|
|
reset(f,1);
|
|
{$I+}
|
|
if IOresult<>0 then LoadPicSuperPacked:=1;
|
|
if IOresult<>0 then exit;
|
|
|
|
blockread(f,buffer,300,result);
|
|
|
|
for i:=1 to 9 do header:=concat(header,chr(buffer[i-1]));
|
|
|
|
|
|
if header<> 'PAINTPROV' then LoadPicSuperPacked:=2;
|
|
if header<> 'PAINTPROV' then exit;
|
|
|
|
header:='';
|
|
|
|
header:=concat(header,chr(buffer[9]),chr(buffer[10]),chr(buffer[11]));
|
|
|
|
if header<>'5.0' then LoadPicSuperPacked:=3;
|
|
if header<>'5.0' then exit;
|
|
buffpointer:=12;
|
|
|
|
for i:=0 to 255 do begin
|
|
r:=buffer[buffpointer];
|
|
g:=buffer[buffpointer+1];
|
|
b:=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;
|
|
if loadpal then pal(i,r,g,b);
|
|
end;
|
|
|
|
|
|
|
|
sixbytes2twoint;
|
|
xsize:=tempint1;
|
|
ysize:=tempint2;
|
|
sixbytes2twoint;
|
|
maxcolors:=tempint1;
|
|
|
|
{if maxcolors>256 then error=4}
|
|
|
|
x:=x1;
|
|
y:=y1;
|
|
if loadpic=true then begin
|
|
while (lastread=false) do begin
|
|
sixbytes2twoint;
|
|
col:=tempint1;
|
|
numacross:=tempint2;
|
|
horizontalline(x,x+numacross,y,col,where);
|
|
{ for i:=x to (x+numacross) do putpixel(i,y,col,where);}
|
|
if (x+numacross)>xsize+x1 then begin
|
|
inc(y);
|
|
x:=x1;
|
|
numacross:=0;
|
|
end;
|
|
x:=x+numacross;
|
|
end;
|
|
end;
|
|
close(f);
|
|
end;
|
|
|
|
function oldloadpicsuperpacked(x1,y1:integer;where:word;fil:string):byte;
|
|
|
|
var buffer:array[0..255] of byte;
|
|
f:file;
|
|
col,x,y,xsize,ysize,buffpointer,i,oldcol,
|
|
tempint1,tempint2,numacross:integer;
|
|
header:string;
|
|
lastread,done:boolean;
|
|
temp7:string;
|
|
|
|
procedure readbuffer;
|
|
begin
|
|
blockread(f,buffer,1);
|
|
if buffer[255]=90 then lastread:=true;
|
|
end;
|
|
|
|
procedure sixbytes2twoint;
|
|
var temp1,temp2,temp3:byte;
|
|
int1,int2:integer;
|
|
begin
|
|
if buffpointer>=253 then begin
|
|
readbuffer;
|
|
buffpointer:=0;
|
|
end;
|
|
if not done then begin
|
|
temp1:=buffer[buffpointer];
|
|
temp2:=buffer[buffpointer+1];
|
|
temp3:=buffer[buffpointer+2];
|
|
if (temp1=255) and (temp2=255) and (temp3=255) then
|
|
done:=true;
|
|
inc(buffpointer,3);
|
|
asm
|
|
mov ah,temp1
|
|
mov al,temp2
|
|
shr ax,1
|
|
shr ax,1
|
|
shr ax,1
|
|
shr ax,1
|
|
mov int1,ax
|
|
mov ah,temp2
|
|
mov al,temp3
|
|
shl ah,4
|
|
shr ah,4
|
|
mov int2,ax
|
|
end;
|
|
tempint1:=int1;
|
|
tempint2:=int2;
|
|
end;
|
|
end;
|
|
label ender;
|
|
begin
|
|
done:=false;
|
|
header:='PAINTPROV4.00';
|
|
assign(f,fil);
|
|
reset(f,256);
|
|
readbuffer;
|
|
buffpointer:=0;
|
|
temp7:=header;
|
|
for i:=1 to 13 do temp7[i]:=chr(buffer[i-1]);
|
|
if temp7<>header then begin
|
|
oldloadpicsuperpacked:=01;
|
|
exit;
|
|
end;
|
|
buffpointer:=13;
|
|
sixbytes2twoint;
|
|
xsize:=tempint1;
|
|
ysize:=tempint2;
|
|
sixbytes2twoint;
|
|
|
|
x:=x1;
|
|
y:=y1;
|
|
repeat
|
|
sixbytes2twoint;
|
|
if done then goto ender;
|
|
col:=tempint1;
|
|
numacross:=tempint2;
|
|
for i:=x to (x+numacross) do putpixel(i,y,col,where);
|
|
if (x+numacross)>xsize+x1 then begin
|
|
inc(y);
|
|
x:=x1;
|
|
numacross:=0;
|
|
end;
|
|
x:=x+numacross;
|
|
ender:
|
|
until done=true;
|
|
close(f);
|
|
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.
|