{$A+,B+,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-}
{AdnMod 0.2 by Beta/Adrenalin.
 GUS only
 Thanks to:
    flap / Capacala for sending me "some" info
    Mark Feldham for PCGPE
    Mark Dixon for his GUS669 source
    Thunder for excellent info about MODs
    Tran & Joshua C. Jensen for releasing ultradox

 Greets:
    Wihannes / Nordic vision
    Solar / Hysteria
    Psyko / Acidface software
    TOP4.ZIP
    All users of Metropoli & Starport
}
unit modunit;
interface
uses dos;

const
maxchn = 8;   {max # of channels in mod. Lower this, if you run out
               of memory}
amp_vol : byte = 14;  {amplifying volume. Increasing by one doubles
                       the volume}

def_pan : byte = 4;        {default panning. 0-7}

max_per = 1000;          {Max & min period for Amiga limits}
min_per = 20;            {not implemented anymore coz of extra octaves}
Base : word = $200;       {GUS address}

mod_error : word = 0;
{0 = no error
 1 = wrong number of channels
 2 = load error
 3 = out of pattern memory
 255 = other error}

per_table : array[0..15,1..48 ] of word = (
   (856,808,762,720,678,640,604,570,538,508,480,453,
   428,404,381,360,339,320,302,285,269,254,240,226,
   214,202,190,180,170,160,151,143,135,127,120,113,
   107,101,95,90,85,80,75,71,67,63,60,56),

(850,802,757,715,674,637,601,567,535,505,477,450,{ : C-1 to B-1 Finetune +1}
425,401,379,357,337,318,300,284,268,253,239,225, { : C-2 to B-2 Finetune +1}
213,201,189,179,169,159,150,142,134,126,119,113, { : C-3 to B-3 Finetune +1}
106,100,94,89,84,79,75,71,67,83,59,56),          { : C-4 to B-4 Finetune +1}


(844,796,752,709,670,632,597,563,532,502,474,447,{ : C-1 to B-1 Finetune +2}
422,398,376,355,335,316,298,282,266,251,237,224, { : C-2 to B-2 Finetune +2}
211,199,188,177,167,158,149,141,133,125,118,112, { : C-3 to B-3 Finetune +2}
105, 99, 94, 88, 83, 79, 74, 70, 66, 62, 59, 56),{ : C-4 to B-4 Finetune +2}

(838,791,746,704,665,628,592,559,528,498,470,444,{ : C-1 to B-1 Finetune +3}
419,395,373,352,332,314,296,280,264,249,235,222, { : C-2 to B-2 Finetune +3}
209,198,187,176,166,157,148,140,132,125,118,111, { : C-3 to B-3 Finetune +3}
104, 99, 93, 88, 83, 78, 74, 70, 66, 62, 59, 55),{ : C-4 to B-4 Finetune +3}

(832,785,741,699,660,623,588,555,524,495,467,441,{ : C-1 to B-1 Finetune +4}
416,392,370,350,330,312,294,278,262,247,233,220, { : C-2 to B-2 Finetune +4}
208,196,185,175,165,156,147,139,131,124,117,110, { : C-3 to B-3 Finetune +4}
104, 98, 92, 87, 82, 78, 73, 69, 65, 62, 58, 55), {; C-4 to B-4 Finetune +4}

(826,779,736,694,655,619,584,551,520,491,463,437,{ : C-1 to B-1 Finetune +5}
413,390,368,347,328,309,292,276,260,245,232,219, { : C-2 to B-2 Finetune +5}
206,195,184,174,164,155,146,138,130,123,116,109, { : C-3 to B-3 Finetune +5}
103, 97, 92, 87, 82, 77, 73, 69, 65, 61, 58, 54),{ ; C-4 to B-4 Finetune +5}

(820,774,730,689,651,614,580,547,516,487,460,434,{ : C-1 to B-1 Finetune +6}
410,387,365,345,325,307,290,274,258,244,230,217, { : C-2 to B-2 Finetune +6}
205,193,183,172,163,154,145,137,129,122,115,109, { : C-3 to B-3 Finetune +6}
102, 96, 91, 86, 81, 77, 72, 68, 64, 61, 57, 54),{ : C-4 to B-4 Finetune +6}

(814,768,725,684,646,610,575,543,513,484,457,431,{ : C-1 to B-1 Finetune +7}
407,384,363,342,323,305,288,272,256,242,228,216, { : C-2 to B-2 Finetune +7}
204,192,181,171,161,152,144,136,128,121,114,108, { : C-3 to B-3 Finetune +7}
102, 96, 90, 85, 80, 76, 72, 68, 64, 60, 57, 54),{ : C-4 to B-4 Finetune +7}

(907,856,808,762,720,678,640,604,570,538,504,480,{ : C-1 to B-1 Finetune -8 }
453,428,404,381,360,339,320,302,285,269,254,240, { : C-2 to B-2 Finetune -8  }
226,214,202,190,180,170,160,151,143,135,127,120, { : C-3 to B-3 Finetune -8 }
113,107,101, 95, 90, 85, 80, 75, 71, 67, 63, 60),{ : C-4 to B-4 Finetune -8}


(900,850,802,757,715,675,636,601,567,535,505,477,{ : C-1 to B-1 Finetune -7 }
450,425,401,379,357,337,318,300,284,268,253,238, { : C-2 to B-2 Finetune -7  }
225,212,200,189,179,169,159,150,142,134,126,119, { : C-3 to B-3 Finetune -7 }
112,106,100, 94, 89, 84, 79, 75, 71, 67, 63, 59),{ : C-4 to B-4 Finetune -7}

(894,844,796,752,709,670,632,597,563,532,502,474,{ : C-1 to B-1 Finetune -6 }
447,422,398,376,355,335,316,298,282,266,251,237, { : C-2 to B-2 Finetune -6  }
223,211,199,188,177,167,158,149,141,133,125,118, { : C-3 to B-3 Finetune -6 }
111,105, 99, 94, 88, 83, 79, 74, 70, 66, 62, 59),{ : C-4 to B-4 Finetune -6}

(887,838,791,746,704,665,628,592,559,528,498,470,{ : C-1 to B-1 Finetune -5 }
444,419,395,373,352,332,314,296,280,264,249,235, { : C-2 to B-2 Finetune -5  }
222,209,198,187,176,166,157,148,140,132,125,118, { : C-3 to B-3 Finetune -5  }
111,104, 99, 93, 88, 83, 78, 74, 70, 66, 62, 59),{ : C-4 to B-4 Finetune -5}

(881,832,785,741,699,660,623,588,555,524,494,467,{ : C-1 to B-1 Finetune -4 }
441,416,392,370,350,330,312,294,278,262,247,233, { : C-2 to B-2 Finetune -4  }
220,208,196,185,175,165,156,147,139,131,123,117, { : C-3 to B-3 Finetune -4 }
110,104, 98, 92, 87, 82, 78, 73, 69, 65, 61, 58),{   C-4 to H-4 Finetune -4}

(875,826,779,736,694,655,619,584,551,520,491,463,{ : C-1 to B-1 Finetune -3 }
437,413,390,368,347,338,309,292,276,260,245,232, { : C-2 to B-2 Finetune -3  }
219,206,195,184,174,164,155,146,138,130,123,116, { : C-3 to B-3 Finetune -3 }
109,103, 97, 92, 87, 82, 77, 73, 69, 65, 61, 58),{   C-4 to H-4 Finetune -3}

(868,820,774,730,689,651,614,580,547,516,487,460,{ : C-1 to B-1 Finetune -2 }
434,410,387,365,345,325,307,290,274,258,244,230, { : C-2 to B-2 Finetune -2  }
217,205,193,183,172,163,154,145,137,129,122,115, { : C-3 to B-3 Finetune -2 }
108,102, 96, 91, 86, 81, 77, 72, 68, 64, 61, 57),{   C-4 to H-4 Finetune -2}

(862,814,768,725,684,646,610,575,543,513,484,457,{ : C-1 to B-1 Finetune -1 }
431,407,384,363,342,323,305,288,272,256,242,228, { : C-2 to B-2 Finetune -1  }
216,203,192,181,171,161,152,144,136,128,121,114, { : C-3 to B-3 Finetune -1}
108,101, 96, 90, 85, 80, 76, 72, 68, 64, 60, 57));{  C-4 to H-4 Finetune -1}

