Intermedia 1998 January/inter1_98.iso/www/rozi/FLI_2.ZIP/FLIUNIT.PAS

Pascal/Delphi Source File | 1996-03-23 | 5KB | 370 lines

{$a+,b-,d-,e-,f-,g+,i+,l+,n-,o-,r-,s+,v+,x-}
{$m  1024,0,655360}
unit fliunit;
interface
uses dos,crt;
type         {16384,0,655360}
fliheader= record
size      :longint;
htype     :word;
framecount:word;
width     :word;
height    :word;
bitsperpixel:word;
flags     :integer;
speed     :integer;
nexthead  :longint;
framesintable:longint;
hfile:integer;
hframe1offset:longint;
strokes:longint;
session:longint;
reserved:array[1..88] of byte;
end;
frameheader=record
size:longint;
ftype:word;
chunks:word;
expand:array[1..8] of byte;
end;
chunkheader=record
size:longint;
id:word;
end;
buffer=array[1..65535] of byte;

rgb=record
r,g,b:byte;
end;
paltype=array[0..255] of rgb;
var
buf:^buffer;
pal:^paltype;
h:fliheader;
fh:frameheader;
ch:chunkheader;
i,j:word;
speed:word;
f:file;
fname:string;
firstframe:longint;
function setgraphmode:word;
procedure settextmode;
procedure waitforscreen;
procedure waiting;
procedure decodefli_color;
procedure decodefli_black;
procedure decodefli_brun;
procedure decodefli_lc;
procedure decodefli_copy;
procedure fli_play(fname:string);

implementation
function setgraphmode:word;assembler;
asm
mov ax,0013h
int 10h
mov ah,0fh
int 10h
xor ah,ah
end;
procedure settextmode;assembler;
asm
mov ax,0003h
int 10h;
end;

procedure waitforscreen;assembler;
asm
mov dx,3dah
@wait1:
in al,dx
test al,8
jnz @wait1
@wait2:
in al,dx
test al,8
jz @wait2
end;

procedure waiting;assembler;
asm
mov cx,speed
jcxz @end
dec cx
@wait:
call waitforscreen
loop @wait
@end:
end;

procedure decodefli_color;assembler;

asm
les ax,pal
mov bx,es
mov dx,ax
and ax,15
mov di,ax
shr dx,4
add bx,dx
push ds
lds ax,buf
mov bx,ds
mov dx,ax
and ax,15
mov si,ax
shr dx,4
add bx,dx
mov ds,bx
cld
lodsw
mov bx,ax
test bx,bx
jmp @endu
@u:
lodsb
add di,ax
add di,ax
add di,ax
lodsb
or al,al
jnz @u2
mov ax,256
@u2:
mov cx,ax
add cx,ax
add cx,ax
rep movsb
dec bx
@endu:
jnz @u
sub di,768
mov si,di
push es
pop ds
mov cx,256
mov bl,0
@setpal:
mov dx,3c8h
mov al,bl
out dx,al
inc dx
lodsb
out dx,al
lodsb
out dx,al
lodsb
out dx,al
inc bl
loop @setpal
pop ds
end;

procedure decodefli_black; assembler;

asm
mov cx,32000
mov ax,0a000h
mov es,ax
xor ax,ax
mov di,ax
rep stosw
call waiting
end;

procedure decodefli_brun;assembler;
var
linecount:word;

asm
call waitforscreen
mov linecount,200
mov ax,0a000h
mov es,ax
xor di,di
push ds
lds ax,buf
mov bx,ds
mov dx,ax
and ax,15
mov si,ax
shr dx,4
add bx,dx
mov ds,bx
cld
mov dx,di
xor ah,ah
@linelp:
mov di,dx
lodsb
mov bl,al
test bl,bl
jmp @endulcloop
@ulcloop:
lodsb
test al,al
js @ucopy
mov cx,ax
lodsb
rep stosb
dec bl
jnz @ulcloop
jmp @ulcout
@ucopy:
neg al
mov cx,ax
rep movsb
dec bl
@endulcloop:
jnz @ulcloop
@ulcout:
add dx,320
dec linecount
jnz @linelp
pop ds
call waiting
end;


procedure decodefli_lc;assembler;

var
linecount:word;

asm
call waitforscreen
mov ax,0a000h
mov es,ax
xor di,di
push ds
lds ax,buf
mov bx,ds
mov dx,ax
and ax,15
mov si,ax
shr dx,4
add bx,dx
mov ds,bx
cld
lodsw
mov dx,320
mul dx
add di,ax
lodsw
mov linecount,ax
mov dx,di
xor ah,ah
@linelp:
mov di,dx
lodsb
mov bl,al
test bl,bl
jmp @endulcloop
@ulcloop:
lodsb
add di,ax
lodsb
test al,al
js @ulcrun
mov cx,ax
rep movsb
dec bl
jnz @ulcloop
jmp @ulcout
@ulcrun:
neg al
mov cx,ax
lodsb
rep stosb
dec bl
@endulcloop:
jnz @ulcloop
@ulcout:
add dx,320
dec linecount
jnz @linelp
pop ds
call waiting
end;

procedure decodefli_copy;assembler;

asm
call waitforscreen
mov ax,0a000h
mov es,ax
xor di,di
push ds
lds ax,buf
mov bx,ds
mov dx,ax
and ax,15
mov si,ax
shr dx,4
add bx,dx
mov ds,bx
mov cx,32000
rep movsw
pop ds
call waiting
end;

procedure fli_play(fname:string);
begin
assign(f,fname);
{$i-} reset(f,1); {$i+}
if ioresult<>0 then begin
writeln('brak');
halt(2);
end;
{$i-} blockread(f,h,sizeof(h)); {$i+}
if ioresult<>0 then begin
writeln('blad');
halt(3);
end;
if h.htype<>$af11 then begin
writeln('fli');
close(f);
halt(4);
end;
if setgraphmode<>$13 then begin
writeln('vga');
halt(5);
end;
new(buf);new(pal);
speed:=h.speed;
firstframe:=filepos(f);
while 1=1 do begin
for i:=1 to h.framecount do begin
{$i-} blockread(f,fh,sizeof(fh)); {$i+}
if fh.ftype<>$f1fa then begin
writeln('klatka'); close(F); halt(4);
end;
if fh.chunks>0 then
for j:=1 to fh.chunks do begin
{$i-} blockread(f,ch,sizeof(ch)); {$i+}
{$i-} blockread(f,buf^,ch.size-sizeof(ch)); {$i+}

case ch.id of
11:decodefli_color;
12:decodefli_lc;
13:decodefli_black;
15:decodefli_brun;
16:decodefli_copy;
end;
end else waiting;
if port[$60]=1 then begin
close(f);
dispose(pal); dispose(buf);
settextmode;
halt(0);
end;
end;
delay(7500);
settextmode;
exit;
seek(f,firstframe);
end;
end;
end.