Const HappyBirthDay: Array [1..30] of TFullNote =
     ( (N: Mi1;  D: 2), (N: Mi1;  D: 2), (N: FaD1; D: 1),
(N: Mi1;  D: 1), (N: La1;  D: 1), (N: SolD1;D: 0.5), (N: Pause; D: 2),
(N: Mi1;  D: 2), (N: Mi1;  D: 2), (N: FaD1; D: 1),
(N: Mi1;  D: 1), (N: Si1;  D: 1), (N: La1;  D: 0.5), (N: Pause; D: 2),
(N: Mi1;  D: 2), (N: Mi1;  D: 2), (N: DoD2; D: 1),
(N: La1;  D: 1),
(N: SolD1;D: 2), (N: La1;  D: 2), (N: SolD1;D: 1),
(N: FaD1; D: 1),          (N: Pause; D: 2),
(N: Re2;  D: 2), (N: Re2;  D: 2), (N: DoD2; D: 1),
(N: La1;  D: 1), (N: DoD2; D: 1), (N: Si1;  D: 0.5), (N: Pause; D: 8) );

Unit Music;
{--------------------------}Interface
Procedure Sound (Hz: Word);
Procedure NoSound;

Var Duration: Word;
{Type  TNote=(Pause,
C1,  Cs1,  D1,  Ds1,  E1,  F1,  Fs1,  G1,  Gs1,  A1,  As1,  B1,
C2,  Cs2,  D2,  Ds2,  E2,  F2,  Fs2,  G2,  Gs2,  A2,  As2,  B2);}
Type  TNote=(Pause,
Do1, DoD1, Re1, ReD1, Mi1, Fa1, FaD1, Sol1,SolD1,La1, LaD1, Si1,
Do2, DoD2, Re2, ReD2, Mi2, Fa2, FaD2, Sol2,SolD2,La2, LaD2, Si2);
     {перечисление нот
*1, *2 - первая, вторая октавы
??D? (?s?) - диез (sharp)}
     TDuration = Single;
     TFullNote = Record
     N: TNote;     {Нота}
     D: TDuration  {Длительность}
   End;

{Пример вся 1ая октава + До второй}
{Const Melody0: Array [1..8] of TFullNote =
    ( (N: Do1; D: 1), (N: Re1; D: 1), (N: Mi1; D: 1), (N: Fa1; D: 1),
      (N: Sol1;D: 1), (N: La1; D: 1), (N: Si1; D: 1), (N: Do2; D: 1) );}

Procedure PlayNote (FullNote: TFullNote);
Procedure Play (Melody: Array of TFullNote);

{--------------------------}Implementation
Function Stp (L: Double; R: ShortInt): Double;
 Var i: Byte;
     Pr: Double;
 Begin
   Pr:=1;
   For i:=1 to Abs(R) do Pr:=Pr*L;
   If R<0 Then Stp:=1/Pr
   Else Stp:=Pr
 End;

Var Base, Trans: Double;

Procedure Sound (Hz: Word); Assembler;
 Asm
MOV BX,SP
MOV BX,SS:[BX+4]
MOV AX,34DDH
MOV DX,0012H
CMP DX,BX
JNC @@2
DIV BX
MOV BX,AX
IN AL,61H
TEST AL,3
JNZ @@1
OR AL,3
OUT 61H,AL
MOV AL,0B6H
OUT 43H,AL
@@1: MOV AL,BL
OUT 42H,AL
MOV AL,BH
OUT 42H,AL
@@2: RETF 2
 End;

Procedure NoSound; Assembler;
 Asm
IN AL,61H
AND AL,0FCH
OUT 61H,AL
RETF
 End;

Procedure PlayNote (FullNote: TFullNote);
 Begin
   With FullNote do
   Begin
     If N=Pause
     Then NoSound
     Else Sound( Round( Base * Stp(Trans, Ord(N)) ) );
     Delay( Duration / D )
   End
 End;

Procedure Play (Melody: Array of TFullNote);
 Var i: Word;
 Begin
   For i:=Low(Melody) to High(Melody) do
     PlayNote(Melody[i]);
   NoSound
 End;

Begin
 Trans:=Exp(Ln(2)/12);
 Base:=440*Stp(Trans, -10);
 Duration:= 400;
End.