modiromppu/modiromppu.iso/PROGRAMS/ORGPACKS/SNGPLY10.ZIP/PLAYMUS.PAS

Pascal/Delphi Source File | 1997-01-01 | 5KB | 271 lines

{$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M 16384,0,655360}

Program PlayMusic;   {By Bugsy of OBSESSION 1994 FREEWARE}

Uses
  Crt;

Type
  TSongBuf   = Array [1..$FFFF] Of Byte;

  THeaderRec = Record
    IDWord1    ,
    IDWord2    ,
    SongLength ,
    SongStart  ,
    SongLoop   : Word;
    DelayStart : Byte;
    Compressed : Boolean;
  End;

Var
  DelayCt    : Byte;
  SongSeg    ,
  NodePos    : Word;
  SongPtr    : ^TSongBuf;
  HeaderRec  : THeaderRec;


Procedure OutAdlib; Assembler;
ASM
  Push    ax
  Push    dx
  Mov     dx, 388h
  Xchg    al, ah
  Out     dx, al
  Inc     dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  Mov     al, ah
  Out     dx, al
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  In      al, dx
  Pop     dx
  Pop     ax
End;

Procedure InitAdlib; Assembler;
Asm
  Mov     cx, 0F0h
  Mov     ax, 1000h
@Loop_1:
  Call    OutAdlib
  Inc     ah
  Loop    @Loop_1

  Mov     cx, 20h
  Mov     ax, 403Fh
@Loop_2:
  Call    OutAdlib
  Inc     ah
  Loop    @Loop_2

  Mov     cx, 0A0h
  Mov     ax, 6000h
@Loop_3:
  Call    OutAdlib
  Inc     ah
  Loop    @Loop_3

  Mov     ax, 120h
  Call    OutAdlib

  Mov     ax, 0800h
  Call    OutAdlib

  Mov     ax, 0BD00h
  Call    OutAdlib

  Mov     cx, 9
  Xor     di, di
@Loop_4:
  Push    cx
  Xor     ax, ax
  Mov     bx, di
  Mov     bh, ah
  Mov     ah, 0A0h
  Add     ah, bl
  Call    OutAdlib

  Mov     al, bh
  Add     ah, 10h
  Call    OutAdlib

  Inc     di
  Pop     cx
  Loop    @Loop_4
End;

Procedure PlayNote; Assembler;
Asm
  Push    ax
  Push    bx
  Push    ES
  Mov     ax, SongSeg
  Mov     ES, ax

  Cmp     HeaderRec.Compressed, True
  Jne      @NotCompressed

  Dec     DelayCt
  Cmp     DelayCt, 0
  Jne     @DelayNOTDone

@NotCompressed:
  Mov     bx, NodePos

@NextCommand:
  Mov     ax, ES:[bx]
  Add     bx, 2

  Cmp     bx, HeaderRec.SongLength
  Jb      @SongNOTDone

  Mov     bx, HeaderRec.SongLoop
  Jmp     @NextCommand

@SongNOTDone:

  Cmp     ah, 0
  Je      @RowDone

  Call    OutAdlib
  Jmp     @NextCommand

@RowDone:
  Mov     DelayCt, al
  Mov     NodePos, bx

@DelayNOTDone:
  Pop     ES
  Pop     bx
  Pop     ax
End;


Procedure WaitRetrace; Assembler;
Asm
  Mov     dx, 3DAh
@NoRetrace:
  In      al, dx
  Test    al, 8
  Jz      @NoRetrace

@Retrace:
  In      al, dx
  test    al, 8
  jnz     @Retrace
End;

Procedure PlaySongPas;
Var
  Ct : Word;

Begin
  Repeat
    PlayNote;
    WaitRetrace;
    GotoXY (1, WhereY-1);
    WriteLn ('Music pos : ',NodePos,'   ');
  Until Port[$60] = 1;     {ESC}
  Readkey;
End;

Procedure Error (Err : Byte);
Begin
  Write ('ERROR (',Err,') : ');
  Case Err Of
    1 : WriteLn ('USAGE Playmus filename.ext');
    2 : WriteLn ('File not found');
    3 : WriteLn ('Can''t read from file');
    4 : WriteLn ('Unknown file format');
    5 : WriteLn ('Not enough memory');
  Else
    WriteLn ('Unknown, programmer is a jerk !');
  End;
  Halt (Err);
End;

Procedure LoadSong;
Var
  ReadCt     : Word;
  InFile     : File;
  HeaderFile : File Of THeaderRec;

Begin
  If ParamCount <> 1 Then Error (1);
  Assign (HeaderFile, ParamStr(1));
  {$I-}
  Reset(HeaderFile);
  If IOResult <> 0 Then Error(2);
  Read(HeaderFile, HeaderRec);
  If IOResult <> 0 Then Error(3);
  Close(HeaderFile);

  New (SongPtr);
  If SongPtr = Nil Then Error(5);
  SongSeg := Seg (SongPtr^);

  Assign (InFile, ParamStr(1));
  Reset (InFile,1);
  BlockRead (InFile,SongPtr^,$FFFF, ReadCt);
  If IOResult <> 0 Then Error(3);
  Close (InFile);
  {$I+}

  With HeaderRec Do Begin
    If (IDWord1 <> $624F) OR (IDWord2 <> $4D73) Then Error (4);
    NodePos := SongStart + Sizeof(THeaderRec);
    DelayCt := DelayStart;
  End;
  Write ('Type      : ');
  If HeaderRec.Compressed Then WriteLn ('Compressed')
  Else WriteLn ('Uncompressed');
  WriteLn;
End;

Begin
  WriteLn;
  WriteLn ('Music player v 1.0 by BUGSY of OBSESSION  FREEWARE 1994');
  WriteLn;

  LoadSong;
  InitAdlib;
  PlaySongPas;
  InitAdlib;
End.