Program FileOut;
{$L C:\PROGRA~2\BP70\BIN\EGAVGA.OBJ}
{$G+,N+,E-,D-}
Uses Graph, CRT;
{H:\MUSIC\ВАГНЕР~1.WAV /2w}
{E:\KARAOKE\GIRL-B~1.WAV /2w}
Procedure EGAVGA; External;
const
Nw = 28672;
Nb = 57344;
Nnw = Nw - 1;
Nnb = Nb - 1;
Zw : Single = 240/32768;
Zb : Single = 240/256;
Tau = 1550;
var
Tbw : array [0..Nnw] of Integer;
Tbb : array [0..Nnb] of ShortInt absolute Tbw;
D, R, e : Integer;
i : LongInt;
y, x : Integer;
k : Word;
P : Pointer;
f : file;
FSZ : Longint;
Col : Byte;
Procedure InitMouse; Assembler;
asm
mov ax, 0
int 33h
end;
Procedure ShowMouse; Assembler;
asm
mov ax, 1
int 33h
end;
Procedure HideMouse; Assembler;
asm
mov ax, 2
int 33h
end;
Function MouseButt : Word; Assembler;
asm
mov ax, 3
int 33h
mov ax, bx
end;
Function MouseX : Word; Assembler;
asm
mov ax, 3
int 33h
mov ax, cx
end;
Function MouseY : Word; Assembler;
asm
mov ax, 3
int 33h
mov ax, dx
end;
Procedure PutPixel; Assembler;
asm
mov al, 8
mov dx, 03CEh
out dx, al
inc dx
mov cx, word ptr x
xor al, al
and cx, 0Fh
inc al
inc cl
ror al, cl
out dx, al
push ds
mov ax, word ptr y
mov bx, ax
shl bx, 2
add bx, ax
shl bx, 4
mov ax, word ptr x
shr ax, 3
add bx, ax
mov cl, Col
mov ax, 0A000h
mov ds, ax
mov byte ptr [bx], cl {Поместили точку}
pop ds
end;
{Теперь смещаем экран вправо}
Procedure Scroll; Assembler;
asm
{ ret}
push ds
push es
mov ax, 0A000h
mov ds, ax
mov es, ax
mov cx, 480
std
@newline:
push cx
mov ax, cx
dec ax
mov si, ax
shl ax, 2
add si, ax
shl si, 4
mov di, si
add di, 1
mov cx, 80 (*640/8*)
rep movsb
pop cx
loop @newline
pop es
pop ds
end;
Procedure TwoChannelsWord;
begin
Assign(f, ParamStr(1));
Reset(f, 2);
FSZ := FileSize(f);
Seek(f, 0);
FSZ := (FSZ and $FFFFFFFE) shr 1;
for i := 1 to FSZ div Nw do
begin
BlockRead(f, Tbw, Nw);
k := 0;
While k <= Nw do
begin
Col := LightRed;
y := 240+Round(Zw*Tbw[k]);
PutPixel;
asm inc word ptr k end;
Col := LightGreen;
y := 240+Round(Zw*Tbw[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
push ds
mov ax, 0A000h
mov ds, ax
xor ax, ax
mov cx, 480*40
mov di, 0
cld
rep stosw
pop ds
@nka:
end;
if keyPressed then Break;
end;
end;
BlockRead(f, Tbw, FSZ mod Nw);
k := 0;
While k <= FSZ mod Nw do
begin
Col := LightRed;
y := 240+Round(Zw*Tbw[k]);
PutPixel;
asm inc word ptr k end;
Col := LightGreen;
y := 240+Round(Zw*Tbw[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
Close(f);
end;
Procedure TwoChannelsByte;
begin
Assign(f, ParamStr(1));
Reset(f, 1);
FSZ := FileSize(f);
Seek(f, 0);
FSZ := (FSZ and $FFFFFFFE);
for i := 1 to FSZ div Nb do
begin
BlockRead(f, Tbb, Nb);
k := 0;
While k <= Nb do
begin
Col := LightBlue;
y := 240+Round(Zb*Tbb[k]);
PutPixel;
asm inc word ptr k end;
Col := LightMagenta;
y := 240+Round(Zb*Tbb[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
end;
BlockRead(f, Tbb, FSZ mod Nb);
k := 0;
While k <= FSZ mod Nb do
begin
Col := LightBlue;
y := 240+Round(Zb*Tbb[k]);
PutPixel;
asm inc word ptr k end;
Col := LightMagenta;
y := 240+Round(Zb*Tbb[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
Close(f);
end;
Procedure OneChannelWord;
begin
Assign(f, ParamStr(1));
Reset(f, 2);
FSZ := FileSize(f);
Seek(f, 0);
FSZ := (FSZ and $FFFFFFFE) shr 1;
Col := Yellow;
for i := 1 to FSZ div Nw do
begin
BlockRead(f, Tbw, Nw);
k := 0;
While k <= Nw do
begin
y := 240+Round(Zw*Tbw[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
end;
BlockRead(f, Tbw, FSZ mod Nw);
k := 0;
While k <= FSZ mod Nw do
begin
y := 240+Round(Zw*Tbw[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
Close(f);
end;
Procedure OneChannelByte;
begin
Assign(f, ParamStr(1));
Reset(f, 1);
FSZ := FileSize(f);
Seek(f, 0);
FSZ := (FSZ and $FFFFFFFE);
Col := LightGray;
for i := 1 to FSZ div Nb do
begin
BlockRead(f, Tbb, Nb);
k := 0;
While k <= Nb do
begin
y := 240+Round(Zb*Tbb[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
end;
BlockRead(f, Tbb, FSZ mod Nb);
k := 0;
While k <= FSZ mod Nb do
begin
y := 240+Round(Zb*Tbb[k]);
PutPixel;
asm inc word ptr k end;
asm inc word ptr x end;
asm
cmp word ptr x, 640
jne @nka
xor ax, ax
mov word ptr x, ax
@nka:
end;
if keyPressed then Break;
end;
Close(f);
end;
Function UpString(S:String):String;
var
i : Integer;
S1 : String;
begin
S1 := S;
for i := 1 to Length(S1) do
S1[i] := UpCase(S1[i]);
UpString := S1;
end;
begin
if ParamCount = 0 then Halt($FFFF);
P := @EGAVGA;
D := Detect;
if RegisterBGIdriver(P) < 0 then
begin
Writeln('Ошибка регистрации драйвера: ',
GraphErrorMsg(GraphResult));
Halt(1);
end;
InitGraph(D, R, '');
e := GraphResult;
if e <> grOk then
begin
WriteLn('Произошла ошибка графики!!!');
WriteLn(GraphErrorMsg(e));
end;
asm
mov al, 5
mov dx, 03CEh
out dx, al
inc dx
mov al, 2
out dx, al
end;
Col := Blue;
ReadKey;
x := 1;
InitMouse;
if ParamCount<2 then OneChannelByte;
if UpString(ParamStr(2))='/1B' then OneChannelByte;
if UpString(ParamStr(2))='/2W' then TwoChannelsWord;
if UpString(ParamStr(2))='/1W' then OneChannelWord;
if UpString(ParamStr(2))='/2B' then TwoChannelsByte;
asm
mov al, 5
mov dx, 03CEh
out dx, al
inc dx
mov al, 1
out dx, al
{ push ds
mov ax, 0A000h
mov ds, ax
mov cx, 80
xor ax, ax
xor di, di
cld
rep stosb
pop ds}
end;
While MouseButt = 0 do
Scroll;
While MouseButt <> 0 do;
{ While KeyPressed do ReadKey;
ReadKey;}
CloseGraph;
end.
< -->