gusvol : array[0..64] of word =     {volume table}

  (0,1750,2503,2701,2741,2781,2944,2964,2981,
  3000,3017,3034,3052,3070,3207,3215,3224,

  3232,3240,3248,3256,3263,3271,3279,3287,
  3294,3303,3310,3317,3325,3458,3462,3466,

  3469,3473,3478,3481,3484,3489,3492,3495,
  3499,3502,3506,3509,3513,3517,3520,3524,

  3528,3532,3534,3538,3543,3545,3549,3552,
  3556,3558,3563,3565,3570,3573,3577,3580);

vib_tbl : array[0..2,0..63] of shortint =
((0,6,12,19,24,30,36,41,45,49,53,56,59,61,63,64,
64,64,63,61,59,56,53,49,45,41,36,30,24,19,12,6,
0,-6,-12,-19,-24,-30,-36,-41,-45,-49,-53,-56,-59,-61,-63,-64,
-64,-64,-63,-61,-59,-56,-53,-49,-45,-41,-36,-30,-24,-19,-12,-6),
(-63,-61,-59,-57,-55,-53,-51,-49,-47,-45,-43,-41,-39,-37,-35,-33,
-31,-29,-27,-25,-23,-21,-19,-17,-15,-13,-11,-9,-7,-5,-3,-1,
1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,
33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63),
(-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,
-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,-64,
64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,
64,64,64,64,64,64,64,64,64,64,64,64,64,64,64,64));


type
  t_memarray = array[0..2000] of word;
  t_channel = record
                Vol : byte;       {current volume 0-64}
                note : byte;      {current note 1(C-1) to 48(B-4)}
                Per,dper : word;  {period & dest. period for tone portamentos}
                Sample : byte;    {current sample}
                Pan : byte;       {panning}
                fx,fxdata : byte;
                fx_sl2,fx_vib : byte;  {slide to & vibrato fx-data}
                vib_wave : byte;    {vibrato waveform}
                vib_cnt : byte;     {vibrato counter}
                trig_cnt : byte;    {retrig counter}
                arp1,arp2,         {arpeggio params}
                arp_cnt : byte;     {arpeggio counter}
                start_fx : byte;    {tick to start do_fx for channel}
                on : byte;        {0 = channel is muted}
                bar : byte;       {volume bar}
                hit : byte;
                no_fx : byte  {1 = do not get new fx}
              end;
  t_sample = record
               Name : array[1..40] of char;
               Addr : longint;  {address in GUS mem}
               Length : word;
               LoopStart,
               LoopEnd : word;
               ftune : byte;
               Volume : byte;
             end;
  t_note = record
             per : word;
             note,
             sample,
             fx,
             fxdata : byte;
           end;
  t_row = array[0..maxchn-1] of t_note;
  t_pattern = array[0..63] of t_row;
  p_pattern = ^t_pattern;

  mod_header = record
                 name : string[20];
                 Length : byte;
                 tag : array[0..3] of char;  {M.K.}
                 chns : byte;  {4..12}
                 samples : byte; {15 / 31}
               end;

