{C:\PROGRA~2\BP70\BIN\beryoz_.mzc}
{Убрать следующие неисправности и дополнить:
1. Ошибка "Недействительная операция с указателем" в режиме работы
со списком файлов
3. Сократить формат MZP, сохраняя в файле не 4, а 3 байта двойного слова
длительности звучания(отдельная программа для перекодировки)
4. Сделать Asm - процедеру проигрывания музыки(с прерыванием 1Ch)
> 5. Добавить "производство" COM - файлов с музыкой
6. Отдельные программы - производство MZP - файлов на импорте
из WAV, MID - файлов и программ, выводящих звук через динамик.
}
Program MyMusic;
{$G+,D-}
Uses MusicShu, DOS, ProgFace;
{+|+|+|+|+|+|+|+|+|+|+|+|+|+|+|+}
{ $L C:\PROGRA~2\BP70\FONTS\AXEFONT.OBJ}
{$L C:\D_TEMPOS\ASM\MUSUNIT.OBJ}
{$L C:\D_TEMPOS\ASM\MUSUNIT_.OBJ}
{$M 65520, 0, 655360}
{Procedure Font; External;}
Procedure COMFile; External;
Procedure COMFile_; External;
type
FName = String[12];
var
i : Word;
ip : LongInt;
Stn : String;
DirInfo: SearchRec;
DirLineAttr, CurLineAttr : Byte;
PFNm : ^FName;
P : Pointer;
NameAddr : Longint absolute PFNm;
BaseAddr : Longint absolute P;
NFiles : Longint;
var
OldExit : Pointer;
const
N = 89;
flag : Word = 0;
{[][][][][][][][][][][][][][][]}
Function GetFile(SFMask : String):String;NEAR;
var
i, k : Longint;
C : Char;
Sr : String;
Label Again;
Procedure FileList(j : Longint);
var
i1 : LongInt;
begin
ZZCursor;
NewLine;
i1 := j;
While (yt <= Window.Yr) do
begin
NameAddr := BaseAddr + (i1-1)*SizeOf(FName);
if ((i1-1)<=NFiles) then
WriteLine(' '+PFNm^+' ', WinAttr)
else
WriteLine(' ', WinAttr);
NewLine;
inc(i1);
end;
end;
begin
SaveBar(20, 1, 60, 25);
Again:
SetWindChar(' ');
SetAttr(LightGray,Blue,WinAttr);
SetAttr(Yellow,Green,DirLineAttr);
SetAttr(DarkGray,Cyan,CurLineAttr);
SetAttr(LightRed,Blue,WBorderAttr);
SetAttr(LightGreen,Blue,WinHAttr);
SetWindow(20, 1, 60, 25, 2, '---=== Выберите файл в списке: ===---', True);
NFiles := 0;
SetAttr(Green,Red,MnAttrK);
SetAttr(Green,Red,MnAttrM);
ZZCursor;
WriteLine(' '+FExpand('.')+' ', DirLineAttr);
NewLine;
FindFirst(SFMask, ReadOnly+Hidden+Archive, DirInfo);
while DosError = 0 do
begin
inc(NFiles);
FindNext(DirInfo);
end;
FindFirst('*', Directory, DirInfo);
while DosError = 0 do
begin
inc(NFiles);
FindNext(DirInfo);
end;
Sr := '';
GetMem(P, NFiles*SizeOf(FName));
PFNm := P;
for i := 1 to NFiles do
begin
NameAddr := NameAddr + SizeOf(FName);
PFNm^ := ' ';
PFNm^[0] := #12;
end;
PFNm := P;
FindFirst(SFMask, ReadOnly+Hidden+Archive, DirInfo);
while DosError = 0 do
begin
PFNm^ := Dirinfo.Name;
NameAddr := NameAddr + SizeOf(FName);
FindNext(DirInfo);
end;
FindFirst('*', Directory, DirInfo);
while DosError = 0 do
begin
PFNm^ := Dirinfo.Name;
NameAddr := NameAddr + SizeOf(FName);
FindNext(DirInfo);
end;
i := ip;
with Window do
FileList(( ((i-1)- ((i-1) mod 22) + 1) div 22)*22+1);
NameAddr := BaseAddr + (i-1)*SizeOf(FName);
ZZCursor;
NewLine;
with Window do
for k := 1 to ((i-1) mod (Yr-Y0) ) do
NewLine;
NameAddr := BaseAddr + (i-1)*SizeOf(FName);
WriteLine(PFNm^+' ' , CurLineAttr);
i := ip;
Repeat
C:=ReadKey;
case C of
#0:
begin
C := ReadKey;
case C of
#72:
begin
if i > 1 then dec(i);
end;
#80:
begin
if i < NFiles then inc(i);
end;
#75:
begin
i := 1;
end;
#77:
begin
i := NFiles;
end;
end;
end;
#27:
begin
Sr := '';
Break;
end;
#13:
begin
Sr := PFNm^;
Break;
end;
end;
with Window do
FileList(( ((i-1)- ((i-1) mod 22) + 1) div 22)*22+1);
ZZCursor;
NewLine;
with Window do
for k := 1 to ((i-1) mod (Yr-Y0) ) do
NewLine;
NameAddr := BaseAddr + (i-1)*SizeOf(FName);
WriteLine(PFNm^+' ' , CurLineAttr);
until (C=#27) or (C=#13);
if P <> NIL then
begin
FreeMem(P, NFiles*SizeOf(FName));
P := NIL;
end;
FindFirst(Sr, AnyFile, DirInfo);
if Sr <> '' then
if DirInfo.Attr=Directory then
begin
ip := 1;
ChDir(FExpand(Sr));
goto Again;
end;
ip := i;
GetFile := Sr;
UndoMenu;
end;
{Procedure SetFont;Assembler;
Asm
push bp
mov ax,seg Font
mov es,ax
mov bp,offset Font
mov bx,1000h
xor dx,dx
mov cx,256
mov ax,1100h
int 10h
pop bp
mov ah,1
mov cx,1000h
int 10h
end;
}
const
OldInt1Ch : Pointer = NIL;
MA : Pointer = NIL;
MemAvbl : Longint = 0;
Procedure SetInt1Ch; Assembler;
asm
push es
mov ax, 351Ch
int 21h
mov word ptr OldInt1Ch, bx
mov word ptr OldInt1Ch+2, es
mov word ptr @OI1Ch, bx
mov word ptr @OI1Ch+2, es
pop es
mov ax, 251Ch
push ds
mov dx, seg @int1Ch
mov ds, dx
mov dx, offset @int1Ch
int 21h
pop ds
ret
@int1Ch:
pushf
{ pusha
push ds
push ax}
mov word ptr flag, 1
{ pop ax
pop ds
popa}
popf
db 02Eh, 0EAh {cs:jmp 00000000}
@OI1Ch :
dd 0
{ iret}
end;
Procedure RestoreInt1Ch; Assembler;
asm
push ds
lds dx, OldInt1Ch
mov ax, 251Ch
int 21h
pop ds
end;
Procedure WaitRetrace;Assembler;
asm
mov dx, 03DAh
@VRTL1:
in al, dx
test al, 8
jnz @VRTL1
@VRTL2:
in al, dx
test al, 8
jne @VRTL2
end;
Procedure MakeCOM(fnm : String);
var
f : file;
P : Pointer;
i : Word;
Tmp : Word;
const
Size = 139-2;
Size_ = 142-2;
begin
P := @COMFile;
P := @COMFile_;
Assign(f, fnm);
Rewrite(f, 1);
BlockWrite(f, P^, Size_);
Tmp := MusicPhrase.Leng;
BlockWrite(f, Tmp, 2);
for i := MusicPhrase.Leng downto 1 do
begin
Tmp := Round(MusicPhrase.MusicNotes[i].ling/55);{Time}
BlockWrite(f, Tmp, 2);
Tmp := MusicPhrase.MusicNotes[i].freq;
BlockWrite(f, Tmp, 2);
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;
Procedure ErrorExit;FAR;
var
S : String;
begin
ExitProc := OldExit;
SaveBar(27, 8, 53, 16);
SetWindChar(' ');
SetAttr(LightRed,Red,WinAttr);
SetAttr(LightRed,Red,WBorderAttr);
SetAttr(Yellow,Red,WinHAttr);
SetWindow(27, 8, 53, 16, 2, ' -= Ошибка !!! =- ', True);
ZZCursor;
Str(ExitCode, S);
WriteLine(' Внимание! Произошла ошибка', WinAttr);
NewLine;
WriteLine(' Ошибка '+S, WinAttr);
While KeyPressed do ReadKey;
ReadKey;
CursorOn;
if P <> NIL then
FreeMem(P, NFiles*SizeOf(FName));
RestoreScreen;
asm
mov ax, 83h
int 10h
end;
Halt(ExitCode);
end;
{[][][][][][][][][][][][[][][][][]}
var
FMask : String;
Encode : Boolean;
COM : Boolean;
isParam : Boolean;
Heap : String;
begin
OldExit := ExitProc;
ExitProc := @ErrorExit;
Encode := False;
COM := False;
CursorOff;
{ WaitRetrace;
SetFont;}
isParam := (ParamCount<>0);
if not isParam then
begin
SaveBar(10, 8, 70, 16);
SetWindChar(' ');
SetAttr(Yellow,Blue,WinAttr);
SetAttr(Blue,Green,WBorderAttr);
SetAttr(Green,Red,WinHAttr);
SetWindow(10, 8, 70, 16, 1, 'Выбор типа файла', True);
ZZCursor;
WriteLine(' Сделайте выбор:', WinAttr);
NewLine;
WriteLine(' "1" - *.mzc', WinAttr);
NewLine;
WriteLine(' "2" - *.mzp', WinAttr);
NewLine;
WriteLine(' "0" - *.mz?', WinAttr);
NewLine;
WriteLine(' "~" ("`") - Перекодировка *.mzc <=> *.mzp', WinAttr);
NewLine;
WriteLine(' "|"(\) Создание COM - файла', WinAttr);
FMask := '';
Repeat
case ReadKey of
'0' : FMask := '*.MZ?';
'1' : FMask := '*.MZC';
'2' : FMask := '*.MZP';
'`', '~' :
begin
Encode := True;
FMask := '*.MZ?';
end;
'|', '\' :
begin
COM := True;
Encode := True;
FMask := '*.MZ?';
end;
#27 : FMask := ' ';
end
Until FMask <> '';
UndoMenu;
end
else FMask := '*'+UpString(Copy(ParamStr(1), Pos('.', ParamStr(1)), 4));
ip := 1;
if UpString(ParamStr(2))='/ENCODE' then Encode := True;
if UpString(ParamStr(2))='/COM' then
begin
Encode := True;
COM := True;
end;
Repeat
if (FMask = ' ') or (Length(FMask)<>5) then Break;
if not isParam then
Stn := GetFile(FMask)
else
Stn := UpString(ParamStr(1));
NewLine;
LingNota := 3000;
MusicPhrase.Leng := 0;
MusicPhrase.Leng := 0;
if Stn<>''
then
begin
SaveBar(20, 1, 60, 25);
SetWindChar(' ');
SetAttr(DarkGray,Green,WinAttr);
SetAttr(Green,LightGray,WBorderAttr);
SetAttr(LightRed+Blink,Blue,WinHAttr);
SetWindow(25, 5, 55, 8, 2, '-= Гружу файл '+Stn+'... =-', False);
ZZCursor;
NewLine;
if Copy(Stn, Pos('.', Stn)+1, 3) = 'MZC' then
LoadCodeMusicPhrase(MusicPhrase, Stn);
if Copy(Stn, Pos('.', Stn)+1, 3) = 'MZP' then
LoadMusicPhrase(MusicPhrase, Stn);
UndoMenu;
end
else Break;
SaveBar(10, 5, 70, 7);
SetWindChar(' ');
SetAttr(LightRed,Blue,WinAttr);
SetAttr(LightBlue,Red,WBorderAttr);
SetAttr(Green+Blink,Red,WinHAttr);
WaitRetrace;
SetWindow(10, 5, 70, 7, 1, '[ Играю Мелодию... ]', True);
ZZCursor;
WriteLine(' '+MusicName, WinAttr);
if not Encode then
PlayMusic(MusicPhrase)
else
if COM then
MakeCOM(Copy(Stn, 1, Pos('.', Stn)-1)+'.COM')
else
begin
if Copy(Stn, Pos('.', Stn)+1, 3) = 'MZC' then
SaveMusicPhrase(MusicPhrase, Copy(Stn, 1, Pos('.', Stn)-1)+'.MZP');
if Copy(Stn, Pos('.', Stn)+1, 3) = 'MZP' then
MusicCode2StrFile(MusicPhrase, Stn);
end;
UndoMenu;
UndoMenu;
if isParam then Break;
Until KeyPressed;
CursorOn;
RestoreScreen;
ExitProc := OldExit;
asm
mov ax, 83h
int 10h
end;
end.
< -->