952 lines
No EOL
16 KiB
ObjectPascal
952 lines
No EOL
16 KiB
ObjectPascal
Unit GraphVGA;
|
||
interface
|
||
Uses
|
||
CRT,DOS;
|
||
Const
|
||
NormEffect = 0;
|
||
FadeEffect = 1;
|
||
noViewEfct = 2;
|
||
GetMaxX = 319;
|
||
GetMaxY = 199;
|
||
CentreX = 160;
|
||
CentreY = 100;
|
||
VGA = $13;
|
||
CGALo = $04;
|
||
CGAHi = $06;
|
||
On = True;
|
||
Off = False;
|
||
Screen : Pointer = Ptr($0000,$0000);
|
||
MagicLong : Longint = $11111111;
|
||
Type
|
||
Infor = Record
|
||
X1,Y1,X2,Y2 : Integer;
|
||
End;
|
||
PointType = Record
|
||
X,Y : Integer;
|
||
End;
|
||
ColorRGB = Record
|
||
Rouge : Byte;
|
||
Vert : Byte;
|
||
Bleu : Byte;
|
||
End;
|
||
RGB = Array[0..$FF] of ColorRGB;
|
||
ImageInfo = Record
|
||
SizeX : Word;
|
||
SizeY : Word;
|
||
Palette : RGB;
|
||
Picture : Pointer;
|
||
Size : Word;
|
||
End;
|
||
Var
|
||
PageW : Pointer;
|
||
PageWS : Word;
|
||
PageWO : Word;
|
||
WriteS : Word;
|
||
Reg : Registers;
|
||
RGBPal : RGB;
|
||
DirectV : Boolean;
|
||
VgaMode : Boolean;
|
||
Doub : Boolean;
|
||
DefSpd : Byte;
|
||
_CColor : Byte;
|
||
|
||
Procedure pause(Speed : Word);
|
||
|
||
Procedure SimpleBuffer;
|
||
|
||
Procedure DoubleBuffer;
|
||
|
||
Procedure SetDColor( c: Byte);
|
||
|
||
Function Rad(A : Real) : real;
|
||
|
||
Function Deg(A : Real) : Real;
|
||
|
||
Procedure WaitVBL;
|
||
|
||
Procedure SetRGB(Var Pal : RGB);
|
||
|
||
Procedure GetRGB(Var Pal : RGB);
|
||
|
||
{ Assembler : }
|
||
Procedure InitGraph( Mode : Byte );
|
||
|
||
Procedure CloseGraph;
|
||
|
||
Procedure SetSpeed(Speed : Byte);
|
||
{ Assembler : }
|
||
Procedure PutPixel ( X,Y : Integer;
|
||
C : Byte);
|
||
|
||
Function GetPixel ( X,Y : Integer) : Byte;
|
||
|
||
Function GPixel ( X,Y : Integer) : Byte;
|
||
|
||
Procedure ClearDevice(CColor : Byte);
|
||
|
||
Procedure ViewPage;
|
||
|
||
Procedure DirectVideo(Direct : Boolean);
|
||
|
||
Function GetVideo : Boolean;
|
||
|
||
Procedure SetColor ( Color, Red, Green, Blue : Byte );
|
||
|
||
Procedure SetRGBColor( Color,R,G,B : Byte; Var Pal : RGB);
|
||
|
||
{ Assembler }
|
||
Procedure Line(X1,Y1,X2,Y2 : Integer; Color : byte);
|
||
|
||
Procedure PaletteOff;
|
||
|
||
{ Assembler }
|
||
Procedure FadeOut(First,Last : Word; Speed : Byte);
|
||
|
||
Procedure FadeIn(first,Last : word; Var Pal : RGB; speed : Byte);
|
||
|
||
Procedure FadeFromWhite(first,Last : word; Var Pal : RGB; Speed : Byte);
|
||
|
||
Procedure FadeWhite(First,Last : Word; speed : Byte);
|
||
|
||
Function expo(A,E : integer) : LongInt;
|
||
|
||
Procedure PutImage( Var Im : ImageInfo;
|
||
Mo : Byte);
|
||
|
||
Procedure AllocImage( SX,SY : Word;
|
||
Var I : imageInfo);
|
||
|
||
Procedure FreeImage( Var I : ImageInfo);
|
||
|
||
Procedure LoadRIX(N : String; Var Ima : Imageinfo);
|
||
|
||
Procedure Comprs(Var Pic : Pointer; Var Taille : Word);
|
||
|
||
Procedure UnComprs(Pic : Pointer; ToP : Pointer);
|
||
|
||
Implementation
|
||
{
|
||
Var
|
||
PageW : Pointer;
|
||
PageWS : Word;
|
||
PageWO : Word;
|
||
WriteS : Word;
|
||
Reg : Registers;
|
||
DirectV : Boolean;
|
||
VgaMode : Boolean;
|
||
DefSpd : Byte;
|
||
_CColor : Byte;
|
||
}
|
||
|
||
Procedure Pause(Speed : Word);
|
||
Var
|
||
I : Word;
|
||
Begin
|
||
I := 0;
|
||
Repeat
|
||
Inc(I);
|
||
Until I>Speed;
|
||
End;
|
||
|
||
Procedure SetDColor( c: Byte);
|
||
Begin
|
||
_CColor := C;
|
||
End;
|
||
|
||
Function Rad(A : Real) : real;
|
||
Begin
|
||
Rad := (A*Pi)/180;
|
||
End;
|
||
|
||
Function Deg(A : Real) : Real;
|
||
Begin
|
||
Deg := (A*180) /pi;
|
||
End;
|
||
|
||
Procedure WaitVBL; Assembler;
|
||
Asm
|
||
{ Wait VBL }
|
||
Mov DX,$3DA
|
||
@W: in AL,DX
|
||
Test AL,$08
|
||
Jne @W
|
||
|
||
@X: in AL,DX
|
||
test AL,$08
|
||
Je @X
|
||
end;
|
||
|
||
Procedure SetColor ( Color, Red, Green, Blue : Byte ); Assembler;
|
||
Asm
|
||
PushA
|
||
Mov DX,$3C8
|
||
Mov AL,[Color]
|
||
Out DX,AL
|
||
Inc DX
|
||
Mov AL,[Red]
|
||
Out DX,AL
|
||
Mov AL,[Green]
|
||
Out DX,AL
|
||
Mov AL,[Blue]
|
||
Out DX,AL
|
||
PopA
|
||
End;
|
||
|
||
Procedure SetRGB(Var Pal : RGB); Assembler;
|
||
Asm
|
||
Push DS
|
||
Push SI
|
||
Push DX
|
||
Push CX
|
||
Push AX
|
||
|
||
Lds SI,[Pal]
|
||
cld
|
||
Xor CX,CX
|
||
Mov DX,$3C8
|
||
@Beg:
|
||
Mov AL,CL
|
||
Out DX,AL
|
||
Inc DX
|
||
LodsB
|
||
Out DX,AL
|
||
Lodsb
|
||
Out DX,AL
|
||
Lodsb
|
||
Out DX,AL
|
||
inc CX
|
||
Dec DX
|
||
cmp CH,$00
|
||
je @beg
|
||
|
||
mov DI,offset [RGBPal]
|
||
mov ax,seg [rgbPal]
|
||
mov es,ax
|
||
Lds SI,[Pal]
|
||
mov CX,3*$FF
|
||
rep movsb
|
||
Pop AX
|
||
Pop CX
|
||
Pop DX
|
||
Pop SI
|
||
Pop DS
|
||
End;
|
||
|
||
Procedure GetRGB(Var Pal : RGB); Assembler;
|
||
Asm
|
||
Push DS
|
||
Push SI
|
||
Push DX
|
||
Push CX
|
||
Push AX
|
||
|
||
Les DI,[Pal]
|
||
cld
|
||
Xor CX,CX
|
||
@Beg:
|
||
Mov DX,$3C8
|
||
Mov AL,CL
|
||
Out DX,AL
|
||
Inc DX
|
||
In AL,DX
|
||
StosB
|
||
In AL,DX
|
||
StosB
|
||
In AL,DX
|
||
StosB
|
||
inc CX
|
||
cmp CH,$00
|
||
jz @beg
|
||
|
||
Pop AX
|
||
Pop CX
|
||
Pop DX
|
||
Pop SI
|
||
Pop DS
|
||
End;
|
||
|
||
Procedure SetSpeed(Speed : Byte);
|
||
Begin
|
||
DefSpd := Speed;
|
||
End;
|
||
|
||
Procedure SimpleBuffer;
|
||
Begin
|
||
If not Doub Then Exit;
|
||
Freemem(PageW,$FFFF);
|
||
PageWS := $A000;
|
||
WriteS := $A000;
|
||
Doub := false;
|
||
End;
|
||
|
||
Procedure DoubleBuffer;
|
||
Begin
|
||
If Doub Then Exit;
|
||
Getmem(pageW,$FFFF);
|
||
PageWS := Seg(PageW^);
|
||
WriteS := PageWS;
|
||
Doub := True;
|
||
End;
|
||
|
||
Procedure InitGraph( Mode : Byte );
|
||
Begin
|
||
asm
|
||
Mov AH,$00
|
||
Mov AL,&Mode
|
||
int $10
|
||
End;
|
||
DirectV := False;
|
||
VGAMode := True;
|
||
DefSpd := 100;
|
||
Getmem(pageW,$FFFF);
|
||
PageWS := Seg(PageW^);
|
||
WriteS := PageWS;
|
||
Screen := Ptr($A000,0000);
|
||
FillChar(PageW^,64000,0);
|
||
Doub := True;
|
||
_CColor := 15;
|
||
GetRGB(RGBPal);
|
||
End;
|
||
|
||
Procedure CloseGraph;
|
||
Begin
|
||
If Not VGAMode Then
|
||
Exit;
|
||
If doub then
|
||
FreeMem(Pagew,$FFFF);
|
||
Asm
|
||
Mov AH,$00
|
||
Mov AL,$03
|
||
int $10
|
||
End;
|
||
TextMode(CO80);
|
||
End;
|
||
|
||
Procedure PutPixel( X,Y : Integer;
|
||
C : Byte); Assembler;
|
||
asm
|
||
Mov Ax,[X]
|
||
cmp [X],1
|
||
jl @exit
|
||
cmp [X],320
|
||
jg @exit
|
||
cmp [Y],1
|
||
jl @exit
|
||
cmp [Y],200
|
||
jg @exit
|
||
|
||
mov ax,&WriteS
|
||
mov Es,ax
|
||
dec [x] { X-1 }
|
||
dec [y] { Y-1 }
|
||
Imul ax,[Y],$140 { Y*320 }
|
||
mov di,[X]
|
||
add di,ax { Bx := Bx+Ax }
|
||
mov al,[c]
|
||
stosb
|
||
|
||
@exit:
|
||
End;
|
||
|
||
Function GPixel( X,Y : Integer) : Byte;
|
||
Begin
|
||
GPixel := Mem[WriteS:(Y-1)*320+(X-1)];
|
||
End;
|
||
|
||
Function GetPixel ( X,Y : Integer) : Byte;
|
||
Begin
|
||
GetPixel := Mem[WriteS:(Y-1)*320+(X-1)]
|
||
End;
|
||
|
||
Procedure ClearDevice(CColor : Byte); Assembler;
|
||
Asm
|
||
Mov CX,32000
|
||
Mov AX,[WriteS]
|
||
Mov ES,AX
|
||
Xor DI,DI
|
||
Mov AH,[CColor]
|
||
Mov AL,AH
|
||
Rep StosW
|
||
End;
|
||
|
||
Procedure ViewPage; Assembler;
|
||
Asm
|
||
Cmp &DirectV,0
|
||
jne @exit
|
||
|
||
Push DS
|
||
|
||
Mov AX,$A000
|
||
Mov ES,AX
|
||
Mov AX,&WriteS
|
||
Mov DS,AX
|
||
Mov CX,$7D00
|
||
Xor Si,Si
|
||
xor Di,Di
|
||
Rep MovsW
|
||
|
||
Pop DS
|
||
@exit:
|
||
End;
|
||
|
||
Procedure DirectVideo(Direct : Boolean);
|
||
Begin
|
||
Case Direct Of
|
||
True : WriteS := $A000;
|
||
False : WriteS := PageWS;
|
||
End;
|
||
directV := Direct;
|
||
End;
|
||
|
||
Function GetVideo : Boolean;
|
||
Begin
|
||
GetVideo := DirectV;
|
||
End;
|
||
|
||
Procedure SetRGBColor( Color,R,G,B : Byte; Var Pal : RGB);
|
||
Begin
|
||
With Pal[Color] Do
|
||
Begin
|
||
Rouge := R;
|
||
Vert := G;
|
||
Bleu := B;
|
||
End;
|
||
End;
|
||
|
||
Procedure Line(X1,Y1,X2,Y2 : Integer; Color : Byte); Assembler;
|
||
Asm
|
||
mov ax,WriteS
|
||
mov es,ax
|
||
mov si,x2
|
||
sub si,x1
|
||
mov ax,si
|
||
jns @1
|
||
neg ax
|
||
@1: mov di,y2
|
||
sub di,y1
|
||
mov bx,di
|
||
jns @2
|
||
neg bx
|
||
@2: cmp ax,bx
|
||
jge @3
|
||
jmp @4
|
||
@3: cmp ax,0
|
||
je @fin
|
||
std
|
||
cmp si,0
|
||
jge @5
|
||
cld
|
||
@5: mov cx,si
|
||
@bcl1: mov ax,si
|
||
imul di
|
||
idiv cx
|
||
add ax,y1
|
||
mov bx,ax
|
||
mov ax,320
|
||
mul bx
|
||
add ax,x1
|
||
add ax,si
|
||
mov bx,ax
|
||
mov al,color
|
||
mov byte ptr es:[bx],al
|
||
lodsb
|
||
cmp si,0
|
||
jnz @bcl1
|
||
jmp @fin
|
||
@4: xchg si,di
|
||
std
|
||
cmp si,0
|
||
jge @6
|
||
cld
|
||
@6: mov cx,si
|
||
@bcl2: mov bx,y1
|
||
add bx,si
|
||
mov ax,320
|
||
mul bx
|
||
mov bx,ax
|
||
mov ax,di
|
||
imul si
|
||
idiv cx
|
||
add ax,x1
|
||
add bx,ax
|
||
mov al,color
|
||
mov byte ptr es:[bx],al
|
||
lodsb
|
||
cmp si,0
|
||
jnz @bcl2
|
||
@fin:
|
||
end;
|
||
|
||
Procedure GetIntRGB ( Var Pal : RGB); Assembler;
|
||
asm
|
||
Mov AH,10h
|
||
mov AL,17h
|
||
Xor BX,BX
|
||
mov CX,256*3
|
||
les dx,Pal
|
||
int 10h
|
||
End;
|
||
|
||
Procedure PaletteOff;
|
||
Var
|
||
INPal : RGB;
|
||
Begin
|
||
fillChar(InPal,sizeOf(RGB),0);
|
||
SetRGB(InPal);
|
||
End;
|
||
|
||
Procedure FadeOut(First,Last : Word; Speed : Byte);
|
||
Var
|
||
R,G,B : Byte;
|
||
Begin
|
||
Asm
|
||
PushA
|
||
mov bl,speed
|
||
mov si,$40
|
||
@Gb:
|
||
Mov cx,[First]
|
||
call WaitVbl
|
||
@Rer:
|
||
{ Get R,G,B }
|
||
Mov dx,$3C7
|
||
Mov al,cl
|
||
Out dx,al
|
||
mov dx,$3C9
|
||
|
||
In al,dx
|
||
mov [r],Al
|
||
|
||
In al,dx
|
||
mov [g],Al
|
||
|
||
In al,dx
|
||
mov [b],Al
|
||
|
||
{ Decremente R,G,B }
|
||
cmp [r],0
|
||
je @G1
|
||
sub [R],bl
|
||
|
||
@G1: cmp [g],0
|
||
je @b1
|
||
sub [g],bl
|
||
|
||
@B1: cmp [B],0
|
||
je @n1
|
||
Sub [B],bl
|
||
|
||
{ Write to DAC VGA }
|
||
@N1: Mov DX,$3C8
|
||
mov al,cl
|
||
out dx,al
|
||
inc dx
|
||
|
||
mov al,[r]
|
||
out dx,al
|
||
|
||
mov al,[g]
|
||
out dx,al
|
||
|
||
mov al,[b]
|
||
out dx,al
|
||
|
||
inc cx
|
||
cmp cx,[Last]
|
||
jbe @rer
|
||
|
||
dec Si
|
||
cmp si,-1
|
||
jne @GB
|
||
PopA
|
||
End;
|
||
End;
|
||
|
||
Procedure FadeIn(first,Last : word; Var Pal : RGB; Speed : Byte);
|
||
Var
|
||
R,G,B : Byte;
|
||
Begin
|
||
Asm
|
||
PushA
|
||
Push ES
|
||
mov bl,speed
|
||
mov di,$40
|
||
@Gb:
|
||
Mov cx,[first]
|
||
call WaitVbl
|
||
@Rer:
|
||
{ Get R,G,B }
|
||
Les sI,Pal
|
||
mov dx,3
|
||
mov ax,cx
|
||
mul dx
|
||
add si,ax
|
||
Mov dx,$3C7
|
||
Mov al,cl
|
||
Out dx,al
|
||
mov dx,$3C9
|
||
|
||
In al,dx
|
||
mov [r],Al
|
||
|
||
In al,dx
|
||
mov [g],Al
|
||
|
||
In al,dx
|
||
mov [b],Al
|
||
|
||
lodsb
|
||
{ Decremente R,G,B }
|
||
cmp [r],al
|
||
je @G1
|
||
add [R],bl
|
||
|
||
@G1: lodsb
|
||
cmp [g],al
|
||
je @b1
|
||
add [g],bl
|
||
|
||
@B1: lodsb
|
||
cmp [B],al
|
||
je @n1
|
||
add [B],bl
|
||
|
||
{ Write to DAC VGA }
|
||
@N1: Mov DX,$3C8
|
||
mov al,cl
|
||
out dx,al
|
||
inc dx
|
||
|
||
mov al,[r]
|
||
out dx,al
|
||
|
||
mov al,[g]
|
||
out dx,al
|
||
|
||
mov al,[b]
|
||
out dx,al
|
||
|
||
inc cx
|
||
cmp cx,[last]
|
||
jbe @rer
|
||
|
||
dec di
|
||
cmp di,-1
|
||
jne @GB
|
||
Pop ES
|
||
PopA
|
||
End;
|
||
End;
|
||
|
||
Procedure FadeFromWhite(first,Last : word; Var Pal : RGB; Speed : Byte);
|
||
Var
|
||
R,G,B : Byte;
|
||
Begin
|
||
Asm
|
||
PushA
|
||
Push DS
|
||
mov bl,speed
|
||
mov di,$40
|
||
@Gb:
|
||
Mov cx,[first]
|
||
call WaitVbl
|
||
@Rer:
|
||
{ Get R,G,B }
|
||
LDs sI,Pal
|
||
mov dx,3
|
||
mov ax,cx
|
||
mul dx
|
||
add si,ax
|
||
Mov dx,$3C7
|
||
Mov al,cl
|
||
Out dx,al
|
||
mov dx,$3C9
|
||
|
||
In al,dx
|
||
mov [r],Al
|
||
|
||
In al,dx
|
||
mov [g],Al
|
||
|
||
In al,dx
|
||
mov [b],Al
|
||
|
||
lodsb
|
||
{ Decremente R,G,B }
|
||
cmp [r],al
|
||
je @G1
|
||
sub [R],bl
|
||
|
||
@G1: lodsb
|
||
cmp [g],al
|
||
je @b1
|
||
sub [g],bl
|
||
|
||
@B1: lodsb
|
||
cmp [B],al
|
||
je @n1
|
||
sub [B],bl
|
||
|
||
{ Write to DAC VGA }
|
||
@N1: Mov DX,$3C8
|
||
mov al,cl
|
||
out dx,al
|
||
inc dx
|
||
|
||
mov al,[r]
|
||
out dx,al
|
||
|
||
mov al,[g]
|
||
out dx,al
|
||
|
||
mov al,[b]
|
||
out dx,al
|
||
|
||
inc cx
|
||
cmp cx,[last]
|
||
jbe @rer
|
||
|
||
dec di
|
||
cmp di,$FFFF
|
||
jne @GB
|
||
Pop DS
|
||
PopA
|
||
End;
|
||
End;
|
||
|
||
Procedure FadeWhite(First,Last : Word; Speed : Byte);
|
||
Var
|
||
R,G,B : Byte;
|
||
Begin
|
||
Asm
|
||
mov bl,speed
|
||
mov BH,040h
|
||
sub bh,bl
|
||
mov si,40h
|
||
@Gb:
|
||
Mov cx,[First]
|
||
call WaitVbl
|
||
@Rer:
|
||
{ Get R,G,B }
|
||
Mov dx,$3C7
|
||
Mov al,cl
|
||
Out dx,al
|
||
mov dx,$3C9
|
||
|
||
In al,dx
|
||
mov [r],Al
|
||
|
||
In al,dx
|
||
mov [g],Al
|
||
|
||
In al,dx
|
||
mov [b],Al
|
||
|
||
{ Incremente R,G,B }
|
||
cmp r,bh
|
||
jnb @G1
|
||
add R,bl
|
||
|
||
@G1: cmp G,bh
|
||
jnb @b1
|
||
add G,bl
|
||
|
||
@B1: cmp B,bh
|
||
jnb @n1
|
||
add B,bl
|
||
|
||
{ Write to DAC VGA }
|
||
@N1: Mov DX,$3C8
|
||
mov al,cl
|
||
out dx,al
|
||
inc dx
|
||
|
||
mov al,[r]
|
||
out dx,al
|
||
|
||
mov al,[g]
|
||
out dx,al
|
||
|
||
mov al,[b]
|
||
out dx,al
|
||
|
||
inc cx
|
||
cmp cx,[Last]
|
||
jbe @rer
|
||
|
||
dec si
|
||
cmp si,-1
|
||
jne @GB
|
||
End;
|
||
GetRGB(RGBPal);
|
||
End;
|
||
|
||
Function expo(A,E : integer) : LongInt;
|
||
Var
|
||
E1 : Byte;
|
||
T : LongInt;
|
||
Begin
|
||
T := A;
|
||
For E1:= 1 to e-1 do
|
||
T := A * T;
|
||
Expo := T;
|
||
End;
|
||
|
||
Procedure PutImage( Var Im : ImageInfo;
|
||
Mo : Byte);
|
||
Var
|
||
X1,Y1 : Word;
|
||
Y2 : Word;
|
||
B : Boolean;
|
||
Begin
|
||
B := GetVideo;
|
||
If Mo <> 2 Then PaletteOff;
|
||
DirectVideo(On);
|
||
With Im do
|
||
Begin
|
||
For Y1:=1 to SizeY do
|
||
Begin
|
||
Y2 := (Y1-1)*320;
|
||
X1 := (Y1-1)*SizeX;
|
||
move( Mem[Seg(Picture^): Ofs(Picture^)+X1],
|
||
Mem[WriteS:(Y2)],SizeX);
|
||
End;
|
||
DirectVideo(B);
|
||
Case Mo Of
|
||
0 : SetRGB(Palette);
|
||
1 : FadeIn(0,$ff,Palette,1);
|
||
2 : SETRGB(Palette);
|
||
3 : ;
|
||
End;
|
||
End;
|
||
End;
|
||
|
||
Procedure AllocImage( SX,SY : Word;
|
||
Var I : imageInfo);
|
||
Var
|
||
Si : Longint;
|
||
Begin
|
||
Si := Longint(SX)*Longint(SY);
|
||
With I do
|
||
Begin
|
||
If SI > 64000 Then
|
||
SI := 64000;
|
||
GetMem(Picture,Si);
|
||
Size := Si;
|
||
SizeX := Sx;
|
||
SizeY := Sy;
|
||
End;
|
||
End;
|
||
|
||
Procedure FreeImage( Var I : ImageInfo);
|
||
Begin
|
||
With I do
|
||
Begin
|
||
FreeMem(Picture,Size);
|
||
Size := 0;
|
||
SizeX := 0;
|
||
SizeY := 0;
|
||
End;
|
||
End;
|
||
|
||
Procedure LoadRIX(N : String; Var Ima : Imageinfo);
|
||
Var
|
||
Header : LongInt;
|
||
F : file;
|
||
X,Y : Word;
|
||
CC : Byte;
|
||
Xs,YS : Word;
|
||
Info : Word;
|
||
Begin
|
||
Assign(F,N);
|
||
reset(F,1);
|
||
BlockRead(F,Header,4);
|
||
BlockRead(F,Xs,2);
|
||
BlockRead(F,YS,2);
|
||
BlockRead(F,Info,2);
|
||
AllocImage(Xs,Ys,Ima);
|
||
For Xs:=0 to $Ff do
|
||
With Ima do
|
||
BlockRead(F,Palette[Xs],3);
|
||
BlockRead(f,Ima.Picture^,ima.Size);
|
||
Close(F);
|
||
End;
|
||
|
||
Procedure Comprs(Var Pic : Pointer; Var Taille : Word);
|
||
Function scan( X : Word;
|
||
C : Byte) : Byte;
|
||
Var
|
||
I : Word;
|
||
Ct : Byte;
|
||
Begin
|
||
I := X;
|
||
Ct := 0;
|
||
While (Mem[WriteS:I] = C) AND (I<64000) AND (Ct<$FF) DO
|
||
Begin
|
||
Inc(Ct);
|
||
Inc(I);
|
||
End;
|
||
Scan := Ct-1;
|
||
End;
|
||
|
||
Var
|
||
I : Word;
|
||
R : Word;
|
||
P : Byte;
|
||
Sc : Byte;
|
||
Ts : Pointer;
|
||
Begin
|
||
getMem(Ts,64000);
|
||
I := 0;
|
||
R := 0;
|
||
Repeat
|
||
P := Scan(I,Mem[WriteS:I]);
|
||
If P > 1 Then
|
||
Begin
|
||
MemL[seg(Ts^):Ofs(Ts^)+R ] := MagicLong;
|
||
Mem[seg(Ts^):Ofs(Ts^)+R+4] := P; { Nombre de repetitions }
|
||
Mem[seg(Ts^):Ofs(Ts^)+R+5] := Mem[WriteS:I]; { Byte a r<>p<EFBFBD>ter }
|
||
Inc(R,6);
|
||
Inc(I,P+1);
|
||
For Sc := I to I+p+1 do
|
||
Mem[WriteS:I] := 0;
|
||
End
|
||
Else
|
||
Begin
|
||
Mem[Seg(Ts^):Ofs(Ts^)+R] := Mem[WriteS:I];
|
||
inc(R);
|
||
Inc(I);
|
||
End;
|
||
Until I>64000;
|
||
Taille := R;
|
||
GetMem(Pic,Taille);
|
||
Move(Ts^,Pic^,Taille);
|
||
FreeMem(Ts,64000);
|
||
End;
|
||
|
||
Procedure UnComprs(Pic : Pointer; ToP : Pointer);
|
||
Var
|
||
I,R : Word;
|
||
C : Byte;
|
||
Begin
|
||
I := 0;
|
||
R := Ofs(Pic^);
|
||
Repeat
|
||
If MemL[seg(Pic^):R ] = MagicLong Then
|
||
Begin
|
||
For C:= 0 to Mem[seg(Pic^):R+4] do
|
||
Begin
|
||
Mem[Seg(Top^):I] := Mem[seg(Pic^):R+5];
|
||
Inc(i);
|
||
End;
|
||
Inc(R,6);
|
||
End
|
||
Else
|
||
Begin
|
||
Mem[Seg(Top^):I] := Mem[Seg(Pic^):R];
|
||
inc(R);
|
||
Inc(I);
|
||
End;
|
||
Until I>64000;
|
||
End;
|
||
|
||
End. |