var
  gus_addr : array[0..32] of longint;
  periods : array[0..1100] of word;
  channels : array[0..maxchn-1] of t_channel;
  samples : array[0..32] of t_sample;
  patterns : array[0..128] of p_pattern;
  orders : array[0..255] of byte;   {order list}
  max_ptn : word;                 {# patterns in mod}
  cur_ptn,cur_row,cur_tick : byte;
  new_ptn,new_row,jump : byte;   {used in jumps}
  speed,nspeed,tempo : byte;
  vblank : boolean;               {true = do not use bpm tempos}

  header : mod_header;
  top_addr : longint;         {Next free address in GUS mem}

  time_counter : longint;      {For syncing with demos. Increments
                                every 1/18.2 seconds}
  time_counter2 : longint;    {Increments every tick}
  vrt_flag : byte;   {if 1 then vertical retrace happened}

Procedure GUSDelay;
Function VoicePos( V : Byte) : Longint;
Function  GUSPeek(Loc : Longint) : Byte;
Procedure GUSPoke(Loc : Longint; B : Byte);
Function GUSProbe(adr : word) : Boolean;
Procedure GUSFind;
Function  GUSFindMem : Longint;
Procedure GUSSetFreq( V : Byte; hz : Word);
Procedure GUSVoiceControl( V, B : Byte);
Procedure GUSSetBalance( V, Bal : Byte);
Procedure GUSSetVolume( V : Byte; Vol : Word);
Procedure GUSSetLoopMode( V : Byte);
Procedure GUSStopVoice( V : Byte);
Procedure GUSPlayVoice( V, Mode : Byte;VBegin, VStart, VEnd : Longint);
procedure gusrelvoice(v : byte);
procedure GusSetOfs(v : byte;vbegin : longint);
Procedure GUSReset;
procedure gusdeinit;

procedure updatenotes;
procedure start_playing;
procedure stop_playing;
procedure set_timer(ticks : word);
procedure init_mod;
procedure free_mod;
procedure load_mod(s : string;debug : boolean);


implementation

var
  oldint : procedure;
  int_tick,o_int_tick : word;
  int_rate : word;

  gus_bank : longint;

  misc_buf : array[0..5000] of byte;    {buffer used while loading mod}
  misc_buf2 : ^t_memarray;      {points to misc_buf}

{$i gus.inc}

{$s-}
procedure get_notes;
var
  chn : byte;
  ptn : byte;
  org_sam,sam,note : byte;
  st_ofs : longint;
  per,dper,vol,freq : word;
  _fx,_fxdata : byte;
  mute: byte;
  _ptn : p_pattern;

procedure prefx;
var
w : word;
_efxdata : byte;
begin
  case _fx of
    9 : begin
          w := _fxdata*$100;
          st_ofs := w;
          channels[chn].no_fx := 1;
          channels[chn].fx := _fx;
          channels[chn].fxdata := _fxdata;
        end;
    $c : begin
           if _fxdata > 64 then _fxdata := 64;
           vol := _fxdata;
         end;
    $e : begin
           _efxdata := _fxdata and 15;
           case _fxdata shr 4 of
           4 : begin
                 channels[chn].fx := _fx;
                 channels[chn].fxdata := _fxdata;
                 if _efxdata and 3 < 3 then channels[chn].vib_wave := _efxdata
                 else channels[chn].vib_wave := 0 or (_efxdata and 4);
               end;
               $c : if _efxdata and 15 = 0 then begin
                 mute := 1;
                 gusstopvoice(chn+1);
               end;
               $d : if _efxdata > 0 then mute := 2
                    else mute := 0;
           end;
    end;
  end;
end;

begin
  ptn := orders[cur_ptn];
  for chn := 0 to header.chns-1 do begin
    if channels[chn].fx = 0 then begin
      sam := channels[chn].sample;
      per := per_table[samples[sam].ftune,
                       channels[chn].note];
      gussetfreq(chn+1,periods[per]);
    end;
    channels[chn].hit := 0;
    if ((patterns[ptn]^[cur_row,chn].per > 0) or
    (patterns[ptn]^[cur_row,chn].sample > 0)) then begin
      mute := 1;
      vol := channels[chn].vol;
      per := channels[chn].per;
      note := channels[chn].note;
      freq := periods[channels[chn].per];
      _fx := patterns[ptn]^[cur_row,chn].fx;
      _fxdata := patterns[ptn]^[cur_row,chn].fxdata;
      org_sam := patterns[ptn]^[cur_row,chn].sample;
      channels[chn].start_fx := 0;
      channels[chn].trig_cnt := 0;
      if org_sam = 0 then begin
        sam := channels[chn].sample;
      end
      else begin
        sam := org_sam;
      end;
      if (_fx = 3) or (_fx = 5) then begin {port to/port to&vol slide}
        mute := 1; {dont restart sample}
        if patterns[ptn]^[cur_row,chn].note > 0 then begin
          note := patterns[ptn]^[cur_row,chn].note;
          dper := per_table[samples[sam].ftune,note];
          if dper > max_per then dper := max_per;
          if dper < min_per then dper := min_per;
          channels[chn].dper := dper;
        end;
      end
      else if patterns[ptn]^[cur_row,chn].per > 0 then begin
        if patterns[ptn]^[cur_row,chn].note > 0 then begin
          note := patterns[ptn]^[cur_row,chn].note;
          per := per_table[samples[sam].ftune,note];
        end
        else if patterns[ptn]^[cur_row,chn].per > 0 then
          per := patterns[ptn]^[cur_row,chn].per;

        if per > max_per then per := max_per;
        if per < min_per then per := min_per;
        channels[chn].dper := per;
        channels[chn].per := per;
        freq := periods[per];
        mute := 0;
      end;
      if org_sam > 0 then begin {should I reset volume}
        vol := samples[sam].volume;
        if channels[chn].sample <> org_sam then mute := 0;
      end;
      if samples[sam].length > 0 then st_ofs := 2;
        {coz first 2 bytes = amiga loopinfo, discard them}
      channels[chn].no_fx := 0;
      prefx;
      channels[chn].vol := vol;
      channels[chn].note := note;
      if channels[chn].vib_wave and 4 = 0 then channels[chn].vib_cnt := 0;
      channels[chn].sample := sam;
      channels[chn].bar := channels[chn].vol;
      vol := gusvol[vol]*amp_vol;
      if channels[chn].on = 0 then mute := 1;
      if mute = 0 then begin
        channels[chn].hit := 1;
        gussetbalance(chn+1,channels[chn].pan);
        if (samples[sam].loopend > 2) then
          gusplayall(chn+1,8,gus_addr[sam]+st_ofs,
                               gus_addr[sam]+samples[sam].loopstart,
                               gus_addr[sam]+samples[sam].loopend,freq,vol)
        else gusplayall(chn+1,0,gus_addr[sam]+st_ofs,
                             gus_addr[sam]+st_ofs,
                             gus_addr[sam]+samples[sam].length,freq,vol);
      end
      else if (channels[chn].on = 1) and (mute=1) then gussetvolume(chn+1,vol);
    end;
  end;
end;

procedure get_fx;
var
chn,ptn : byte;
_fx,_fxdata : byte;
_efx,_efxdata : byte;
per : word;
b : byte;
w : word;

begin
  ptn := orders[cur_ptn];
  new_ptn := cur_ptn;
  new_row := cur_row;
  jump := 0;
  for chn := 0 to header.chns-1 do
  if channels[chn].no_fx = 0 then begin
    channels[chn].start_fx := 0;
    channels[chn].fx := 255;
    _fx := patterns[ptn]^[cur_row,chn].fx;
    _fxdata := patterns[ptn]^[cur_row,chn].fxdata;
    case _fx of
      0 : if _fxdata > 0 then begin {Arpeggio}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
            channels[chn].arp1 := _fxdata shr 4;
            channels[chn].arp2 := _fxdata and 15;
            channels[chn].arp_cnt := 0;
          end;
      1 : begin  {port up}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
            channels[chn].start_fx := 2;
          end;
      2 : begin  {port down}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
            channels[chn].start_fx := 2;
          end;
      3 : begin   {port to}
            channels[chn].fx := _fx;
            if _fxdata > 0 then begin
              channels[chn].fxdata := _fxdata;
              channels[chn].fx_sl2 := _fxdata;
            end
            else channels[chn].fxdata := channels[chn].fx_sl2;
            channels[chn].start_fx := 2;
          end;
      4 : begin    {vibrato}
            channels[chn].fx := _fx;
            b := _fxdata and 15;
            if b = 0 then b := channels[chn].fx_vib and 15;
            w := b;
            b := _fxdata shr 4;
            if b = 0 then b := channels[chn].fx_vib shr 4;
            w := w or (b shl 4);
            b := w;
            channels[chn].fxdata := b;
            channels[chn].fx_vib := b;
          end;
      5 : begin    {port to & vol slide}
             channels[chn].fx := _fx;
             if _fxdata and 15 > 0 then
               _fxdata := _fxdata and 15; {if both ways, then slide down}
             channels[chn].fxdata := _fxdata;
          end;
      6 : begin      {Vibrato & vol slide}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
          end;
      7 : begin      {Tremolo}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
          end;
      8 : begin       {Set panning}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
          end;
      9 : begin   {set sample offset}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
            w := _fxdata * 256;
            b := channels[chn].sample;
            if channels[chn].on = 1 then gussetofs(chn+1,gus_addr[b]+w);
          end;
      $a : begin   {volume slide}
             channels[chn].fx := _fx;
             if _fxdata and 15 > 0 then
               _fxdata := _fxdata and 15; {if both ways, then slide up}
             channels[chn].fxdata := _fxdata;
             channels[chn].start_fx := 2;
           end;
      $b : begin   {position jump}
             if _fxdata < max_ptn then begin
               new_ptn := _fxdata;
               new_row := 0;
               jump := 1;
             end;
           end;
      $c : begin  {Set volume}
             if _fxdata > 64 then _fxdata := 64;
             channels[chn].fx := _fx;
             channels[chn].fxdata := _fxdata;
             channels[chn].vol := _fxdata;
             channels[chn].bar := _fxdata;
             w := gusvol[_fxdata {* main_vol}]*amp_vol;
             if channels[chn].on = 1 then gussetvolume(chn+1,w);
           end;
      $d : begin   {break pattern}
             new_ptn := cur_ptn;
             inc(new_ptn);
             new_row := ((_fxdata and $f0) shr 4)*10+_fxdata and 15;
             jump := 1;
           end;
      $e : begin        {extended effect}
             channels[chn].fx := _fx;
             channels[chn].fxdata := _fxdata;
             _efx := _fxdata shr 4;
             _efxdata := _fxdata and 15;
             case _efx of
               1 : begin
                     per := channels[chn].per;
                     inc(per,_efxdata);
                     if per > max_per then per := max_per;
                     channels[chn].per := per;
                     w := periods[channels[chn].per];
                     gussetfreq(chn+1,w);
                   end;
               2 : begin
                     per := channels[chn].per;
                     dec(per,_efxdata);
                     if per < min_per then per := min_per;
                     channels[chn].per := per;
                     w := periods[channels[chn].per];
                     gussetfreq(chn+1,w);
                   end;
               4 : begin {set vibrato waveform}
                     channels[chn].vib_wave := _efxdata;
                   end;
               5 : begin  {set finetune}
                     samples[channels[chn].sample].ftune := _efxdata;
                   end;
               8 : begin  {set mtm-pan}
                     channels[chn].pan := _efxdata;
                     gussetbalance(chn+1,_efxdata);
                   end;
               9 : if _efxdata > 0 then begin   {retrigger}
                     channels[chn].fx := _fx;
                     channels[chn].fxdata := _fxdata;
                     channels[chn].trig_cnt := _efxdata;
                   end;
               $a : begin   {fine vol slide up}
                      b := channels[chn].vol;
                      inc(b,_efxdata);
                      if b > 64 then b := 64;
                      channels[chn].vol := b;
                      w := gusvol[b{*main_vol}]*amp_vol;
                      if channels[chn].on = 1 then gussetvolume(chn+1,w);
                      channels[chn].bar := b;
                    end;
               $b : begin   {fine vol slide down}
                      b := channels[chn].vol;
                      dec(b,_efxdata);
                      if b > 128 then b := 0;
                      channels[chn].vol := b;
                      w := gusvol[b{*main_vol}]*amp_vol;
                      if channels[chn].on = 1 then gussetvolume(chn+1,w);
                      channels[chn].bar := b;
                    end;
               $c : begin  {cut note}
                      channels[chn].fx := _fx;
                      channels[chn].fxdata := _fxdata;
                    end;
               $d : if _efxdata > 0 then begin
                      channels[chn].fx := _fx;
                      channels[chn].fxdata := _fxdata;
                      channels[chn].start_fx := 1+_efxdata;
                    end
                    else channels[chn].fx := 255;
             end;
           end;
      $f : begin  {set speed}
            channels[chn].fx := _fx;
            channels[chn].fxdata := _fxdata;
             if (_fxdata <= 32) or vblank then begin    {SPEED not tempo}
               nspeed := _fxdata;
               speed := _fxdata;
             end
             else begin
               tempo := _fxdata;
               if tempo < 50 then tempo := 50;
               int_rate := 1193182 div (tempo*4 div 10);
               set_timer(int_rate);
             end;
           end
      else begin
        channels[chn].fx := 255;
        channels[chn].fxdata := 0;
      end;
    end;
  end
  else channels[chn].no_fx := 0;
end;

procedure do_fx;
var
chn : byte;
_fx,_fxdata : byte;
_efx,_efxdata : byte;
per : word;
b : byte;
s : shortint;
w : word;

begin
  for chn := 0 to header.chns-1 do if channels[chn].on = 1 then begin
    if channels[chn].start_fx > 0 then dec(channels[chn].start_fx);
    _fx := channels[chn].fx;
    _fxdata := channels[chn].fxdata;
    if (channels[chn].on = 1) and (channels[chn].start_fx = 0)
    then case _fx of
      0 : with channels[chn] do begin
            case channels[chn].arp_cnt mod 3 of
              0 : gussetfreq(chn+1,
                    periods[per_table[samples[sample].ftune,note]]);
              1 : gussetfreq(chn+1,
                    periods[per_table[samples[sample].ftune,note+arp1]]);
              2 : gussetfreq(chn+1,
                    periods[per_table[samples[sample].ftune,note+arp2]]);
            end;
            inc(arp_cnt);
          end;
      1 : begin   {port up}
            per := channels[chn].per;
            dec(per,_fxdata);
            if per < min_per then per := min_per;
            channels[chn].per := per;
            gussetfreq(chn+1,periods[per]);
          end;
      2 : begin  {port down}
            per := channels[chn].per;
            inc(per,_fxdata);
            if per > max_per then per := max_per;
            channels[chn].per := per;
            gussetfreq(chn+1,periods[per]);
          end;
      3 : begin   {Port to}
            if channels[chn].per < channels[chn].dper then begin
              w := channels[chn].dper;
              per := channels[chn].per;
              inc(per,channels[chn].fx_sl2);
              if per > w then per := w;
              if per > max_per then per := max_per;
              if per < min_per then per := min_per;
              channels[chn].per := per;
              gussetfreq(chn+1,periods[per]);
            end
            else begin
              w := channels[chn].dper;
              per := channels[chn].per;
              if per-channels[chn].fx_sl2 > per then per := min_per
              else dec(per,channels[chn].fx_sl2);
              if per < w then per := w;
              if per < min_per then per := min_per;
              if per > max_per then per := max_per;
              channels[chn].per := per;
              gussetfreq(chn+1,periods[per]);
            end;
          end;
      4 : begin
            _fxdata := channels[chn].fx_vib;
            b := _fxdata and 15;
            s := vib_tbl[channels[chn].vib_wave,channels[chn].vib_cnt];
            s := (s * b) div 64;
            w := channels[chn].per+s;
            if w > max_per then w := max_per;
            if w < min_per then w := min_per;
            b := _fxdata shr 4;
            gussetfreq(chn+1,periods[w]);
            inc(channels[chn].vib_cnt,b);
            if channels[chn].vib_cnt > 63 then
              channels[chn].vib_cnt := channels[chn].vib_cnt - 64;
          end;
      5 : begin
            {volume slide}
            if _fxdata and 15 > 0 then begin  {slide down}
              b := channels[chn].vol;
              if b-_fxdata >= 0 then dec(b,_fxdata)
              else b := 0;
              if b > 128 then b := 0;
              channels[chn].vol := b;
              channels[chn].bar := b;
              w := gusvol[b {* main_vol}]*amp_vol;
              gussetvolume(chn+1,w);
            end
            else begin   {slide up}
              b := channels[chn].vol;
              inc(b,_fxdata shr 4);
              if b > 64 then b := 64;
              channels[chn].vol := b;
              channels[chn].bar := b;
              w := gusvol[b {* main_vol}]*amp_vol;
              gussetvolume(chn+1,w);
            end;
            _fxdata := channels[chn].fx_sl2;
            if channels[chn].per < channels[chn].dper then begin {port to}
              w := channels[chn].dper;
              per := channels[chn].per;
              inc(per,_fxdata);
              if per > w then per := w;
              if per > max_per then per := max_per;
              if per < min_per then per := min_per;
              channels[chn].per := per;
              gussetfreq(chn+1,periods[per]);
            end
            else begin
              w := channels[chn].dper;
              per := channels[chn].per;
              if per-_fxdata > per then per := min_per
              else dec(per,_fxdata);
              if per < w then per := w;
              if per < min_per then per := min_per;
              if per > max_per then per := max_per;
              channels[chn].per := per;
              gussetfreq(chn+1,periods[per]);
            end;
          end;
      6 : begin
            begin
              b := channels[chn].fx_vib and 15;
              s := vib_tbl[channels[chn].vib_wave,channels[chn].vib_cnt];
              s := (s * b) div 64;
              w := channels[chn].per+s;
              if w > max_per then w := max_per;
              if w < min_per then w := min_per;
              b := channels[chn].fx_vib shr 4;
              gussetfreq(chn+1,periods[w]);
              inc(channels[chn].vib_cnt,b);
              if channels[chn].vib_cnt > 63 then
                channels[chn].vib_cnt := channels[chn].vib_cnt - 64;
            end;
            {volume slide}
            if _fxdata and 15 > 0 then begin  {slide down}
              b := channels[chn].vol;
              if b-_fxdata >= 0 then dec(b,_fxdata)
              else b := 0;
              if b > 128 then b := 0;
              channels[chn].vol := b;
              channels[chn].bar := b;
              w := gusvol[b {* main_vol}]*amp_vol;
              gussetvolume(chn+1,w);
            end
            else begin   {slide up}
              b := channels[chn].vol;
              inc(b,_fxdata shr 4);
              if b > 64 then b := 64;
              channels[chn].vol := b;
              channels[chn].bar := b;
              w := gusvol[b {* main_vol}]*amp_vol;
              gussetvolume(chn+1,w);
            end;
          end;
      $a : begin  {volume slide}
             if _fxdata and 15 > 0 then begin  {slide down}
               b := channels[chn].vol;
               if b < (_fxdata and 15) then b := 0
               else dec(b,_fxdata and 15);
               if b > 64 then b := 0;
               channels[chn].vol := b;
               channels[chn].bar := b;
               w := gusvol[b]*amp_vol;
               gussetvolume(chn+1,w);
             end
             else begin   {slide up}
               b := channels[chn].vol;
               inc(b,_fxdata shr 4);
               if b > 64 then b := 64;
               channels[chn].vol := b;
               channels[chn].bar := b;
               w := gusvol[b {* main_vol}]*amp_vol;
               gussetvolume(chn+1,w);
             end;
           end;
      $e : begin
             _efx := _fxdata shr 4;
             _efxdata := _fxdata and 15;
             case _efx of
               9 : begin
                     b := channels[chn].sample;
                     dec(channels[chn].trig_cnt);
                     if channels[chn].trig_cnt = 0 then begin
                       gussetofs(chn+1,gus_addr[b]+2);
                       channels[chn].trig_cnt := _efxdata;
                     end;
                   end;
               $c : if _efxdata = 0 then begin
                      gussetvolume(chn+1,0);
                    end
                    else begin
                      dec(_efxdata);
                      b := _fxdata;
                      b := b and $f0;
                      b := b or _efxdata;
                      channels[chn].fxdata := b;
                    end;
               $d : begin
                      w := channels[chn].sample;
                      if channels[chn].on = 1 then begin
                        channels[chn].hit := 1;
                        gussetbalance(chn+1,channels[chn].pan);
                        if (samples[w].loopend > 2) then
                          gusplayall(chn+1,8,gus_addr[w]+2,
                               gus_addr[w]+samples[w].loopstart,
                               gus_addr[w]+samples[w].loopend,
                               periods[channels[chn].per],
                               gusvol[channels[chn].vol]*amp_vol)
                        else  gusplayall(chn+1,0,gus_addr[w]+2,
                             gus_addr[w],
                             gus_addr[w]+samples[w].length+1,
                             periods[channels[chn].per],
                             gusvol[channels[chn].vol]*amp_vol);
                      end;
                    end;
             end;
           end;
    end;
  end;
end;

procedure updatenotes;
var
n : integer;
begin
  if cur_ptn > header.length-1 then new_ptn := 0;
  cur_ptn := new_ptn;
  cur_row := new_row;
  if (cur_tick >= speed) and (speed > 0) then begin
    speed := nspeed;
    cur_tick := 0;
    if jump = 0 then inc(cur_row);
    if cur_row > 63 then begin
      inc(cur_ptn);
      cur_row := 0;
      if cur_ptn > header.length-1 then begin
        new_ptn := 0;
        cur_ptn := 0;
      end;
    end;
  end;
  for n := 0 to maxchn-1 do begin
    if channels[n].bar > 1 then dec(channels[n].bar,2)
    else channels[n].bar := 0;
  end;
  new_ptn := cur_ptn;
  new_row := cur_row;
  if speed > 0 then begin
    inc(cur_tick);
    if cur_tick = 1 then begin
      get_notes;
      if port[$3da] and 8 = 8 then vrt_flag := 1;
      get_fx;
    end;
    if port[$3da] and 8 = 8 then vrt_flag := 1;
    do_fx;
    if port[$3da] and 8 = 8 then vrt_flag := 1;
  end;
end;

procedure modint; interrupt;
{This happens bpm*4/10 times per second (50hz if vblank).}
begin
  asm sti end;
  if port[$3da] and 8 = 8 then vrt_flag := 1;
  inc(time_counter2);
  updatenotes;
  o_int_tick := int_tick;
  int_tick := int_tick + int_rate;
  if o_int_tick > int_tick then begin
    inc(time_counter);
    asm
      cli
      pushf
      call oldint
    end;
  end
  else
    asm
      mov  al,20h
      out  20h,al  {send EOI}
    end;
end;

{$s+}
procedure load_MOD(s : string;debug : boolean);
var
f : file;

procedure set_up_modheader;
var
chn : integer;
begin
  header.samples := 31;
  header.name[0] := #20;
  move(misc_buf[0],header.name[1],20);
  header.tag := '    ';
  move(misc_buf[1080],header.tag,4);
  chn := maxchn;
  if header.tag = 'M.K.' then chn := 4
  else if header.tag = 'M!K!' then chn := 4
  else if header.tag = '6CHN' then chn := 6
  else if header.tag = '8CHN' then chn := 8
  else if header.tag = '12CH' then chn := 12
  else begin
    header.samples := 15;
    chn := 4;
  end;
  if chn > maxchn then begin
    mod_error := 1;
    exit;
  end;
  if header.samples = 15 then begin
    move(misc_buf[472],orders[0],128);
    seek(f,600);
    header.length := misc_buf[470];
    header.chns := 4;
  end else begin
    header.length := misc_buf[950];
    move(misc_buf[952],orders[0],128);
    if debug then writeln('Tag: ',header.tag);
  end;
  header.chns := chn;
end;

procedure mod_sample_info;
var
n : integer;
maxi : integer;
begin
  for n := 0 to 31 do begin
    fillchar(samples[n].name,22,0);
    samples[n].length := 0;
    samples[n].ftune := 0;
    samples[n].volume := 0;
    samples[n].loopstart := 0;
    samples[n].loopend := 0;
  end;
  for n := 1 to header.samples do begin
    move(misc_buf[(n-1)*30+20],samples[n].name[1],22);
    samples[n].name[23] := #0;
    samples[n].length := 2*swap(misc_buf2^[(n-1)*15+21]); {n*30+42}
    samples[n].ftune := misc_buf[(n-1)*30+44];
    samples[n].volume := misc_buf[(n-1)*30+45];
    samples[n].loopstart := 2*swap(misc_buf2^[(n-1)*15+23]);  {n*30+46}
    samples[n].loopend := 2*swap(misc_buf2^[(n-1)*15+24]);  {n*30+48}
    if samples[n].loopend < 3 then begin
      samples[n].loopend := 0;
      samples[n].loopstart := 0;
    end;
    inc(samples[n].loopend,samples[n].loopstart);
    if samples[n].loopend > samples[n].length then
      samples[n].loopend := samples[n].length;
  end;
end;

procedure read_ptn(n : word);
var
row,note : integer;
w,w2,i : word;
b : byte;
mchn : byte;

begin
  mchn := header.chns;
  blockread(f,misc_buf,256*mchn);
  for row := 0 to 63 do
    for note := 0 to mchn-1 do begin
      w := misc_buf2^[row*(2*mchn)+note*2];
      w2 := misc_buf2^[row*(2*mchn)+note*2+1];
      asm
        mov  cx,w
        and  cl,15
        xchg cl,ch
        and  cx,0fffh
        mov  i,cx
      end;
      patterns[n]^[row,note].per := i;
      asm
        mov  al,byte ptr w2
        shr  al,4
        mov  ah,byte ptr w
        and  ah,11110000b
        or   al,ah
        xor  ah,ah
        mov  i,ax
      end;
      patterns[n]^[row][note].sample := i;
      patterns[n]^[row][note].fx := lo(w2) and 15;
      patterns[n]^[row][note].fxdata := hi(w2);
      i := patterns[n]^[row,note].per;
      w := 0;
      b := 0;
      while b = 0 do begin
        inc(w);
        if (w > 48) or (i = per_table[0,w]) then b := 1;
      end;
      if w <= 48 then patterns[n]^[row,note].note := w
      else patterns[n]^[row,note].note := 0;
    end;
end;

procedure load_patterns;
var
num_ptn : longint;
n : word;
m_ptn : integer;
begin
  if debug then write('Loading patterns');
  num_ptn := 0;
  for n := 0 to 127 do if orders[n] > num_ptn then begin
    if orders[n] > 127 then begin
      mod_error := 2;
      exit;
    end else num_ptn := orders[n];
  end;
  max_ptn := num_ptn+1;
  for n := 0 to max_ptn-1 do begin
    if maxavail < 256*header.chns then begin
      mod_error := 3;          {if error then release memory allocated}
      if n >= max_ptn-2 then for n := 0 to max_ptn-2 do dispose(patterns[n]);
      exit;
    end;
    if debug then write('.');
    new(patterns[n]);
    read_ptn(n);
  end;
  if debug then writeln;
end;

procedure load2gus(len : word);
var
{n : word;
addlo,addhi : word;}
l : longint;

begin
  l := top_addr;
  asm
    mov  di,len
    mov  si,offset misc_buf
@@1:
    {AddLo := L AND $FFFF;
    AddHi := longint(L and $ff0000) shr 16;}
      mov  ax,word ptr l
      mov  cx,ax      {cx=addlo}
      mov  ax,word ptr l+2
      and  ax,0ffh
      mov  bx,ax   {bx=addhi}

      mov  dx,command   {Port [command] := $43;}
      mov  al,43h
      out  dx,al

      mov  dx,data_low  {Portw[data_low] := AddLo;}
      mov  ax,cx
      out  dx,ax

      mov  dx,command    {Port [command] := $44;}
      mov  al,44h
      out  dx,al

      mov  dx,data_high
      mov  ax,bx
      out  dx,ax        {Port [data_high] := AddHi;}

      add  word ptr l,1     {inc(l,1);}
      adc  word ptr l+2,0

    mov  dx,dram_io      {Port [dram_io] := misc_buf[n];}
    outsb

    dec  di
    jnz  @@1
  end;
  inc(top_addr,len);
end;

procedure load_sample(num : word);
const
block = 4096;
var
w : word;
fl,l : word;
len : longint;

begin
  if debug then write('.');
  guspoke(top_addr,0);
  inc(top_addr);
  guspoke(top_addr,0);
  inc(top_addr);
  len := samples[num].length+top_addr;
  if (len > gus_bank+$40000) and (top_addr < gus_bank+$40000) then begin
    gus_bank := gus_bank+$40000;
    top_addr := gus_bank;
  end;

  samples[num].addr := top_addr;
  gus_addr[num] := top_addr;
  if samples[num].length < 1 then exit;
  {blockread(f,w,2);}  {read amiga repeat bytes}
  fl := (samples[num].length) div block;
  l := (samples[num].length) mod block;
  if fl > 0 then for w := 1 to fl do begin
    blockread(f,misc_buf,block);
    load2gus(block);       {load in 4kb blocks}
  end;
  if l > 0 then begin
    blockread(f,misc_buf,l);
    load2gus(l);           {load remainder}
  end;
  if samples[num].loopend > 2 then begin
    guspoke(top_addr,guspeek(gus_addr[num]+samples[num].loopstart));
    guspoke(gus_addr[num]+samples[num].loopend+1,
            guspeek(gus_addr[num]+samples[num].loopstart));
    inc(top_addr);
  end;
end;

var
i : integer;
l : longint;

begin
  gus_bank := 0;
  assign(f,s);
  {$i-}
  reset(f,1);
  blockread(f,misc_buf,1084);  {read module header}
  i := ioresult;
  if i <> 0 then begin
    mod_error := 2;
    exit;
  end;
  set_up_modheader;
  if mod_error <> 0 then exit;
  mod_sample_info;
  load_patterns;
  if mod_error <> 0 then exit;
  if debug then write('Loading samples');
  for i := 0 to 31 do load_sample(i);
  if debug then writeln;
  close(f);
  {$i+}
end;

procedure free_mod;
var
n,i : word;
begin
  for n := max_ptn-1 downto 0 do dispose(patterns[n]);
  top_addr := 16;
  for n := 0 to 31 do with samples[n] do begin
    addr := 0;
    for i := 0 to sizeof(name) do name[i] := #0;
    length := 0;
    loopstart := 0;
    loopend := 0;
    ftune := 0;
    volume := 0;
  end;
  gus_bank := 0;
end;

procedure init_mod;
var
n,i : integer;
l : longint;

begin
  vrt_flag := 0;
  misc_buf2 := @misc_buf;
  for n := 10 to 1050 do begin
       {gusperiod:=586580935 div (amigaperiod * (divisor div 100 shl 4))}
       {divisor = 44100}
    {l := 7093789 div (n*2);
    l := l div 40;}
    l := n;
    l := 586580935 div (l * 7056);
    periods[n] := l;
    {hz = 7093789.2/(per*2)}
  end;
  for n := 0 to 255 do orders[n] := 0;
  for n := 0 to maxchn-1 do begin
    channels[n].vol := 64;
    channels[n].per := 0;
    channels[n].dper := 0;
    channels[n].sample := 0;
    channels[n].pan := 7;  {middle}
    channels[n].note := 0;
  end;
  for n := 0 to 31 do with samples[n] do begin
    addr := 0;
    for i := 0 to sizeof(name) do name[i] := #0;
    length := 0;
    loopstart := 0;
    loopend := 0;
    ftune := 0;
    volume := 0;
  end;
  for n := 0 to 128 do patterns[n] := nil;
  for n := 1 to 14 do gussetvolume(n,0);
  for n := 1 to 14 do gusstopvoice(n);
  cur_ptn := 0;
  cur_row := 0;
  new_ptn := 0;
  new_row := 0;
  cur_tick := 0;
  for n := 0 to 31 do guspoke(n,0);
  top_addr := 16;
  gus_bank := 0;
  vblank := false;
  getintvec(8,@oldint);
end;

procedure set_timer(ticks : word);
begin
  asm cli end;
  port[$43] := $36;
  port[$40] := lo(ticks);
  port[$40] := hi(ticks);
  asm sti end;
end;

procedure stop_playing;
var
n : integer;
begin
  int_rate := 65535;
  set_timer(65535);
  setintvec(8,@oldint);
  for n := 1 to maxchn do GusStopVoice(n);
end;

procedure start_playing;
var
n : integer;
begin
  for n := 0 to maxchn-1 do begin
    channels[n].vol := 0;
    channels[n].per := 428;
    channels[n].sample := 0;
    channels[n].pan := 7;  {middle}
    channels[n].on := 1;
    channels[n].dper := 428;
    channels[n].bar := 0;
    channels[n].fx := 255;
    channels[n].fxdata := 0;
    channels[n].fx_sl2 := 0;
    channels[n].fx_vib := 0;
    channels[n].vib_cnt := 0;
    channels[n].vib_wave := 0;
    channels[n].note := 0;
    channels[n].hit := 0;
    channels[n].no_fx := 0;
    channels[n].start_fx := 0;
    channels[n].arp1 := 0;
    channels[n].arp2 := 0;
    channels[n].arp_cnt := 0;
  end;
  speed := 6;
  nspeed := 6;
  tempo := 125;
  channels[0].pan := 7-def_pan;
  channels[1].pan := 7+def_pan;
  channels[2].pan := 7+def_pan;
  channels[3].pan := 7-def_pan;
  if maxchn > 4 then for n := 4 to maxchn-1 do
    channels[n].pan := channels[n-4].pan;
  if maxchn > 8 then for n := 8 to maxchn-1 do
    channels[n].pan := channels[n-8].pan;
  jump := 0;
  int_tick := 0;
  cur_ptn := 0;
  cur_row := 0;
  new_ptn := 0;
  new_row := 0;
  cur_tick := 0;
  time_counter := 0;
  time_counter2 := 0;
  asm cli end;
  setintvec(8,@modint);
  int_rate := 1193182 div 50;
  set_timer(int_rate);
  asm sti end;
end;

begin
end.
Published in: Pascal
Download

Related snippets