Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/AMOD095.ZIP/ADNMOD.PAS

Pascal/Delphi Source File | 1995-12-21 | 54KB | 2,274 lines

{$m 6000,60000,60000}
uses crt,dos,modunit,modtypes,memunit,list,txt3d;
const
_c1 = 0;
_Db1 = 1;
_D1 = 2;
_Eb1 = 3;
_E1 = 4;
_F1 = 5;
_Gb1 = 6;
_G1 = 7;
_Ab1 = 8;
_A1 = 9;
_Bb1 = 10;
_B1 = 11;

_c2 = 0+16;
_Db2 = 1+16;
_D2 = 2+16;
_Eb2 = 3+16;
_E2 = 4+16;
_F2 = 5+16;
_Gb2 = 6+16;
_G2 = 7+16;
_Ab2 = 8+16;
_A2 = 9+16;
_Bb2 = 10+16;
_B2 = 11+16;

_c3 = 0+32;
_Db3 = 1+32;
_D3 = 2+32;
_Eb3 = 3+32;
_E3 = 4+32;
_F3 = 5+32;
_Gb3 = 6+32;
_G3 = 7+32;
_Ab3 = 8+32;
_A3 = 9+32;
_Bb3 = 10+32;
_B3 = 11+32;

col_backr = 0;
col_backg = 0;
col_backb = 10;
col_back = 2;
col_flash = 20;
flash_val : integer= 0;
strobo_speed : integer = 8;

note_txt : array[0..15] of string[2] =
             ('C-','C#','D-','D#','E-','F-','F#','G-','G#','A-','A#','B-',
             '??','??','??','??');

hex_tbl : array[0..15] of char = ('0','1','2','3','4','5','6','7',
                                  '8','9','A','B','C','D','E','F');
fx_txt : array[0..25] of string[3] = (
         'ARP','PR^','PRv','TON','VIB','T&S',
         'V&S','trm','PAN','SO=','VLs','JMP',
         'VL=','BRK','EFX','SPD','SPD','PRv',
         'PR^','PRv','PR^','FVL','TRG','GVL','!!!','!!!');

s3mfx_txt : array[0..23] of char = (
         'J','?','?','G','H','L','K','R','X','O',
         '?','B','-','C','S','T','A','E','F','?',
         '?','D','Q','V');

efx_txt : array[0..15] of string[4] = (
         'filt','FPR^','FPRv','glis','vibf',
         'FTUN','LOOP','trmf','PAN=','TRIG',
         'FVL^','FVLv','NCUT','NDEL','PDEL',
         'funk');

savertime : integer = 18*60*5;

defpan : array[0..31] of integer =
  (3,12,12,3,3,12,12,3,3,12,12,3,3,12,12,3,3,12,12,3,3,12,12,3,3,12,12,3,3,12,12,3);
pan_sign : array[0..31] of integer =
  (-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,-1,1,1,-1);
pan_mode : boolean = false;
pan_speed : integer = 16;
pan_cnt : integer = 16*4;
pan_inc : integer = 1;
qualitymode : boolean = false;
lockquality : boolean = false;
keybled : boolean = true;

  temp_path : string = 'c:\';
  unzip_opt = ' -o';

