{
  Mini FM Organ Using Yamaha OPL-3 Chip
  Autodetect Sound Blaster using BLASTER Environment variable
  By : Roby Johanes
  http://www.geocities.com/SiliconValley/Park/3230
  Finished in 1996

  Latest update: December 1997 for submission to SWAG
}
Program Sound_Blaster_Mini_FM_Organ;
uses crt,dos;
type
  CardType = (SB_1, SB_2, SBPro, SB_16, SBAWE32);
  Str4     = string[4];
  TSBdata  = record
               Portno : word;
               ctype  : CardType;
               irq    : byte;
               dma    : byte;
             end;
  TFMInst  = record
               modchr, carchr, modlev, carlev,
               modatk, caratk, modsus, carsus,
               modwav, carwav, feedback : byte;
               reserved : array[1..5] of byte;
             end;
const
  CardName : array [1..5] of string[8] = (
             'SB v1.0', 'SB v2.0', 'SB Pro', 'SB 16', 'SB AWE32');
  Notefreq : array[1..12] of word = ($16B,$181,$198,$1B0,$1CA,$1E5,
                                     $202,$220,$241,$263,$287,$2AE);
const
  waitctr   = $400;
  FMaddr    = $388;
  EOI       = $20;
  PIC       = $20;
  PICStatus = $21;
  Modofs    : array[1..9] of byte = (0,1,2,8,9,10,16,17,18);
  Carofs    : array[1..9] of byte = (3,4,5,11,12,13,19,20,21);
var
  SBdata : TSBdata;
  c      : TSBData;
  v      : word;
  f      : tfminst;
  s      : string;
  t      : string[3];

Function  WordToHex(no : word): Str4;
const
  h : array [0..15] of char = '0123456789ABCDEF';
begin
  WordToHex:=h[hi(no) shr 4]+h[hi(no) and 15]+h[lo(no) shr 4]+
             h[lo(no) and 15];
end;

Function ResetChip(Portno : Word) : Boolean; Assembler;
asm
  mov    bx,-1
  mov    dx,[Portno]
  add    dl,6
  mov    al,1
  out    dx,al
  mov    cx,waitctr

@@1:
  loop   @@1
  dec    al
  out    dx,al
  mov    cx,waitctr

@@2:
  loop   @@2
  add    dl,8
  mov    cx,waitctr

@@testreadybit:
  in     al,dx
  test   al,80h
  loopz  @@testreadybit
  jz     @@SBnotpresent
  sub    dl,4
  mov    cx,waitctr

@@pollfor0AAh:
  in     al,dx
  cmp    al,0AAh
  je     @@done
  loop   @@pollfor0AAh

@@SBnotpresent:
  xor    bx,bx

@@done:
  mov    ax,bx
end;

Function  SBRead: byte; assembler;
asm
  mov     dx,[SBData.Portno]
  add     dl,0eH
  mov     cx,waitctr
@@loopit:
  in      al,dx
  test    al,80H
  loopz   @@loopit
  sub     dx,4
  in      al,dx
end;

Procedure SBWrite(Data : byte); assembler;
asm
  mov    dx,[SBData.Portno]
  add    dl,0cH
  mov    cx,waitctr
@@loopit:
  in     al,dx
  test   al,80H
  loopnz @@loopit
  mov    al,[Data]
  out    dx,al
end;

Function  GetDSPVersion : Word; assembler;
asm
  push   00e1H
  call   SBwrite
  call   SBread
  mov    ah,al
  call   SBread
end;

Procedure FMwrite(reg, data : byte); assembler;
asm
  mov    dx,FMaddr
  mov    al,[reg]
  out    dx,al
  mov    cx,6
@@1:
  in     al,dx
  loop   @@1
  inc    dl
  mov    al,[data]
  out    dx,al
  dec    dl
  mov    cx,35
@@2:
  in     al,dx
  loop   @@2
end;

Procedure FMreset;
begin
  FMwrite(1,0);
end;

Procedure FMKeyon(channel: byte; freq: word; octave: byte);
begin
  FMWrite($A0+channel-1,freq and $FF);
  FMWrite($B0+channel-1,(freq shr 8) or (octave shl 2) or $20);
end;

Procedure FMKeyoff(channel: byte);
begin
  FMWrite($B0+channel-1,0);
end;

Procedure FMSetVolume(channel, vol: byte);
begin
  FMWrite($40+Modofs[channel],vol and $3F);
  FMWrite($40+Carofs[channel],vol and $3F);
end;

Procedure FMSetup(channel: byte; FMInst : TFMInst);
var
  i, j : byte;
