{ Description
------------

Cette procédure adresse le haut-parleur PC mono pour émettre un son dont la fréquence, transmise en paramétrage par «frequency», est exprimée en Hertz. Le son est émis jusqu'à ce qu'un appel à la procédure «NoSound» soit effectué ou jusqu'à ce qu'un nouvel appel à la procédure «Sound» vienne modifier la fréquence du son émis. }

Procedure Sound(Frequency:Word);Assembler;ASM
MOV BX,frequency
MOV AX,034DDh
MOV DX,012h
CMP DX,BX
JNB @2
DIV BX
MOV BX,AX
IN AL,061h
TEST AL,3
JNE @1
OR AL,3
OUT 061h,AL
MOV AL,0B6h
OUT 043h,AL
@1:
MOV AL,BL
OUT 042h,AL
MOV AL,BH
OUT 042h,AL
@2:
END;

{ Description
------------

Cette procédure arrête le son émis par le PC Speaker mais n'affecte en aucun cas le son de la carte de son. Elle affecte seulement le PC Speaker!
}

Procedure NoSound;Assembler;ASM
IN AL,061h
AND AL,0FCh
OUT 061h,AL
END;

{ Description
-----------
Cette procédure permet de faire jouer de la musique sous le format du "Play" du langage BASIC.
}

Procedure Play(S:String);
Const
NoteOfs:Array['A'..'G']of Integer=(9,11,0,2,4,5,7);
NoteFreqs:Array[0..84]of Integer=(0,
(* C C# D D# E F F# G G# A A# B *)
65, 69, 73, 78, 82, 87, 92, 98, 104, 110, 116, 123,
131, 139, 147, 156, 165, 175, 185, 196, 208, 220, 233, 247,
262, 278, 294, 312, 330, 350, 370, 392, 416, 440, 466, 494,
524, 556, 588, 624, 660, 700, 740, 784, 832, 880, 932, 988,
1048,1112,1176,1248,1320,1400,1480,1568,1664,1760,1864,1976,
2096,2224,2352,2496,2640,2800,2960,3136,3328,3520,3728,3952,
4192,4448,4704,4992,5280,5600,5920,6272,6656,7040,7456,7904);
QuarterNote=0.25; Digits:Set of'0'..'9'=['0'..'9'];
Var
PlayFreq,PlayDur,RestDur,I,N,K:Integer;
C:Char;
Freq:Array[0..6,0..11]of Integer Absolute NoteFreqs;
XN:Real;
Function GetInt:Integer;
Var
N:Integer;
Begin
N:=0;
While(S[I]in Digits)do Begin
N:=N*10+Byte(S[I])-Byte('0');
Inc(I)
End;
Dec(I);
GetInt:=N;
End;
Begin
IncStr(S,' ');I:=1;
While I<Length(S)do Begin
C:=UpCase(S[I]);
Case C of
'A'..'G':Begin
N:=NoteOfs[C];
PlayFreq:=Freq[NoteOctave,N];
XN:=NoteQuarter*(NoteLen/QuarterNote);
PlayDur:=Trunc(XN*NoteFrac);
RestDur:=Trunc(XN*(1.0-NoteFrac));
If S[I+1]in['#','+','-']Then Begin
Inc(I);
Case S[I] of
'#','+':PlayFreq:=Freq[NoteOctave,N+1];
'-':PlayFreq:=Freq[NoteOctave,N-1];
End;
End;
If(S[I+1]in Digits)Then Begin
Inc(I);N:=GetInt;XN:=(1.0/N)/QuarterNote;
PlayDur:=Trunc(NoteFrac*NoteQuarter*XN);
RestDur:=Trunc((1.0-NoteFrac)*Xn*NoteQuarter);
End;
If S[I+1]='.'Then Begin
XN:=1.0;
While S[I+1]='.'do Begin
XN:=XN*1.5;
Inc(I);
End;
PlayDur:=Trunc(PlayDur*XN);
End;
Sound(PlayFreq);
Delay(PlayDur);
NoSound;
Delay(RestDur);
End;
'M':Begin
Inc(I);C:=S[I];
Case C Of
'N':NoteFrac:=0.875;
'L':NoteFrac:=1.000;
'S':NoteFrac:=0.750;
End;
End;
'O':Begin
Inc(I); N:=Byte(S[I])-Byte('0');
If(N<0)or(N>6)Then N:=4;
NoteOctave:=N;
End;
'<':If NoteOctave>0Then Dec(NoteOctave);
'>':If NoteOctave<6Then Inc(NoteOctave);
'N':Begin
Inc(I);N:=GetInt;
If(N>0)and(N<=84)Then Begin
PlayFreq:=NoteFreqs[N];XN:=NoteQuarter*(NoteLen/QuarterNote);
PlayDur:=Trunc(XN*NoteFrac);
RestDur:=Trunc(XN*(1.0-NoteFrac));
End
Else
If N=0Then Begin
PlayFreq:=0;
PlayDur:=0;
RestDur:=Trunc(NoteFrac*NoteQuarter*(NoteLen/QuarterNote));
End;
Sound(PlayFreq);
Delay(PlayDur);
NoSound;
Delay(RestDur);
End;
'L':Begin
Inc(I);
N:=GetInt;
If N>0Then NoteLen:=1.0/N;
End;
'T':Begin
Inc(I);
N:=GetInt;
NoteQuarter:=(1092.0/18.2/N)*1000.0;
End;
'P':Begin
Inc(I);N:=GetInt;
If N<1Then N:=1 Else
If N>64Then N:=64;
PlayFreq:=0;
PlayDur:=0;
RestDur:=Trunc(((1.0/N)/QuarterNote)*NoteQuarter);
Sound(PlayFreq);
Delay(PlayDur);
NoSound;
Delay(RestDur);
End;
End;
Inc(I);
End;
NoSound;
End;