{$i compdate}   {Remove this if you don't have compdate.sys driver}
{$i adnpic1.inc}
{$i adnpic2.inc}
{$i adnpic3.inc}
{$i adnpic4.inc}
{$i adnpic5.inc}
{$i adnpic6.inc}

var
  gusmem : longint;
  start_sample,cur_sample,play_sample : integer;
  cur_octave : integer;
  old_row : integer;
  mod_name : string;
  pause : byte;
  oldintfc,oldint8,oldint9 : procedure;
  alt_tab,int8use : boolean;
  strobo_sam : array[0..99] of boolean;
  strobo_val : integer;
  strobo_col : array[1..3] of integer;
  strobo_fx : boolean;
  help : boolean;
  {golmap1,golmap2 : array[0..51,0..81] of byte;}
  golmap1 : array[0..51,0..81] of byte absolute $b800:8000;
  golmap2 : array[0..51,0..81] of byte absolute $b800:13000;
  normpal,pal : array[0..63,0..2] of byte;
  normkbf : byte;
  int_cnt : integer;
  start_chn : integer;

  lpic : pointer;
  listpic : ^t_memarray;
  flist : t_list;
  strlist : array[0..maxline+1] of string[20];
  typelist : array[0..maxline+1] of integer;
  org_path,old_path,cur_path : string;
  drives : array[1..28] of boolean;
  new_mod,archive : boolean;
  old_st3_per : array[0..15] of integer;

{$s-}
procedure hide_cursor; assembler;
asm
  mov  ax,0100h
  mov  cx,2607h
  int  10h
end;

procedure show_cursor; assembler;
asm
  mov  ax,0100h
  mov  cx,2607h
  int  10h
end;

procedure wait_vr; assembler;
asm
  mov  dx,3dah
@@1:
  in   al,dx
  test al,8
  jz   @@1
end;

procedure wait_novr; assembler;
asm
  mov  dx,3dah
@@1:
  in   al,dx
  test al,8
  jnz  @@1
end;

procedure fillword(var p;count : word;value : word); assembler;
asm
  mov  es,word ptr p+2
  mov  di,word ptr p
  mov  cx,count
  mov  ax,value
  rep  stosw
end;

procedure rmove(var source,target; count : word); assembler;
asm
  mov  es,word ptr target+2
  mov  di,word ptr target
  add  di,count
  mov  si,word ptr source
  add  si,count
  push ds
  mov  ds,word ptr source+2
  mov  cx,count
  std
  rep  movsb
  cld
  pop  ds
end;

procedure setvgapal(pal,col1,col2,col3 : byte); assembler;
asm
  cli
  mov  dx,3c8h
  mov  al,pal
  out  dx,al
  inc  dx
  mov  al,col1
  out  dx,al
  mov  al,col2
  out  dx,al
  mov  al,col3
  out  dx,al
  sti
end;

procedure set_scr_ofs(ofs : word); assembler;
asm
  cli
  mov  bx,ofs
  mov  dx,$3d4
  mov  al,0Ch       {Start address high}
  out  dx,al
  inc  dx
  mov  al,bh
  out  dx,al
  dec  dx
  mov  al,0Dh      {Start address high}
  out  dx,al
  inc  dx
  mov  al,bl
  out  dx,al
  sti
end;

procedure line_comp(lc : word);
var
b : byte;
begin
  port[$3d4] := 7;
  if lc and 256 > 0 then b := 31
  else b := 15;
  port[$3d5] := b;
  port[$3d4] := 9;
  port[$3d5] := port[$3d5] and $bf;
  port[$3d4] := $18;
  port[$3d5] := lo(lc);
end;

procedure getpal(p : pointer); assembler;
asm
  cld
  cli
  mov  es,word ptr p+2
  mov  di,word ptr p
  xor  ax,ax
  mov  dx,3c7h
  out  dx,al
  mov  dx,3c9h
  mov  cx,64*3
@@1:
  in   al,dx
  stosb
  loop @@1
  sti
end;

procedure setpal(p : pointer); assembler;
asm
  cld
  cli
  push ds
  mov  ds,word ptr p+2
  mov  si,word ptr p
  xor  ax,ax
  mov  dx,3c8h
  out  dx,al
  inc  dx
  mov  cx,64*3
@@1:
  lodsb
  out  dx,al
  loop @@1
  pop  ds
  sti
end;

function fixgetmem(p : pointer) : pointer;
var
hi,lo : word;
p2 : pointer;
begin
  asm
    mov  ax,word ptr p
    mov  lo,ax
    mov  ax,word ptr p+2
    mov  hi,ax
  end;
  if lo <> 0 then hi := hi+(lo+15) div 16;
  asm
    mov  ax,0
    mov  word ptr p2,ax
    mov  ax,hi
    mov  word ptr p2+2,ax
  end;
  fixgetmem := p2;
end;
{$s-}
procedure free_ticks; assembler;
asm
  int  28h
end;

function peekkey : char;
var
c : char;
begin
  c := #0;
asm
  mov  ah,1
  int  16h
  jnz   @@end
  mov  ax,0
@@end:
  mov  c,al
end;
  peekkey := c;
end;

procedure fillattr(x,y,xl : integer; attr : byte); assembler;
asm
  mov  ax,0b800h
  mov  es,ax
  mov  ax,y
  mov  di,ax
  shl  ax,7
  shl  di,4
  add  di,x
  add  di,di
  add  di,ax
  sub  di,161
  mov  cx,xl
  mov  al,attr
@@1:
  mov  es:[di],al
  add  di,2
  loop @@1
end;

procedure fastwrite(x,y : word;s : string);
begin
asm
    push ds
    lea  si,s
    mov  ax,ss
    mov  ds,ax
    mov  ax,0b800h
    mov  es,ax
    lodsb
    cmp  al,0
    je   @@end
    mov  cl,al
    xor  ch,ch
    mov  di,y
    dec  di
    dec  x
    mov  ax,160
    mul  di
    mov  di,ax
    add  di,x
    add  di,x
@@1:
    movsb
    inc  di
    loop @@1
@@end:
    pop  ds
end;
end;

procedure fastwritel(x,y,l : word;s : string); assembler;
asm
    push ds
    mov  cx,l
    cmp  cx,0
    je   @@end
    mov  si,word ptr s
    inc  si
    mov  ds,word ptr s+2
    mov  ax,0b800h
    mov  es,ax
    mov  ax,y
    mov  di,ax
    shl  ax,7
    shl  di,4
    add  di,x
    add  di,di
    add  di,ax
    sub  di,162
    mov  ah,$ff
@@1:
    lodsb
    test al,0ffh
    je   @@3
@@2:
    and  al,ah
    stosb
    inc  di
    loop @@1
    jmp  @@end
@@3:
    xor  ah,ah
    jmp  @@2
@@end:
    pop  ds
end;

procedure scroll_up(y1,yl : word); assembler;
asm
  mov  ax,y1
  mov  cx,160
  mul  cx
  mov  y1,ax
  push ds
  mov  ax,0b800h
  mov  ds,ax
  mov  es,ax
  mov  si,y1
  add  si,160
  mov  di,y1
  mov  bx,yl
@@1:
  mov  cx,80
  rep  movsw
  dec  bx
  jnz  @@1
  pop  ds
end;

function byte2hex(b : byte) : string;
begin
  byte2hex := hex_tbl[b shr 4]+hex_tbl[b and 15];
end;

function nibb2hex(b : byte) : char;
begin
  nibb2hex := hex_tbl[b and 15];
end;

function int2str(i,n : longint) : string;
var
s : string;
begin
  str(i:n,s);
  int2str := s;
end;

function word2str(i,n : word) : string;
var
s : string;
begin
  str(i:n,s);
  word2str := s;
end;

procedure showbyte(x,y : integer;b : byte); assembler;
asm
  dec  y
  dec  x
  mov  ax,0b800h
  mov  es,ax
  mov  di,y
  mov  ax,160
  mul  di
  mov  di,ax
  add  di,x
  add  di,x
  mov  ah,0
  mov  al,b
  mov  cl,10
  div  cl
  add  ax,3030h
  mov  es:[di],al
  add  di,2
  mov  es:[di],ah
end;

procedure showint4(x,y : integer;w : word); assembler;
asm
  dec  y
  dec  x
  mov  ax,0b800h
  mov  es,ax
  mov  di,y
  mov  ax,di
  shl  ax,5
  shl  di,7
  add  di,ax
  add  di,x
  add  di,x
  xor  dx,dx
  mov  ax,w
  mov  cx,1000
  div  cx
  add  al,30h
  mov  es:[di],al
  mov  ax,dx
  mov  cl,100
  div  cl
  mov  bx,ax
  add  al,30h
  mov  es:[di+2],al
  mov  al,bh
  mov  ah,0
  mov  cl,10
  div  cl
  add  ax,3030h
  mov  es:[di+4],al
  mov  es:[di+6],ah
end;

procedure showhex(x,y : integer;b : byte);
begin
  mem[$b800:(y-1)*160+2*x-2] := byte(hex_tbl[b shr 4]);
  mem[$b800:(y-1)*160+2*x] := byte(hex_tbl[b and 15]);
end;

procedure show_pic(ofs,dest : word;pic : pointer); assembler;
asm
  mov  ax,dest
  mov  es,ax
  mov  dx,0
  mov  ax,700h
  mov  cx,0
  mov  di,ofs
  push ds
  mov  si,word ptr pic
  mov  ds,word ptr pic+2
@@start:
  lodsb
  cmp  al,8
  jae  @@char
  cmp  al,0
  je   @@end
  cmp  al,1
  je   @@attr
  cmp  al,2
  je   @@pack
  cmp  al,3
  je   @@space
  jmp  @@start
@@attr:
  lodsb
  mov  ah,al
  jmp  @@start
@@space:
  lodsb
  mov  cl,al
  mov  al,32
  rep  stosw
  jmp  @@start
@@pack:
  lodsb
  mov  cl,al
  lodsb
  rep  stosw
  jmp  @@start
@@char:
  stosw
  jmp  @@start
@@end:
  pop  ds
end;

procedure normscr;
var
n : integer;
begin
  hide_cursor;
  setvgapal(col_back,col_backr,col_backg,col_backb);
  show_pic(8000+0,$b800,@image1);
  show_pic((50+5+header.usedchns)*160,$b800,@image2);
  show_pic(160,$b800,@image3);
  for n := 0 to header.usedchns do move(image4,mem[$b800:(4+n)*160+8000],160);
  line_comp((header.usedchns+9)*8);
  set_scr_ofs(4000);
  if qualitymode then begin
    fastwrite(8,51,'QUALITY MODE');
    fastwrite(62,51,'QUALITY MODE');
  end;
end;

function note2txt(note : byte) : string;
var
o,n : byte;
begin
  o := note shr 4;
  n := note and 15;
  if note = 255 then note2txt := '...'
  else if note = 254 then note2txt := '^^^'
  else note2txt := note_txt[n]+char(o+48);
end;

procedure makepertbl;
var
n,i : integer;
begin
  if not qualitymode then move(old_st3_per,st3_per,sizeof(st3_per))
  else for n := 0 to 15 do begin
    st3_per[n] := round(old_st3_per[n]*(0.975+random(10)/200));
  end;
end;

{$s-}
procedure bar(x,y,l : integer;c : char); assembler;
asm
  cld
  mov  ax,0b800h
  mov  es,ax

  mov  di,y
  dec  di
  mov  ax,160
  mul  di
  dec  x
  add  ax,x
  add  ax,x
  mov  di,ax
  cmp  l,0
  jz   @@3
  mov  cx,l
  mov  al,c
@@1:
  stosb
  inc  di
  dec  cx
  jnz  @@1
@@3:
  mov  cx,16
  sub  cx,l
  cmp  cx,0
  je   @@end
  mov  al,32
@@2:
  stosb
  inc  di
  dec  cx
  jnz  @@2
@@end:
end;

procedure show_sample(sam,x,y : integer);
begin
  fillattr(x,y,3,1);
  fastwrite(x,y,int2str(sam,2));
  if strobo_sam[sam] then fillattr(x,y,30,6)
  else fillattr(x+3,y,27,7);
  if sam = cur_sample then fillattr(x,y,3,15);
  fastwritel(x+4,y,26,samples[sam].name);
  fastwrite(x+31,y,word2str(samples[sam].length,5));
  fastwrite(x+39,y,word2str(samples[sam].loopstart,5));
  fastwrite(x+47,y,word2str(samples[sam].loopend,5));
  if header.modtype = mt_mod then begin
    if samples[sam].ftune > 7 then
      fastwrite(x+56,y,int2str(integer(samples[sam].ftune or $fff0),2))
    else fastwrite(x+56,y,int2str(samples[sam].ftune,2));
  end
  else fastwrite(x+54,y,int2str(samples[sam].c4spd,5));
  fastwrite(x+62,y,int2str(samples[sam].volume,2));
end;

const
ycol : array[0..73] of byte =
(1,1,
9,9,
11,11,
15,15,
11,11,
9,9,
1,1,
9,9,
11,11,
15,15,
11,11,
9,9,
1,1,
9,9,
11,11,
15,15,
11,11,
9,9,
1,1,
9,9,
11,11,
15,15,
11,11,
9,9,
1,1,
9,9,
11,11,
15,15,
11,11,
9,9,
1,1,
9,9,
11,11,
15,15,
11,11,
9,9,
1,1);

const
scroll_txt : string = 'Welcome to ADNMOD 0.95! The best mod/s3m player '+
                      'for TP ever :)'+
                      '                  '+
                      'REMEMBER: You MUST send me e-mail if you use this program!'+
                      '                  '+
                      'Greets fly out to: Psyko, Distance, Jaba, Black Hole,'+
                      ' Solar, flap, Wog & RedT';
var
scroll_msg : array[0..1000] of char;
scroll_len : integer;

procedure scrsaver;
var
n,count : integer;

procedure showgol(yc : integer); assembler;
asm
  push ds
  mov  ax,0b800h
  mov  es,ax
  mov  ds,ax
  mov  di,1
  mov  si,offset golmap1+82+2
  mov  dx,49
@@2:
  mov  cx,80
  pop  ds
  mov  bx,dx
  add  bx,yc
  mov  ah,[bx+offset ycol]

  push ds
  mov  bx,es
  mov  ds,bx
@@1:
  mov  al,ds:[si]
  inc  si
  shl  al,5
  add  al,ah
  mov  es:[di],al
  add  di,2
  dec  cx
  jnz  @@1
  add  si,2
  dec  dx
  jnz  @@2
  pop  ds
end;

procedure muunnagol;
begin
  asm
     push ds
     mov  ax,0b800h
     mov  ds,ax
     mov  es,ax
     mov  di,offset golmap2+82+1
     mov  si,offset golmap1+82+1
     mov  dx,49
@@yloop:

     mov  cx,81-1
     mov  bx,81
     inc  si
     inc  di
@@xloop:
     mov  al,[si-81-2]
     add  al,[si-81-1]
     add  al,[si-81]
     add  al,[si-1]
     add  al,[si+1]
     add  al,[si+81]
     add  al,[si+81+1]
     add  al,[si+81+2]
     mov  ah,[si]
     cmp  al,3
     je   @@live
     cmp  ah,0
     je   @@die_scum
     cmp  al,2
     je   @@live
@@die_scum:
     xor  al,al
     stosb
     jmp  @@loop_end
@@live:
     mov  al,1
     stosb
@@loop_end:
     inc  si
     loop @@xloop
     inc  si
     inc  di

     dec  dx
     jnz  @@yloop
@@end:
     pop  ds
end;
  move(golmap2,golmap1,sizeof(golmap1));
end;

procedure plot(x,y : integer);
var
_x,_y : integer;
begin
  for _y := -2 to 2 do for _x := -2 to 2 do
    golmap1[y+_y,x+_x] := random(2);
end;

procedure initgol;
var
n : integer;
begin
  fillchar(golmap1,sizeof(golmap1),0);
  fillchar(golmap2,sizeof(golmap2),0);
  for n := 1 to 20 do plot(random(70)+5,random(40)+5);
end;

procedure fadeout;
var
n,i : integer;
begin
  for n := 30 downto 0 do begin
    wait_vr;
    for i := 0 to 63 do
      setvgapal(i,word(pal[i,0]*n) div 30,
                  word(pal[i,1]*n) div 30,
                  word(pal[i,2]*n) div 30);
  end;
end;

procedure fadein;
var
n,i : integer;
begin
  for n := 0 to 30 do begin
    wait_vr;
    for i := 0 to 63 do
      setvgapal(i,word(pal[i,0]*n) div 30,
                  word(pal[i,1]*n) div 30,
                  word(pal[i,2]*n) div 30);
  end;
end;

procedure scroll(sc : integer);
var
n : integer;
begin
  for n := 0 to 79 do memw[$b800:49*160+n*2] := 15*256+byte(scroll_msg[sc+n]);
end;

type
ta = array[0..50000] of byte;
pa = ^ta;

var
yc : integer;
pspeed,i : integer;
obj_kx,obj_ky,obj_kz : integer;
buf,p : pointer;
sc,sc2 : integer;

begin
  scroll_len := byte(scroll_txt[0])+102;
  fillchar(scroll_msg,sizeof(scroll_msg),0);
  move(scroll_txt[1],scroll_msg[82],scroll_len-102);
  getmem(p,16000+16);
  buf := ptr(seg(p^)+1,0);
  fillchar(buf^,16000,0);
  txt3d.scr_seg := seg(buf^);
  obj_kx := 0;
  obj_ky := 0;
  obj_kz := 0;
  pan_cnt := integer(pan_cnt*5) div 7;
  pspeed := integer(pan_speed*5) div 7;
  if pspeed < 1 then pspeed := 1;
  getpal(@pal);
  fadeout;
  fillchar(mem[$b800:0],160*100,0);
  textmode(font8x8+co80);
  setfont;
  hide_cursor;
  init3d;
  l3d_adnmod;
  initgol;
  count := 0;
  yc := 0;
  matriisi(matrix,0,0,0);
  rotatep;
  time_counter := 0;
  time_counter2 := 0;
  time_counter3 := 0;
  sc := 0;
  sc2 := 0;
  repeat
    wait_vr;
    mix;
    free_ticks;
    if time_counter > 0 then begin
      inc(yc);
      if yc > 10 then yc := 0;
      showgol(yc);
      muunnagol;
      inc(sc2);
      if sc2 > scroll_len*2 then sc2 := 0;
      sc := sc2 shr 1;
      dec(time_counter);
      inc(count);
      if count mod (6*30) = 0 then case random(3) of
        0 : l3d_cube;
        1 : l3d_pyramid;
        2 : l3d_adnmod;
      end;
      if count > 18*20 then begin
        time_counter := 0;
        count := 0;
        initgol;
      end;
    end;
    scroll(sc);
    free_ticks;
    hide;
    matriisi(matrix,obj_kx,obj_ky,obj_kz);
    rotatep;
    free_ticks;
    show;
    free_ticks;
    inc(obj_kx,word(time_counter3) div 7);
    inc(obj_ky,word(time_counter3) div 7);
    inc(obj_kz,word(time_counter3) div 7);
    time_counter3 := 0;
    if obj_kx > 1000 then dec(obj_kx,1000);
    if obj_ky > 1000 then dec(obj_ky,1000);
    if obj_kz > 1000 then dec(obj_kz,1000);
    if pan_mode and (time_counter2 > 0) then begin
      inc(pan_cnt,pan_inc*time_counter2);
      if (pan_cnt<=-pspeed*7-pspeed+1) or
      (pan_cnt>=pspeed*7+pspeed-1) then pan_inc := -pan_inc;
      if pan_cnt < -pspeed*7-pspeed+1 then pan_cnt := -pspeed*7;
      if pan_cnt > pspeed*7+pspeed-1 then pan_cnt := pspeed*8;
      for n := 0 to header.usedchns-1 do begin
        i := integer(pan_sign[i]*pan_cnt) div pspeed;
        if i > 0 then
          channels[n].pan := 8+i
        else channels[n].pan := 7+i;
        gussetbalance(n,channels[n].pan);
      end;
      time_counter2 := 0;
    end;
    free_ticks;
  until keypressed;
  readkey;
  freemem(p,16000+16);
  for n := 0 to 63 do setvgapal(n,0,0,0);
  fillchar(mem[$b800:0],80*100*2,0);
  textmode(co80+font8x8);
  for n := 0 to 63 do setvgapal(n,0,0,0);
  fillchar(mem[$b800:0],80*100*2,0);
  normscr;
  for n := 0 to 63 do setvgapal(n,0,0,0);
  for n := 0 to 24-header.usedchns do show_sample(n+start_sample,9,n+17);
  old_row := 666;
  fadein;
end;

procedure show_chn(chn,st : byte);
var
fx,fxdata : byte;
start : integer;
n : integer;
begin
  start := 5-st+50;
  inc(chn,st);
  fx := channels[chn].fx;
  fxdata := channels[chn].fxdata;
  if channels[chn].on = 1 then
    fastwritel(3,chn+start,27,samples[channels[chn].sample].name)
  else fastwritel(3,chn+start,27,'     ---MUTED---             ');
  fastwrite(34,chn+start,int2str(channels[chn].vol,2));
  fastwritel(37,chn+start,3,note2txt(channels[chn].note));
  fastwrite(41,chn+start,int2str(channels[chn].per,4));
  fastwrite(46,chn+start,int2str(channels[chn].dper,4));
  fastwrite(58,chn+start,int2str(shortint(channels[chn].pan)-7,2));
  if fx = 14 then
    fastwritel(51,chn+start,5,efx_txt[fxdata shr 4]+nibb2hex(fxdata and 15))
  else if ((fx < 255) and (fx >0)) or ((fx = 0) and (fxdata > 0)) then
    fastwritel(51,chn+start,5,fx_txt[fx]+byte2hex(fxdata))
  else fastwritel(51,chn+start,5,'     ');
  bar(63,chn+start,(channels[chn].bar+2) shr 2,'≈');
  if channels[chn].hit <> 0 then begin
    fillattr(3,chn+start,27,15);
    fillattr(34,chn+start,26,15);
    channels[chn].hit := 2;
  end else begin
    fillattr(3,chn+start,27,7);
    fillattr(34,chn+start,26,7);
  end;
end;

procedure show_row(ptn,row : integer);
const
wid = 16;
x = 12;
var
  n : integer;
  sam : integer;
  vol,fx,fxdata : byte;
  chn : integer;
  st : integer;
  _ptn : p_pattern;
  s : string[2];
begin
  _ptn := virt_getptn(ptn);
  st := 13;
  fastwrite(8,st,byte2hex(row)+':');
  for n := 0 to 3 do begin
    chn := start_chn+n;
    fastwrite(n*wid+x+1,st,
      note2txt(_ptn^[row*header.chns+chn].note)+' ');
    sam := _ptn^[row*header.chns+chn].sample;
    if sam > 0 then fastwrite(n*wid+x+5,st,byte2hex(sam)+' ')
    else fastwrite(n*wid+x+5,st,'.. ');
    fx := _ptn^[row*header.chns+chn].fx;
    fxdata := _ptn^[row*header.chns+chn].fxdata;
    if (fx=0) and (fxdata = 0) then fx := 255;
    if header.modtype = mt_mod then begin
      case fx of
        0 : if fxdata > 0 then
          fastwrite(n*wid+x+9,st,fx_txt[fx]+byte2hex(fxdata))
        else fastwrite(n*wid+x+9,st,'     ');
        1..$D : fastwrite(n*wid+x+9,st,fx_txt[fx]+byte2hex(fxdata));
        $E : fastwrite(n*wid+x+9,st,
             efx_txt[fxdata shr 4]+nibb2hex(fxdata and 15));
        $F : fastwrite(n*wid+x+9,st,fx_txt[fx]+byte2hex(fxdata));
        else fastwrite(n*wid+x+9,st,'     ');
      end;
    end
    else if header.modtype = mt_s3m then begin
      vol := _ptn^[row*header.chns+chn].vol;
      if vol <> 255 then begin
        s := int2str(vol,2);
        if s[1] = ' ' then s[1] := '0';
      end else s := '  ';
      fastwrite(n*wid+x+8,st,s);
      if fx <> 255 then begin
        fastwrite(n*wid+x+11,st,s3mfx_txt[fx]);
        fastwrite(n*wid+x+12,st,byte2hex(fxdata));
      end
      else fastwrite(n*wid+x+11,st,'   ');
    end;
  end;
end;

procedure show_info(ptn:integer);
var
st : integer;
begin
  st := 50+8 + header.usedchns;
  fastwrite(30,st,int2str(amp_vol,2));
  fastwrite(41,st,int2str(speed,2));
  if not vblank then fastwrite(53,st,int2str(tempo,3)+'   ')
  else fastwrite(53,st,'VBlank');
  fastwrite(30,st+1,int2str(cur_ptn,2)+'/'+int2str(header.length-1,2));
  fastwrite(41,st+1,int2str(ptn,2)+'/'+int2str(max_ptn-1,2));
  fastwrite(53,st+1,int2str(cur_row,2));
end;

procedure updateinfo;
var
i,n : integer;
kbf : byte;
begin
  if not loaded then exit;
  wait_vr;
  if strobo_fx then for i := 0 to header.usedchns-1 do
    if (channels[i].hit = 1) and (channels[i].on <> 0) then
      if strobo_sam[channels[i].sample]=true then strobo_val := 62;
  i := strobo_val and strobo_col[3];
  if i < col_backb then i := col_backb;
  setvgapal(0,strobo_val and strobo_col[1],
              strobo_val and strobo_col[2],
              strobo_val and strobo_col[3]);
  setvgapal(2,strobo_val and strobo_col[1],
              strobo_val and strobo_col[2],
              i);
  if strobo_val > 0 then dec(strobo_val,strobo_speed);
  if strobo_val < 0 then strobo_val := 0;
  dec(flash_val);
  if flash_val<-19 then flash_val := 20;
  n := abs(flash_val)+43;
  setvgapal(col_flash,n,n,n);
  if keybled then begin
    kbf := mem[$40:$17] and 15;
    if channels[start_chn].hit=1 then kbf := kbf or $20;
    if channels[start_chn+1].hit=1 then kbf := kbf or $40;
    if channels[start_chn+2].hit=1 then kbf := kbf or $10;
    mem[$40:$17] := kbf;
    mem[$40:$18] := 0;
  end;
  if pan_mode then begin
    inc(pan_cnt,pan_inc);
    if (pan_cnt=-pan_speed*7-pan_speed+1) or
    (pan_cnt=pan_speed*7+pan_speed-1) then pan_inc := -pan_inc;
    for i := 0 to header.usedchns-1 do begin
      n := integer(pan_sign[i]*pan_cnt) div pan_speed;
      if n > 0 then
        channels[i].pan := 8+n
      else channels[i].pan := 7+n;
      gussetbalance(i,channels[i].pan);
    end;
  end;
  for i := 0 to header.usedchns-1 do show_chn(i,0);
  show_info(orders[cur_ptn]);
end;

procedure show_ptn(clear : boolean);
var
  ptn : word;
var
  i,n : integer;
  s : string;
  c : char;
  helpcnt : integer;

begin
  helpcnt := 0;
  strobo_val := 0;
  fastwrite(30,50+7+header.usedchns,header.name);
  for i := 0 to 24-header.usedchns do show_sample(i+start_sample,9,i+17);
  if clear then begin
    s := '                                                                   ';
    for i := 0 to 7 do fastwritel(8,14+50+header.usedchns+i,65,s);
  end;
  time_counter := 0;
  repeat
    updateinfo;
    free_ticks;
    ptn := orders[cur_ptn];
    time_counter2 := 0;
    if (not help) and (cur_row <> old_row) then begin
      i := cur_row;
      fillattr(13,13,61,7+2*16);
      scroll_up(4,8);
      show_row(orders[cur_ptn],i);
      old_row := cur_row;
      fillattr(13,13,61,15+2*16);
    end;
    free_ticks;
    if upcase(peekkey) = 'H' then begin
      readkey;
      time_counter := 0;
      if help then begin
        show_pic(160,$b800,@image3);
        fastwritel(30,50+7+header.usedchns,20,header.name);
        for i := 0 to 24-header.usedchns do show_sample(i+start_sample,9,i+17);
        help := false;
      end
      else begin
        help := true;
        show_pic(160,$b800,@image5);
      end;
    end;
    if time_counter > savertime then begin
      time_counter := 0;
      scrsaver;
    end;
    free_ticks;
  until keypressed;
  if help then begin
    show_pic(160,$b800,@image3);
    help := false;
  end;
  if keybled then begin
    mem[$40:$17] := mem[$40:$17] and 15;
    mem[$40:$18] := 0;
  end;
end;

{$s-,i-}
{$i tsr.inc}

{Do NOT use this!}
{procedure int9; interrupt;
var
regs : array[0..5] of longint;
n : integer;
begin
  if test8086 > 1 then asm
    db  66h
    mov  word ptr regs[0],ax
    db  66h
    mov  word ptr regs[4],bx
    db  66h
    mov  word ptr regs[8],cx
    db  66h
    mov  word ptr regs[12],dx
    db  66h
    mov  word ptr regs[16],si
    db  66h
    mov  word ptr regs[20],di
  end;
  if (mem[$40:$17] and 8 > 0) and (port[$60] = $f) then
    if alt_tab then begin
      alt_tab := false;
      fillword(mem[$b800:160*41-160*header.usedchns],(9+header.usedchns)*80,7*256);
      mem[$40:$84] := 49;
      set_scr_ofs(0);
      line_comp(128*8);
    end
    else begin
      alt_tab := true;
      if wherey > (41-header.usedchns) then begin
        for n := 0 to 40-header.chns do
          move(mem[$b800:(n+header.chns+9)*160],mem[$b800:n*160],160);
        gotoxy(wherex,41-header.chns);
        port[$3d4] := 7;
        port[$3d5] := port[$3d5] and $df;
      end;
      mem[$40:$84] := 40-header.usedchns;
      set_scr_ofs(4000);
      line_comp((9+header.usedchns)*8);
    end;
  if test8086 > 1 then asm
    db  66h
    mov  ax,word ptr regs[0]
    db  66h
    mov  bx,word ptr regs[4]
    db  66h
    mov  cx,word ptr regs[8]
    db  66h
    mov  dx,word ptr regs[12]
    db  66h
    mov  si,word ptr regs[16]
    db  66h
    mov  di,word ptr regs[20]
  end;
  asm
    pushf
    cli
    call oldint9;
  end;
end;}

procedure fwritel(x,y,l : integer;s : pointer); assembler;
asm
  push ds
  mov  ax,word ptr s+2
  mov  ds,ax
  mov  ax,0b800h
  mov  es,ax
  mov  si,word ptr s
  inc  si
  mov  cx,l
  cmp  cx,0
  jne  @@2
  ret
@@2:
  mov  di,y
  dec  di
  dec  x
  mov  ax,160
  mul  di
  mov  di,ax
  add  di,x
  add  di,x
@@1:
  movsb
  inc  di
  loop @@1
  pop  ds
end;

procedure int8; interrupt;
const
regs : array[0..5] of longint = (0,0,0,0,0,0);
n : integer = 0;
i : integer=0;
pspeed : integer=0;
p : longint = 0;
fx: byte = 0;
fxdata : byte = 0;
st : integer = 0;
begin
  asm
    pushf
    cli
    call oldint8
  end;
  dec(int_cnt);
  if (int8use = false) and (int_cnt = 0) then begin
   int8use := true;
   if test8086 > 1 then asm
     cli
     db  66h
     mov  word ptr regs[0],ax
     db  66h
     mov  word ptr regs[4],bx
     db  66h
     mov  word ptr regs[8],cx
     db  66h
     mov  word ptr regs[12],dx
     db  66h
     mov  word ptr regs[16],si
     db  66h
     mov  word ptr regs[20],di
   end;
   int_cnt := 35;
   asm sti end;
   if alt_tab then begin
    if pan_mode then begin
      pspeed := pan_speed;
      if pspeed < 1 then pspeed := 1;
      inc(pan_cnt,pan_inc);
      if (pan_cnt<=-pspeed*8+1) or
      (pan_cnt>=pspeed*8-1) then pan_inc := -pan_inc;
      if pan_cnt < -pspeed*8+1 then pan_cnt := -pspeed*7;
      if pan_cnt > pspeed*8-1 then pan_cnt := pspeed*7;
    end;
    st := 50+9+header.usedchns;
    showbyte(53,st,cur_row);
    showbyte(41,st,speed);
    showbyte(30,st,cur_ptn);
    showbyte(33,st,header.length-1);
    showbyte(41,st,orders[cur_ptn]);
    showbyte(44,st,max_ptn-1);
    for n := 0 to header.usedchns-1 do begin
      if strobo_val < 0 then strobo_val := 0;
      if strobo_fx then begin
        port[$3c8] := 0;
        port[$3c9] := strobo_val and strobo_col[1];
        port[$3c9] := strobo_val and strobo_col[2];
        port[$3c9] := strobo_val and strobo_col[3];
      end;
      dec(strobo_val,strobo_speed);
      dec(strobo_val,strobo_speed);
      if pan_mode then begin
        i := integer(pan_sign[n]*pan_cnt) div pspeed;
        if i > 0 then
          channels[n].pan := 8+i
        else channels[n].pan := 7+i;
        gussetbalance(n,channels[n].pan);
      end;
      fx := channels[n].fx;
      fxdata := channels[n].fxdata;
      p := longint(@samples[channels[n].sample].name);
      fwritel(3,n+55,27,pointer(p));
      showbyte(34,n+55,channels[n].vol);
      fwritel(37,n+55,2,@note_txt[channels[n].note and 15]);
      {fastwrite(39,n+55,nibb2hex(channels[n].note shr 4));}
      showint4(41,n+55,channels[n].per);
      showint4(46,n+55,channels[n].dper);
      showbyte(58,n+55,channels[n].pan);
      if fx = 14 then begin
        showhex(54,n+55,fxdata and 15);
        fwritel(51,n+55,4,@efx_txt[fxdata shr 4]);
      end
      else if (fx < 16) and (fx >0) then begin
        fwritel(51,n+55,3,@fx_txt[fx]);
        showhex(54,n+55,fxdata);
      end;
      if fx > 15 then fillchar(mem[$b800:(n+54)*160+50*2],10,0);
      bar(63,55+n,(channels[n].bar+2) shr 2,'≈');
      if channels[n].hit = 1 then begin
        fillattr(3,n+55,27,15);
        fillattr(34,n+55,26,15);
        if strobo_fx then
          if strobo_sam[channels[n].sample] then strobo_val := 62;
      end else begin
        fillattr(3,n+55,27,7);
        fillattr(34,n+55,26,7);
      end;
    end;
   end;
   if test8086 > 1 then asm
     db  66h
     mov  ax,word ptr regs[0]
     db  66h
     mov  bx,word ptr regs[4]
     db  66h
     mov  cx,word ptr regs[8]
     db  66h
     mov  dx,word ptr regs[12]
     db  66h
     mov  si,word ptr regs[16]
     db  66h
     mov  di,word ptr regs[20]
   end;
   int8use := false;
  end;
end;
{i+}

procedure init_dos;
var
n : integer;
begin
  directvideo := false;
  gotoxy(1,1);
  alt_tab := true;
  int_cnt := 14;
  int8use := false;
  {getintvec(9,@oldint9);}
  getintvec(dos_irq,@oldint8);
  asm
    cld
    mov  ax,0B800h
    mov  es,ax
    mov  di,0
    mov  cx,4000
    mov  ax,0720h
    rep  stosw
  end;
  mem[$40:$84] := 40-header.usedchns;
  set_scr_ofs(4000);
  line_comp((9+header.usedchns)*8);
  show_cursor;
  setpal(@normpal);
  {setintvec(9,@int9);}
  setintvec(dos_irq,@int8);
end;

procedure end_dos;
begin
  setintvec(dos_irq,@oldint8);
  {setintvec(9,@oldint9);}
end;

procedure initlist;
var
f : file;
n,i,maxdrive : integer;
s : string;
begin
  s := getenv('TEMP');
  if s <> '' then temp_path := s;
  archive := false;
  textmode(co80+font8x8);
  getdir(0,org_path);
  getdir(0,cur_path);
  fillchar(drives,sizeof(drives),0);
  drives[1] := true;
  drives[2] := false;
  for n := 3 to 28 do if diskfree(n)>-1 then drives[n] := true;

  getmem(lpic,8000);
  listpic := fixgetmem(lpic);
end;

function getmodname(s : string) : string;
var
f : file;
s2 : string;
begin
  assign(f,s);
  reset(f,1);
  blockread(f,s2[1],20);
  s2[0] := #20;
  close(f);
  getmodname := s2;
end;

procedure load;
var
dirinfo : searchrec;
n : integer;
s : string;
maxstr : integer;

begin
  maxstr := 0;
  findfirst('*.mod',anyfile,dirinfo);
  while (doserror = 0) and (maxstr < maxline) do begin
    strlist[maxstr] := dirinfo.name;
    typelist[maxstr] := t_mod;
    inc(maxstr);
    findnext(dirinfo);
  end;
  findfirst('*.s3m',anyfile,dirinfo);
  while (doserror = 0) and (maxstr < maxline) do begin
    strlist[maxstr] := dirinfo.name;
    typelist[maxstr] := t_mod;
    inc(maxstr);
    findnext(dirinfo);
  end;
  if not archive then begin
    findfirst('*.zip',anyfile,dirinfo);
    while (doserror = 0) and (maxstr < maxline) do begin
      strlist[maxstr] := dirinfo.name;
      typelist[maxstr] := t_zip;
      inc(maxstr);
      findnext(dirinfo);
    end;
    findfirst('*.*',$10,dirinfo);
    while (doserror = 0) and (maxstr < maxline) do begin
      if dirinfo.attr and $18 <> 0 then begin
        strlist[maxstr] := dirinfo.name;
        typelist[maxstr] := t_dir;
        inc(maxstr);
      end;
      findnext(dirinfo);
    end;
  end
  else begin
    strlist[maxstr] := '..';
    typelist[maxstr] := t_dir;
    inc(maxstr);
  end;
  dec(maxstr);
  if not archive then for n := 1 to 28 do if drives[n]=true then begin
    inc(maxstr);
    strlist[maxstr] := char(n+64)+':';
    typelist[maxstr] := t_drive;
  end;
  for n := 0 to maxstr do begin
    case typelist[n] of
      t_dir : s := 'DIR';
      t_zip : s := 'ARCHIVE';
      t_mod : s := getmodname(strlist[n]);
      else s := '';
    end;
    flist.insline(strlist[n],s,'',typelist[n]);
  end;
  flist.qsort;
end;

procedure unzip(s : string);
var
zippath : string;
begin
  zippath := fsearch('PKUNZIP.EXE',getenv('PATH'));
  chdir(temp_path);
  exec(zippath,s+' *.mod *.s3m '+unzip_opt);
  if doserror <> 0 then begin
    writeln('Dos error ',doserror,#7);
    delay(500);
  end;
end;

function countfiles(s : string) : integer;
var
dir : searchrec;
n : integer;
begin
  n := 0;
  findfirst(s,anyfile,dir);
  while doserror = 0 do begin
    inc(n);
    findnext(dir);
  end;
  countfiles := n;
end;

procedure delall;
var
s : searchrec;
f : file;
begin
  findfirst('*.mod',anyfile,s);
  while (doserror = 0) do begin
    assign(f,s.name);
    erase(f);
    findnext(s);
  end;
  findfirst('*.s3m',anyfile,s);
  while (doserror = 0) do begin
    assign(f,s.name);
    erase(f);
    findnext(s);
  end;
end;

procedure doit(num : integer);
var
n : integer;
begin
  if not archive then case flist.lines^[num].t of
    t_mod : begin
              clrscr;
              stop_playing;
              free_mod;
              move(old_st3_per,st3_per,sizeof(st3_per));
              writeln('Loading');
              load_mod(flist.lines^[num].s[0]);
              makepertbl;
              start_playing;
              new_mod := true;
              chdir(cur_path);
              cur_sample := 1;
              start_sample := 1;
              hide_cursor;
            end;
    t_dir : begin
              chdir(flist.lines^[num].s[0]);
              getdir(0,cur_path);
              flist.delete;
              load;
              move(listpic^,mem[$b800:0],6400);
              flist.draw;
           end;
    t_drive : begin
                chdir(flist.lines^[num].s[0]);
                getdir(0,cur_path);
                flist.delete;
                load;
                move(listpic^,mem[$b800:0],6400);
                flist.draw;
              end;
    t_zip : begin
              getdir(0,old_path);
              cur_path := temp_path;
              fillchar(mem[$b800:0],6400,0);
              textattr := 0;
              gotoxy(1,1);
              if old_path[length(old_path)]='\' then
                unzip(old_path+flist.lines^[num].s[0])
              else unzip(old_path+'\'+flist.lines^[num].s[0]);
              textattr := 7;
              n := countfiles('*.mod');
              n := n+countfiles('*.s3m');
              if n = 0 then begin
                fillchar(mem[$b800:0],8000,0);
                move(listpic^,mem[$b800:0],6400);
                hide_cursor;
                chdir(old_path);
                flist.delete;
                load;
                flist.draw;
              end
              else if n = 1 then begin
                archive := false;
                flist.delete;
                load;
                stop_playing;
                free_mod;
                move(old_st3_per,st3_per,sizeof(st3_per));
                writeln('Loading');
                load_mod(flist.lines^[1].s[0]);
                makepertbl;
                start_playing;
                delall;
                new_mod := true;
                fillchar(mem[$b800:0],8000,0);
                {move(listpic^,mem[$b800:0],6400);}
                cur_sample := 1;
                start_sample := 1;
                hide_cursor;
                chdir(old_path);
                flist.delete;
              end
              else begin
                archive := true;
                flist.delete;
                load;
                hide_cursor;
                move(listpic^,mem[$b800:0],6400);
                flist.draw;
              end;
            end;
  end
  else begin
    if flist.lines^[num].t = t_mod then begin
      chdir(temp_path);
      stop_playing;
      free_mod;
      move(old_st3_per,st3_per,sizeof(st3_per));
      load_mod(flist.lines^[num].s[0]);
      makepertbl;
      start_playing;
      new_mod := true;
      fillchar(mem[$b800:0],8000,0);
      {move(listpic^,mem[$b800:0],6400);
      flist.draw;}
      cur_sample := 1;
      start_sample := 1;
      hide_cursor;
    end
    else begin
      archive := false;
      chdir(temp_path);
      delall;
      chdir(old_path);
      cur_path := old_path;
      flist.delete;
      load;
      hide_cursor;
      move(listpic^,mem[$b800:0],6400);
      flist.draw;
    end;
  end;
end;

procedure dolist;
var
ch : char;
n : integer;
begin
  n := 30;
  if header.usedchns > 10 then dec(n,header.usedchns-10);
  flist.init(maxline,11,3,68,n,listpic);
  flist.c2x := 21;
  fillchar(listpic^,8000,0);
  show_pic(0,seg(listpic^),@image6);
  move(listpic^,mem[$b800:0],8000);
  flist.delete;
  if archive then chdir(temp_path);
  load;
  flist.draw;
  repeat
    new_mod := false;
    repeat
      updateinfo;
    until keypressed;
    ch := readkey;
    case upcase(ch) of
      'A'..'Z' : begin
                   flist.gotokey(upcase(ch));
                 end;
      #0 : begin
             ch := readkey;
             case ch of
               #72 : flist.upline;
               #80 : flist.downline;
               #73 : flist.uppage;
               #81 : flist.downpage;
               #71 : flist.gohome;
               #79 : flist.goend;
             end;
           end;
      ' ' : flist.tagline;
      #8 : flist.draw;
      #13 : doit(flist.curline);
    end;
  until (ch=#27) or (new_mod);
  flist.done;
  if new_mod then begin
    strobo_fx := false;
    for n := 0 to 99 do strobo_sam[n] := false;
    pan_mode := false;
  end;
  fillchar(mem[$b800:0],16000,0);
  normscr;
end;

procedure soita(sam,note : integer);
var
freq,vol,st_ofs : integer;
begin
  gusstopvoice(13);
  gussetbalance(13,7);
  if samples[sam].length < 3 then exit;
  freq := (8363 * 4 * (st3_per[note and 15] shr (note shr 4)))
           div samples[sam].c4spd;
  freq := per2gus(freq);
  vol := gusvol[samples[sam].volume]*amp_vol+20000;
  st_ofs := 2;
  if (samples[sam].loop) then
    gusplayall(13,8,gus_addr[sam]+st_ofs,
                     gus_addr[sam]+samples[sam].loopstart,
                     gus_addr[sam]+samples[sam].loopend,freq,vol)
    else gusplayall(13,0,gus_addr[sam]+st_ofs,
                          gus_addr[sam]+st_ofs,
                          gus_addr[sam]+samples[sam].length,freq,vol);
end;

function key2note(ch : char;okt : integer) : integer;
var
note : integer;
begin
  case ch of
    'Q' : note := _C2+okt;
    'W' : note := _D2+okt;
    'E' : note := _E2+okt;
    'R' : note := _F2+okt;
    'T' : note := _G2+okt;
    'Y' : note := _A2+okt;
    'U' : note := _B2+okt;
    'I' : note := _C3+okt;
    'O' : note := _D3+okt;
    'P' : note := _E3+okt;
    '2' : note := _Db2+okt;
    '3' : note := _Eb2+okt;
    '5' : note := _Gb2+okt;
    '6' : note := _Ab2+okt;
    '7' : note := _Bb2+okt;
    '9' : note := _Db3+okt;
    'Z' : note := _C1+okt;
    'X' : note := _D1+okt;
    'C' : note := _E1+okt;
    'V' : note := _F1+okt;
    'B' : note := _G1+okt;
    'N' : note := _A1+okt;
    'M' : note := _B1+okt;
    'S' : note := _Db1+okt;
    'D' : note := _Eb1+okt;
    'G' : note := _Gb1+okt;
    'H' : note := _Ab1+okt;
    'J' : note := _Bb1+okt;
    else note := 0;
  end;
  key2note := note;
end;

procedure menu;
var
ch : char;
clr : boolean;
n,i : integer;
begin
  clr := true;
  start_chn := 0;
  pause := 0;
  old_row := 666;
  start_sample := 1;
  cur_sample := 1;
  play_sample := 0;
  cur_octave := 2;
  help := false;
  if loaded then start_playing;
  hide_cursor;
  getpal(@normpal);
  setvgapal(col_back,col_backr,col_backg,col_backb);
  {show_pic(0,seg(listpic^),@image6);}
  show_pic(8000+0,$b800,@image1);
  show_pic((50+5+header.usedchns)*160,$b800,@image2);
  if loaded then show_pic(160,$b800,@image3)
  else show_pic(160,$b800,@image6);
  for n := 0 to header.usedchns do
    move(image4,mem[$b800:(4+n)*160+8000],160);
  line_comp((header.usedchns+9)*8);
  set_scr_ofs(4000);
  repeat
    if loaded then show_ptn(clr);
    clr := false;
    if loaded then ch := readkey
    else ch := #13;
    if (play_sample <> 0) and (key2note(upcase(ch),cur_octave*16) <> 0) then begin
      soita(play_sample,key2note(upcase(ch),cur_octave*16));
      ch := #1;
    end;
    if (play_sample <> 0) and (key2note(upcase(ch),cur_octave*16)=0) then begin
      if (ch = '+') and (cur_octave<6) then inc(cur_octave);
      if (ch = '-') and (cur_octave>0) then dec(cur_octave);
      if upcase(ch) in ['A'..'Z','+','-'] then ch := #1;
    end;
    case ch of
      '+' : if amp_vol < 16 then begin
              inc(amp_vol);
              for n := 0 to header.usedchns-1 do begin
                i := gusvol[word(channels[n].vol*main_vol) div 64]*amp_vol+20000;
                gus_chn[n].status := gus_chn[n].status or gst_vol;
                gus_chn[n].vol := i;
                {gussetvolume(n,i);}
              end;
            end;
      '-' : if amp_vol > 0 then begin
              dec(amp_vol);
              for n := 0 to header.usedchns-1 do begin
                i := gusvol[word(channels[n].vol*main_vol) div 64]*amp_vol+20000;
                gus_chn[n].status := gus_chn[n].status or gst_vol;
                gus_chn[n].vol := i;
                {gussetvolume(n,i);}
              end;
            end;
      ',' : if start_chn > 0 then begin
              dec(start_chn);
              clr := true;
            end;
      '.' : if start_chn < header.usedchns-4 then begin
              inc(start_chn);
              clr := true;
            end;
      'P','p' : if pause = 0 then begin
                  pause := speed;
                  speed := 0;
                  for n := 0 to maxchn-1 do gusstopvoice(n);
                  strobo_val := 0;
                end else begin
                  speed := pause;
                  pause := 0;
                end;
      'R','r' : if playing then begin
                  stop_playing;
                  playing := false;
                end else begin
                  clr := true;
                  start_playing;
                  playing := true;
                end;
      'V','v' : if vblank then vblank := false
                else vblank := true;
      'b','B' : if strobo_sam[cur_sample]=true then strobo_sam[cur_sample]:=false
                else begin
                  strobo_sam[cur_sample] := true;
                  strobo_fx := true;
                end;
      'A','a' : if pan_mode then begin
                  for n := 0 to header.usedchns-1 do begin
                    channels[n].pan := defpan[n];
                    gussetbalance(n,defpan[n]);
                  end;
                  pan_mode := false;
                  pan_cnt := 4*pan_speed;
                end
                else begin
                  pan_mode := true;
                  pan_cnt := 4*pan_speed;
                  pan_inc := 1;
                end;
      'Q','q' : if qualitymode and not lockquality then begin
                  qualitymode := false;
                  makepertbl;
                  normscr;
                end
                else begin
                  qualitymode := true;
                  makepertbl;
                  normscr;
                end;
      ' ' : if play_sample <> 0 then begin
              gussetvolume(13,0);
              gusstopvoice(13);
              play_sample := 0;
            end
            else play_sample := cur_sample;
      #13 : dolist;
      #8 : begin      {bkspc}
             goto_mod(cur_ptn,0);
             clr := true;
           end;
      #0 : begin
             ch := readkey;
             case ch of
               #81 : if speed < 31 then begin  {pgdn}
                       inc(nspeed);
                       inc(speed);
                     end;
               #73 : if speed > 0 then begin   {pgup}
                       dec(nspeed);
                       dec(speed);
                     end;
               #71 : begin                     {home}
                       dec(tempo);
                       timer_rate := 25000 div (tempo);
                     end;
               #79 : begin                     {end}
                       inc(tempo);
                       timer_rate := 25000 div (tempo);
                     end;
               #59..#68 : if byte(ch)-59 < header.usedchns then {F1-F10}
                          begin
                            channels[byte(ch)-59].on :=
                              channels[byte(ch)-59].on xor 1;
                            gusstopvoice(byte(ch)-59);
                          end;
               #84..#93 : if byte(ch)-74 < header.usedchns then {SHIFT F1-F10}
                          begin  {F1-F10}
                            channels[byte(ch)-74].on :=
                              channels[byte(ch)-74].on xor 1;
                            gusstopvoice(byte(ch)-74);
                          end;
               #75 : begin    {left arrow}
                       if cur_ptn > 0 then
                         goto_mod(cur_ptn-1,0)
                       else goto_mod(0,0);
                       clr := true;
                     end;
               #77 : begin    {right arrow}
                       if cur_ptn < header.length-1 then
                         goto_mod(cur_ptn+1,0)
                       else goto_mod(cur_ptn,0);
                       clr := true;
                     end;
               #72 : begin {up}
                       if cur_sample > 1 then dec(cur_sample);
                       if cur_sample < start_sample then dec(start_sample);
                       if play_sample <> 0 then play_sample := cur_sample;
                     end;
               #80 : begin  {down}
                       if cur_sample < header.samples then inc(cur_sample);
                       if cur_sample > (start_sample+24-header.usedchns) then
                         inc(start_sample);
                       if play_sample <> 0 then play_sample := cur_sample;
                     end;
             end;
           end;
      'S','s' : scrsaver;
      '!' : begin
              textmode(co80);
              exec(getenv('COMSPEC'),'');
              textmode(co80+font8x8);
              normscr;
              old_row := 666;
            end;
      '"' : begin
              init_dos;
              exec(getenv('COMSPEC'),'');
              end_dos;
              textmode(co80+font8x8);
              normscr;
              old_row := 666;
            end;
    end;
  until (ch = #27) or (not loaded);
  stop_playing;
end;



function toupper(s : string) : string;
var
n,i : integer;
begin
  n := length(s);
  if n < 1 then begin
    toupper := '';
    exit;
  end;
  for i := 1 to n do s[i] := upcase(s[i]);
  toupper := s;
end;

function exists(s : string) : boolean;
var
f : file of byte;
i : integer;
begin
  assign(f,s);
  {$i-}
  reset(f);
  i := ioresult;
  {$i+}
  if i = 0 then begin
    close(f);
    exists := true;
  end else exists := false;
end;

function addext(str,ext: string) : string;
begin
  if pos('.',str) > 0 then addext := str
  else addext := str+ext;
end;

function findgus : word;
var
n,c,i : word;
s : string;
begin
  s := getenv('ultrasnd');
  if s = '' then begin
    findgus := 0;
    exit;
  end;
  val(copy(s,1,3),n,c);
  if c <> 0 then begin
    findgus := 0;
    exit;
  end;
  case n of
    210 : i := $210;
    220 : i := $220;
    230 : i := $230;
    240 : i := $240;
    250 : i := $250;
    260 : i := $260;
    270 : i := $270;
    else begin
      findgus := 0;
      exit;
    end;
  end;
  for n := 1 to 3 do delete(s,1,pos(',',s));
  if gus_irq = 0 then begin
    val(copy(s,1,pos(',',s)-1),gus_irq,c);
    if c <> 0 then gus_irq := 0;
  end;
  findgus := i;
end;

procedure getcmd;
var
s : string;
b : byte;
i,n,c : integer;

begin
  mod_name :=  '';
  for n := 0 to 99 do strobo_sam[n] := false;
  strobo_fx := false;
  strobo_col[1] := $ff;
  strobo_col[2] := $ff;
  strobo_col[3] := $ff;
  writeln('Adrenalin module player v 0.95  By: Beta/A-Men');
  if paramcount > 0 then for n := 1 to paramcount do begin
    s := toupper(s);
    if copy(paramstr(n),1,1) <> '/' then begin
      s := addext(paramstr(n),'.mod');
      if not exists(s) then begin
        s := addext(paramstr(n),'.s3m');
        if not exists(s) then begin
          writeln('Module ',s,' not found!');
          halt(2);
        end;
      end;
      mod_name := s;
    end
    else if copy(paramstr(n),1,5) = '/port' then begin
      s := copy(paramstr(n),6,3);
      if s = '210' then gus_base := $210;
      if s = '220' then gus_base := $220;
      if s = '230' then gus_base := $230;
      if s = '240' then gus_base := $240;
      if s = '250' then gus_base := $250;
      if s = '260' then gus_base := $260;
      if s = '270' then gus_base := $270;
    end
    else if copy(paramstr(n),1,4)='/tmr' then gus_irq := 100
    else if copy(paramstr(n),1,5)='/desq' then keybled := false
    else if copy(paramstr(n),1,5)='/ssam' then begin
      val(copy(paramstr(n),6,2),i,c);
      if (i > 0) and (i < 32) then begin
        strobo_fx := true;
        strobo_sam[i] := true;
      end;
    end
    else if copy(paramstr(n),1,5)='/scol' then begin
      strobo_col[1] := 0;
      strobo_col[2] := 0;
      strobo_col[3] := 0;
      val(copy(paramstr(n),6,2),i,c);
      if (i > 0) and (i < 8) then begin
        if i and 1 > 0 then strobo_col[3] := $ff;
        if i and 2 > 0 then strobo_col[2] := $ff;
        if i and 4 > 0 then strobo_col[1] := $ff;
      end;
    end
    else if copy(paramstr(n),1,5)='/sspd' then begin
      val(copy(paramstr(n),6,2),i,c);
      if i > 0 then strobo_speed := i;
    end
    else if copy(paramstr(n),1,5)='/pspd' then begin
      val(copy(paramstr(n),6,2),i,c);
      if i > 0 then pan_speed := i;
      pan_cnt := 4*pan_speed;
    end
    else if copy(paramstr(n),1,2)='/?' then begin
      writeln('Usage: ADNMOD modname [options]');
      writeln('options:  /portxxx    set gus address');
      writeln('          /scolx      set strobo color');
      writeln('          /sspdxx     set strobo speed');
      writeln('          /tmr        dont use GUS irq');
      writeln('          /desq       disable some desqview unfriendly features');
      halt(0);
    end;
  end;
  s := toupper(getenv('CAPAMOD'));
  if length(s) > 0 then begin
    b := 0;
    n := 1;
    while (n <= length(s)) and (b = 0) do begin
      if s[n] = '/' then begin
        if toupper(copy(s,n+1,3)) = 'AMP' then begin
          val(copy(s,n+4,2),i,c);
          i := i div 3;
          if i > 0 then amp_vol := i;
          b := 1;
        end;
      end;
      inc(n);
    end;
  end;
end;

procedure initialize;
var
w : word;
begin
  if gus_base = $200 then if findgus > 0 then gus_base := findgus;
  if gus_irq > 15 then gus_irq := 0;
  gusfind;
  if gus_base = $200 then begin
    writeln('GUS not found. Assuming address 220');
    gus_base := $220;
    gusfind;
  end;
  write('GUS found at ',nibb2hex(hi(gus_base)),byte2hex(lo(gus_base)));
  gusmem := gusfindmem;
  writeln(' with ',gusmem,' bytes of memory');
  gusreset;
  move(st3_per,old_st3_per,sizeof(st3_per));
  if keybled then normkbf := mem[$40:$17];
  asm
    mov  ax,1600h
    int  2fh
    mov  w,ax
  end;
  if lo(w)=4 then begin
    lockquality := true;
    qualitymode := true;
    makepertbl;
  end;
end;

procedure showerr(error : integer);
begin
  case error of
    1 : writeln('Too many channels');
    2 : begin
          writeln;
          writeln('Load error!');
        end;
    3 : begin
          writeln;
          writeln('Out of memory');
        end;
    255 : writeln('Error');
  end;
end;

var
i,n : integer;

begin
  amp_vol := 16;
  randomize;
  checkbreak := false;
  getcmd;
  initialize;
  init_mod;
  if initxms <> 0 then begin
    writeln('XMS not found');
    halt(3);
  end;
  if mod_name <> '' then begin
    load_mod(mod_name);
    if mod_error <> 0 then begin
      showerr(mod_error);
      halt(mod_error);
    end;
  end;
  initlist;
  getintvec($fc,@oldintfc);
  setintvec($fc,@intfc);
  menu;
  setintvec($fc,@oldintfc);
  freemem(lpic,8000);
  free_mod;
  if isxms then donexms;
  chdir(temp_path);
  delall;
  chdir(org_path);
  done_mod;
  textmode(co80);
  if keybled then begin
    mem[$40:$17] := 0;
    mem[$40:$18] := 0;
  end;
  if mod_error <> 0 then showerr(mod_error);
  if virt_info.err_wptn <> -1 then begin
    writeln('Error in warnptn. Please report error numbers and module name to author');
    writeln('cptn: ',virt_info.err_cptn);
    writeln('wptn: ',virt_info.err_wptn);
    writeln('nptn: ',virt_info.err_nptn);
  end;
  textcolor(15);
  writeln('Thank you for using ADNMOD 0.95');
  textcolor(7);
  write('Send e-mail to ');
  textcolor(14);
  writeln('[e-mail]');
  textcolor(7);
end.