begin
  i:=modofs[channel]; j:=carofs[channel];
  FMWrite($20+i,FMInst.modchr); FMWrite($20+j,FMInst.carchr);
  FMWrite($40+i,FMInst.modlev); FMWrite($40+j,FMInst.carlev);
  FMWrite($60+i,FMInst.modatk); FMWrite($60+j,FMInst.caratk);
  FMWrite($80+i,FMInst.modsus); FMWrite($80+j,FMInst.carsus);
  FMWrite($E0+i,FMInst.modwav); FMWrite($E0+j,FMInst.carwav);
  FMWrite($C0+channel-1,FMInst.feedback);
end;

Procedure SBSetcard(CardData : TSBdata);
begin
  with SBData do
  begin
    portno:=CardData.portno;
    ctype :=CardData.ctype;
    irq   :=CardData.irq;
    dma   :=CardData.dma;
  end;
end;

Function AutoDetectIRQ : Byte;
var
  i       : Integer;
  s       : string;
  j       : byte;
begin
  for I:=1 to EnvCount do
  begin
    s:=EnvStr(i);
    if copy(s,1,7)='BLASTER' then break;
  end;
  if copy(s,1,7)<>'BLASTER' then
  begin
    AutoDetectIRQ:=0;
    exit;
  end;
  j:=pos('I',s);
  if j=0 then
  begin
    j:=pos('i',s);
    if j=0 then
    begin
      AutoDetectIRQ:=0;
      exit;
    end;
  end;
  s:=copy(s,j+1,1);
  j:=ord(s[1])-48;
  AutoDetectIRQ:=j;
end;

Function AutoDetectDMA : Byte;
var
  i       : Integer;
  s       : string;
  j       : byte;
begin
  for I:=1 to EnvCount do
  begin
    s:=EnvStr(i);
    if copy(s,1,7)='BLASTER' then break;
  end;
  if copy(s,1,7)<>'BLASTER' then
  begin
    AutoDetectDMA:=0;
    exit;
  end;
  j:=pos('D',s);
  if j=0 then
  begin
    j:=pos('d',s);
    if j=0 then
    begin
      AutoDetectDMA:=0;
      exit;
    end;
  end;
  s:=copy(s,j+1,1);
  j:=ord(s[1])-48;
  AutoDetectDMA:=j;
end;

Procedure DetectSB (var CardData : TSBdata); assembler;
asm
  { Port AutoDetect }
  mov    ax,ds
  mov    es,ax
  mov    di,[offset SBData]
  mov    si,di
  mov    ax,220h
@@detectionloop:
  mov    bx,ax
  push   bx
  push   ax
  call   ResetChip
  pop    bx
  cmp    ax,-1
  je     @@success
  mov    ax,bx
  add    ax,20h
  cmp    ax,300h
  jb     @@detectionloop
  xor    bx,bx
@@success:
  mov    ax,bx
  cld
  stosw

  { Card Type AutoDetect }
  call   GetDSPVersion
  cmp    ah,4
  jne    @@nexts
  cmp    al,10
  jl     @@nexts
  inc    ah
@@nexts:
  mov    al,ah
  cld
  stosb

  { IRQ autodetect }
  push   es
  push   di
  push   si
  call   AutoDetectIRQ
  pop    si
  pop    di
  pop    es
  cld
  stosb

  { DMA autodetect }
  push   es
  push   di
  push   si
  call   AutoDetectDMA
  pop    si
  pop    di
  pop    es
  cld
  stosb
  les    di,[CardData]
  mov    cx,5
  cld
  rep    movsb
end;

procedure createbkgr; assembler;
asm
  mov  ax,0b800h
  mov  es,ax
  xor  di,di
  mov  cx,2000
  mov  ax,39b1h
  cld
  rep  stosw
  mov  ah,2
  xor  bh,bh
  xor  dx,dx
  int  10h
  mov  ah,1
  mov  cx,-1
  int  10h
end;

procedure writexy(x,y,c : byte; s : string); assembler;
asm
  mov  ax,0b800h
  mov  es,ax
  mov  al,[y]
  dec  al
  xor  ah,ah
  shl  ax,5
  mov  di,ax
  shl  ax,1
  shl  ax,1
  add  di,ax
  mov  al,[x]
  dec  al
  xor  ah,ah
  shl  ax,1
  add  di,ax
  xor  ch,ch
  push ds
  lds  si,[s]
  mov  cl,[si]
  jcxz @@done
  mov  ah,[c]
  inc  si
  cld
