{$A-,B-,E-,F-,G+,I-,N-,O-,R-,S-,V-,X+}
Unit Songs;

Interface

Uses
  Memory, Objects;

type
  TPattern = array[0..1023] of Byte;
  PPattern = ^TPattern;

type
   TSTMHeader = record
     SongName: array[0..19] of Char;
     EdName: array[0..7]  of Char;
     EOF: Byte;
     FileType: Byte;
     Version: Word;
     Temp: Byte;
     NumPatterns: Byte;
     GlobalVolume: Byte;
     VoiceRepart: Byte;
     Reserved: array[0..11] of Char;
   end;

   TSTMInstr = record
     Name: array[0..11] of Char;
     Unused1: Word;
     SampleSeg: Word;
     Length: Word;
     LoopStart: Word;
     LoopEnd: Word;
     DefVolume: Byte;
     Unused2: Byte;
     SpeedOfC: Word;
     Unused3: Longint;
     Unused4: Word;
    end;

type
   TCDMHeader = record
     SongName: array[0..19] of Char;
     EdName: array[0..7]  of Char;
     EOF: Byte;
     FileType: Byte;
     Temp: Byte;
     GlobalVolume: Byte;
     CompMethod: Byte;
     NumPatterns: Byte;
     NumSamples: Byte;
     VoiceRepart: Byte;
     Reserved1: Byte;
     Reserved2: Word;
     AddInfoSize: Word;
    end;

   TCDMInstr = record
     Name: array[0..11] of Char;
     Unused1: array[0..3] of Byte;
     SampleNo: Byte;
     UncompLength: Word;
     LoopStart: Word;
     LoopEnd: Word;
     DefVolume: Byte;
     SpeedOfC: Word;
     CompLength: Word;
     SampleOfs: LongInt;
    end;

type
  TMODInstr = record
    Name: array[0..21] of Char;
    Length: Word;
    FineTune: Byte;
    DefVolume: Byte;
    LoopStart: Word;
    LoopEnd: Word;
  end;

  TMODHeader = record
    SongName: array[0..19] of Char;
    Instr: array[0..30] of TMODInstr;
    SongLength: Byte;
    Reserv: Byte;
    Orders: array[0..127] of Byte;
    Sign: array[0..3] of Char;
  end;

  TMOD2Header = record
    SongName: array[0..19] of Char;
    Instr: array[0..14] of TMODInstr;
    SongLength: Byte;
    Reserv: Byte;
    Orders: array[0..127] of Byte;
  end;

type
  TDriverHead = record
    Description: array [1..20] of char;
    Programmer: array [1..20] of char;
    DeviceFlags: Word;
    MemoryNeed: Word;
    Offset: Word;
    Functions: array [1..13] of Word;
   end;

type
   TInstr = record
     Sample: PByteArray;
     Size: Word;
     LoopS: Word;
     LoopE: Word;
     SpeedOfC: Word;
     DefVolume: Byte;
     Name: String[12];
   end;

type
  PSong = ^TSong;
  TSong = object(TObject)
    GVolume: Byte;
    NumPatt: Byte;
    RealTemp: Byte;
    Error: Byte;
    Name: String[20];
    Orders: array[0..127] of Byte;
    Patterns: array[0..127] of PPattern;
    Instrs: array[0..31] of TInstr;
    constructor Init(FName: FNameStr);
    function Read(var S: TStream): Integer; virtual;
    destructor Done; virtual;
  end;

type
  PSTMSong = ^TSTMSong;
  TSTMSong = object(TSong)
    function Read(var S: TStream): Integer; virtual;
  end;

type
  PMODSong = ^TMODSong;
  TMODSong = object(TSong)
    function Read(var S: TStream): Integer; virtual;
    procedure MODtoSTM(var Pattern: TPattern);
  end;

function OpenDriver(FName: FNameStr): Integer;
procedure LoadDriver(var S: TStream; ASize: Word);
procedure FreeDriver;
function OpenSong(FName: FNameStr): PSong;

const
   CDMHeader: TCDMHeader =
  (SongName: '                    ';
   EdName: 'CDM file';
   EOF: 26;
   FileType: 3;
   Temp: 0;
   GlobalVolume: 0;
   CompMethod: 0;
   NumPatterns: 0;
   NumSamples: 0;
   VoiceRepart: $1B;
   Reserved1: 0;
   Reserved2: 0;
   AddInfoSize: 0);