@@loops:
  lodsb
  stosw
  loop @@loops
@@done:
  pop  ds
end;

procedure organ;
var
  ch  : char;
  n,o : byte;
begin
  repeat
    n:=0;
    ch:=Upcase(readkey);
    FMKeyoff(2);
    case ch of
  ',','A': begin n:=1; o:=2; end;
      'W': begin n:=2; o:=2; end;
  '.','S': begin n:=3; o:=2; end;
      'E': begin n:=4; o:=2; end;
  '/','D': begin n:=5; o:=2; end;
      'F': begin n:=6; o:=2; end;
      'T': begin n:=7; o:=2; end;
      'G': begin n:=8; o:=2; end;
      'Y': begin n:=9; o:=2; end;
      'H': begin n:=10;o:=2; end;
      'U': begin n:=11;o:=2; end;
      'J': begin n:=12;o:=2; end;
      'K': begin n:=1; o:=3; end;
      'O': begin n:=2; o:=3; end;
      'L': begin n:=3; o:=3; end;
      'P': begin n:=4; o:=3; end;
      ';': begin n:=5; o:=3; end;
      #39: begin n:=6; o:=3; end;
      #13: begin n:=8; o:=3; end;
      'M': begin n:=12;o:=1; end;
      'N': begin n:=10;o:=1; end;
      'B': begin n:=8; o:=1; end;
      'V': begin n:=6; o:=1; end;
      'C': begin n:=5; o:=1; end;
      'X': begin n:=3; o:=1; end;
      'Z': begin n:=1; o:=1; end;
    end;
    if n>0 then FMKeyon(2,NoteFreq[n],o);
  until ch=#27;
end;

procedure DrawOrgan;
begin
  textattr:=$0F;
  gotoxy(21, 9); write('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
  gotoxy(21,10); write('ºÞÛÝ  ÞÝ  ÞÛÛÞÛÝ  ÞÝ  ÞÝ  ÞÛÛÞÛÝ  ÞÝ  ÞÛÛ º');
  gotoxy(21,11); write('ºÞÛÝ  ÞÝ  ÞÛÛÞÛÝ  ÞÝ  ÞÝ  ÞÛÛÞÛÝ  ÞÝ  ÞÛÛ º');
  gotoxy(21,12); write('ºÞÛÝ  ÞÝ  ÞÛÛÞÛÝ  ÞÝ  ÞÝ  ÞÛÛÞÛÝ  ÞÝ  ÞÛÛ º');
  gotoxy(21,13); write('ºÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛ º');
  gotoxy(21,14); write('ºÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛ º');
  gotoxy(21,15); write('ºÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛÞÛÛÛ º');
  gotoxy(21,16); write('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
end;

procedure ShowCursor; assembler;
asm
  mov  ah,1
  mov  cx,0708h
  int  10h
end;

begin
  with SBdata do
  begin
    portno:=$220;
    ctype :=sb_16;
    irq   :=7;
    dma   :=1;
  end;
  DetectSB(c);
  If c.portno=0 then
  begin
    writeln('Sound Blaster not present !',#10,#13); halt;
  end;
  createbkgr;
  textattr:=$1E;
  fillchar(s,81,' '); s[0]:=#80;
  writexy(1,1,$1E,s);
  writeln('Sound Blaster present in '+WordToHex(c.portno)+'h'+
  ' of type '+cardname[ord(c.ctype)]+' with IRQ ',c.irq,' and DMA ',c.dma);
  v:=GetDSPversion; textattr:=$1F;
  s:=s+t; writexy(1,25, $1E,s);
  fillchar(s,81,' '); s[0]:=#80;
  str(v shr 8,t);
  s:='DSP version '+t+'.';
  str(v and $FF,t); s:=s+t;
  writexy(1,25, $1E,s);
  writexy(64,25,$1E,'By : Roby Johanes');
  gotoxy(36,7); writeln('FM Mini Organ'); textattr:=$4E;
  gotoxy(36,8); writeln('version 0.007'); textattr:=$2F;
  gotoxy(19,17); writeln('Press a key to produce a sound, or Esc to quit');
  with f do
  begin
    modchr:=$41; carchr:=$41; modlev:=$8a; carlev:=$40;
    modatk:=$F1; caratk:=$F1; modsus:=$31; carsus:=$33;
    modwav:=0;   carwav:=0;   feedback:=6;
  end;
  DrawOrgan; FMReset;
  FMSetup(2,f); organ;
  FMKeyoff(2); FMReset;
  textattr:=7; clrscr; ShowCursor;
end.