const
  STMHeader: TSTMHeader =
 (SongName: '                    ';
  EdName: 'STM file';
  EOF: 26;
  FileType: 2;
  Version: $1502;
  Temp: 0;
  NumPatterns: 0;
  GlobalVolume: 0;
  VoiceRepart: $1B;
  Reserved: 'XXXXXXXXXXXX');

const
  VoiceRepart   : array[0..3] of word = (0,4,8,12);
{°±²Û It contain offsets of channel data in patterns Û²±° ??? }

const
  DriverBody: Pointer = nil;

var
  DriverHead : TDriverHead;

(*°±²ÛÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛÛ²±°*)
(*°±²ÛÛ  Used values of Error are:  ÛÛ²±°*)
(*°±²ÛÛ                             ÛÛ²±°*)
(*°±²ÛÛ  0 - All right              ÛÛ²±°*)
(*°±²ÛÛ  1 - File not found         ÛÛ²±°*)
(*°±²ÛÛ  2 - Bad file format        ÛÛ²±°*)
(*°±²ÛÛ  3 - Not enough memory      ÛÛ²±°*)
(*°±²ÛÛ  4 - I/O error              ÛÛ²±°*)
(*°±²ÛÛ  5 - Can't write file       ÛÛ²±°*)
(*°±²ÛÛÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÛÛ²±°*)

implementation

function OpenDriver(FName: FNameStr): Integer;
var
  S: TDosStream;
begin
  S.Init(FName, stOpenRead);
  LoadDriver(S, S.GetSize);
  OpenDriver := S.Status;
  S.Done;
end;

procedure FreeDriver;
begin
  if DriverBody <> nil then
  begin
    Word(DriverBody) := 0;
    FreeMem(DriverBody, DriverHead.MemoryNeed);
    DriverBody := nil;
  end;
  FillChar(DriverHead, SizeOf(DriverHead), 0);
end;

procedure LoadDriver(var S: TStream; ASize: Word);
begin
  FreeDriver;
  S.Read(DriverHead, SizeOf(DriverHead));
  DriverBody := MemAllocSeg(DriverHead.MemoryNeed);
  S.Read(Ptr(Seg(DriverBody^), DriverHead.Offset)^, ASize-SizeOf(DriverHead));
end;

function ASCIIZtoStr(var Bufer; MaxLen: Word): String; assembler;
asm
        PUSH    DS
        LDS     SI,Bufer
        LES     DI,@Result
        MOV     CX,MaxLen
        MOV     BX,DI
        XOR     AX,AX
        INC     DI
@@1:
        LODSB
        OR      AL,AL
        JZ      @@Done
        STOSB
        INC     AH
        LOOP    @@1
@@Done: MOV     ES:[BX],AH
        POP     DS
end;

function OpenSong(FName: FNameStr): PSong;
var
  Song: PSong;
begin
  Song := New(PSTMSong, Init(FName));
  if Song^.Error <> 0 then
  begin
    Song^.Free;
    Song := New(PMODSong, Init(FName));
    if Song^.Error <> 0 then
    begin
      Song^.Free;
      Song := nil;
    end;
  end;
  OpenSong := Song
end;

constructor TSong.Init(FName: FNameStr);

  procedure CalcPeriod(var SpeedOfC: Word); assembler;
  asm
     LES    DI,SpeedOfC
     MOV    AX,ES:[DI]
     CMP    AX,1235h
     MOV    AX,0
     JBE    @@1
     MOV    DX,0012h
     MOV    AX,34DCh
     DIV    ES:[DI].Word
@@1: XCHG   AL,AH
     STOSW
  end;

var
  I: Integer;
  S: TDosStream;
begin
  TObject.Init;
  Name := '';
  GVolume := 64;
  RealTemp := $60;
  FillChar(Orders,SizeOf(Orders),99);
  for I := 0 to 31 do
  with Instrs[I] do
  begin
    LoopE := $FFFF;
    SpeedOfC := 8448;
    DefVolume := 64;
  end;
  S.Init(FName, stOpen);
  if S.Status <> stOk then Error := S.Status else
  begin
    Error := Read(S);
    if (Error = 0) and (S.Status <> stOk) then
      Error := S.Status;
  end;
  if Error = 0 then
  for I := 0 to 31 do CalcPeriod(Instrs[I].SpeedOfC);
  S.Done;
end;

function TSong.Read(var S: TStream): Integer;
begin
  Read := 0
end;

destructor TSong.Done;
var
  I: Integer;
begin
  for I := 0 to 31 do
  with Instrs[I] do
    if (Sample <> nil) then FreeMem(Sample, Size);
  for I := 0 to NumPatt-1 do
    if Patterns[I] <> nil then Dispose(Patterns[I]);
  TObject.Done
end;

{ ----------------------------------- TSTMSong ---------- }

function TSTMSong.Read(var S: TStream): Integer;
var
  H: TSTMHeader;
  Instr: TSTMInstr;
  InsSeg: array[0..31] of Word;
  I,J: Word;
begin
  Read := 0;
  FillChar(H, SizeOf(H), 0);
  S.Read(H, SizeOf(H));
  if S.Status <> stOk then exit;
  if H.FileType <> 2 then begin Read := 2; exit end;
  Name := ASCIIZToStr(H.SongName, 20);
  J := H.VoiceRepart;
  if J <> Byte('X') then
    for I := 0 to 3 do
    begin
      VoiceRepart[I xor 3] := (J and 3) shl 2;
      j := j shr 2;
    end;
  RealTemp := H.Temp;
  GVolume := H.GlobalVolume;
  NumPatt := H.NumPatterns;

  for i:= 0 to 30 do
  begin
    S.Read(Instr, SizeOf(Instr));
    if S.Status <> stOk then exit;
    Instrs[I].Size := Instr.Length;
    if Instr.Length > 1 then
    begin
      Instrs[I].Name := ASCIIZtoStr(Instr.Name, 12);
      Instrs[I].LoopS := Instr.LoopStart;
      Instrs[I].LoopE := Instr.LoopEnd;
      if (Instr.LoopEnd <> $FFFF) and
        (Instr.LoopEnd > Instr.Length) then Instrs[I].LoopE := Instr.Length;
      Instrs[I].DefVolume := Instr.DefVolume;
      Instrs[I].SpeedOfC := Instr.SpeedOfC;
      InsSeg[I] := Instr.SampleSeg;
    end;
  end;

  S.Read(Orders, 128);
  if S.Status <> stOk then exit;
  for I := 0 to NumPatt-1 do
  begin
    Patterns[I] := MemAlloc(SizeOf(TPattern));
    if Patterns[I] = nil then begin Read := 3; exit end; { ??? }
    S.Read(Patterns[I]^, 1024);
    if S.Status <> stOk then exit;
  end;

  for I := 0 to 30 do
  if Instrs[I].Size > 1 then
  begin
    Instrs[I].Sample := MemAllocSeg(Instrs[I].Size);
    if Instrs[I].Sample = nil then exit;
    S.Seek(Longint(InsSeg[I]) shl 4);
    S.Read(Instrs[I].Sample^, Instrs[I].Size);
    if S.Status <> stOk then exit;
  end;
end;

{ ------------------------------------------ TMODSong ------- }

procedure TModSong.MODtoSTM(var Pattern: TPattern); assembler;
const
  Table : array[0..59] of Word =
 {C-0 to B-0:}(1712,1616,1524,1440,1356,1280,1208,1140,1076,1016, 960, 906,
 {C-1 to B-1:}  856, 808, 762, 720, 678, 640, 604, 570, 538, 508, 480, 453,
 {C-2 to B-2:}  428, 404, 381, 360, 339, 320, 302, 285, 269, 254, 240, 226,
 {C-3 to B-3:}  214, 202, 190, 180, 170, 160, 151, 143, 135, 127, 120, 113,
 {C-4 to B-4:}  107, 101, 95 , 90 , 85 , 80 ,   0,   0,   0,   0,  60,   0);
  Repl: array[0..15] of Byte =
 (0,6,5,0,8,0,0,9,0,0,4,2,0,3,0,1); { ??? }
  C12: Byte = 12;
var
  Instr: Byte;
  Nota: Byte;
  Octava: Byte;
  Command: Byte;
  Volume: Byte;
  Info: Byte;
  Count: Byte;
asm
        CLD
        LES     DI,Pattern
        MOV     Count,0
@@Loop:
        MOV     AL,ES:[DI+2]
        SHR     AL,4
        MOV     Instr,AL

        MOV     AL,ES:[DI+1]
        MOV     AH,ES:[DI]
        AND     AH,0Fh
        OR      AX,AX
        JNZ     @@1
        MOV     AL,0Fh
        MOV     AH,0Fh
        JMP     @@4
@@1:
        CLD
        PUSH    ES
        PUSH    DI
        MOV     DI,OFFSET Table
        MOV     BX,DI
        PUSH    DS
        POP     ES
        MOV     CX,48
        REPNE   SCASW
        JE      @@2
        LEA     DI,[BX+2]
@@2:    SUB     DI,BX
        XCHG    AX,DI
        POP     DI
        POP     ES
        SHR     AX,1
        DEC     AX
        DIV     C12
@@4:
        MOV     Octava,AL
        MOV     Nota,AH

        MOV     Volume,64

        MOV     AH,ES:[DI+2]
        AND     AH,0Fh
        MOV     AL,ES:[DI+3]
        OR      AX,AX
        JZ      @@7

        CMP     AH,0Ch          { Volume }
        JNE     @@5
        MOV     Volume,AL
        JMP     @@6
@@5:
        XOR     BX,BX
        MOV     BL,AH
        MOV     AH,Repl[BX].Byte
        CMP     AH,0
        JNE     @@7
@@6:    MOV     AH,0
        MOV     AL,0
@@7:
        MOV     AL,ES:[DI+3]
        MOV     Info,AL
        MOV     Command,AH
        CMP     AH,1
        JNE     @@8
        SHL     Info,4
        NOP     { /// ??? }
@@8:

        MOV     AL,Octava
        SHL     AL,4
        ADD     AL,Nota
        STOSB

        MOV     AL,Instr
        SHL     AL,3
        MOV     BL,Volume
        MOV     BH,BL
        SHR     BL,6
        ADD     AL,BL
        STOSB

        SHR     BH,3
        MOV     AL,BH
        SHL     AL,4
        ADD     AL,Command
        STOSB

        MOV     AL,Info
        STOSB

        INC     Count
        JNZ     @@Loop
@@Exit:
end;


function TMODSong.Read(var S: TStream): Integer;

  function MaxOrder(var Orders): Byte; assembler;
  asm
        PUSH    DS
        LDS     SI,Orders
        MOV     CX,128
        MOV     AH,0
  @@1:
        LODSB
        CMP     AL,AH
        JL      @@2
        MOV     AH,AL
  @@2:  LOOP    @@1
        MOV     AL,AH
        INC     AL
        POP     DS
  end;

var
  H: TMODHeader;
  H2: TMOD2Header absolute H;
  Count: Word;
  I: Word;
begin
  Read := 0;
  S.Read(H, SizeOf(H));
  if S.Status <> stOk then exit;
  Name := ASCIIZtoStr(H.SongName, 19);
  if (H.Sign='M.K.') or (H.Sign='FLT4') or (H.Sign='FLT8') then Count := 30 else
  begin
    Count := 14;
    Move(H2.SongLength, H.SongLength, 130);
    S.Seek(SizeOf(H2));
  end;

  Move(H.Orders, Orders,SizeOf(Orders));
  NumPatt := MaxOrder(Orders);

  for I := 0 to Count do
  begin
    Instrs[I].DefVolume := H.Instr[I].DefVolume;
    Instrs[I].Size := Swap(H.Instr[I].Length)*2;
    Instrs[I].LoopS := Swap(H.Instr[I].LoopStart)*2;
    if Swap(H.Instr[I].LoopEnd) <= 1 then Instrs[I].LoopE := $FFFF else
      Instrs[I].LoopE := Swap(H.Instr[I].LoopEnd)*2 + Instrs[I].LoopS;
    Instrs[I].SpeedOfC := {H.Instr[I].FineTune;} 8448; { ??? }
    Instrs[I].Name := ASCIIZtoStr(H.Instr[I].Name, 21);
  end;

  for I := 0 to NumPatt-1 do
  begin
    Patterns[I] := MemAlloc(SizeOf(TPattern));
    if Patterns[I] = nil then begin Read := 3; exit end; { ??? }
    S.Read(Patterns[I]^, 1024);
    if S.Status <> stOk then exit;
    MODtoSTM(Patterns[I]^);
  end;

  for I := 0 to Count do
    if Instrs[I].Size <> 0 then
    begin
      Instrs[I].Sample := MemAllocSeg(Instrs[I].Size);
      if Instrs[I].Sample = nil then exit;
      S.Read(Instrs[I].Sample^, Instrs[I].Size);
    end;
end;

end.
