카테고리 없음
[시스템] 사운드파일 없이 PC 스피커로 음악연주
쇼핑스크래퍼2
2023. 9. 14. 07:32
{Written By Luiz C. Vaz de Brito}
Unit Music;
Interface
Uses Windows, Classes, Forms;
Procedure PlaySong (TuneString:string);
Const
BaseOctave: Integer = 0;
Implementation
Const
SharpOffset = 60;
{ Frequency of notes }
PitchArray: Array[1..120] of Word =
(28,31,33,37,41,44,49,55,
62,65,73,82,87,98,110,123,
131,147,165,175,196,220,247,262,
294,330,349,392,440,494,523,587,
659,698,784,880,988,1047,1175,1319,
1397,1568,1760,1976,2093,2349,2637,2794,
3136,3520,3951,4186,4699,5274,5588,6272,
32139,9738,1934,39659,29,33,35,39,
44,46,52,58,65,69,78,87,
92,104,117,131,139,156,175,185,
208,233,262,277,311,349,370,415,
466,523,554,622,698,740,831,932,
1047,1109,1245,1397,1480,1661,1865,2093,
2217,2489,2794,2960,3322,3729,4186,4435,
4978,5588,5920,6645,35669,33772,1772,18119);
Octave: Integer = 3; {Thirth Octave - Starts with half C}
GenNoteType: Integer = 4; {Quarter of note}
Tempo: Integer = 120; {120 BPM}
PlayFrac: Byte = 7; {Normal - 7/8 of time}
Var vq: LongInt;
TmpPitch: LongInt;
{ Write value on Sound port}
procedure SetPort(address, value: Word);
var
bValue: Byte;
begin
bValue := trunc(value and 255);
asm
mov DX, address
mov AL, bValue
out DX, AL
end;
end;
{ Read value on Sound port}
function GetPort(address: Word): Word;
var
bValue: Byte;
begin
asm
mov DX, address
in AL, DX
mov bValue, AL
end;
result := bValue;
end;
{ Stop sound}
procedure NoSound;
var
wValue: Word;
begin
wValue := GetPort($61);
wValue := wValue and $FC;
SetPort($61, wValue);
end;
{Make sound with passed frequency}
procedure Sound(Freq: Word);
var
B: Word;
begin
if Freq > 18 then begin
Freq := Word(1193181 div LongInt(Freq));
B := GetPort($61);
if (B and 3) = 0 then begin
SetPort($61, B or 3);
SetPort($43, $B6);
end;
SetPort($42, Freq);
SetPort($42, (Freq SHR 8));
end;
end;
{Delay for x seconds }
procedure Delay(MSecs: Integer);
var
FirstTickCount : LongInt;
begin
FirstTickCount:=GetTickCount;
repeat
Application.ProcessMessages;
until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));
end;
{Exec string on music standard PLAY of basic }
Procedure PlaySong (TuneString:string);
Var
PlayTime: LongInt;
IdleTime: LongInt;
DotTime: LongInt;
NoteTime : LongInt;
NoteType: Integer;
PitchIndex: Integer;
Position: Integer;
Number : Integer;
Code: Integer;
TuneStrLen: Integer;
Character: Char;
PlayDone: Boolean;
Procedure NVal(Pos:integer; var v, code: integer);
Var
Posn:integer;
Begin
v := 0;
posn := Pos;
while (posn <= TuneStrLen) and (TuneString[posn] in ['0'..'9']) do
Begin
v := v*10 + ord(TuneString[posn]) - ord ('0');
Inc(posn);
End;
code := posn - Pos + 1;
End;
Procedure CheckDots; {There are points after note?}
Begin
While (Position <= TuneStrLen) and (TuneString[Position] = '.') do
Begin
DotTime := DotTime + DotTime div 2;
inc(Position)
End;
End;
Begin
PlayDone := False;
TuneStrLen := length(TuneString);
Position := 1;
Repeat
NoteType := GenNoteType;
DotTime := 1000;
Character := upcase(TuneString[Position]);
Case Character Of
'A'..'G' : Begin
PitchIndex := (ord(Character)-64)+Octave*7;
If (Character='A') or (Character='B') Then
PitchIndex := PitchIndex + 7;
inc(Position);
{Bemol ou sustenido?}
if Position <= TuneStrLen then
case TuneString[Position] of
'#','+': begin
PitchIndex := PitchIndex+SharpOffset;
inc(Position);
end;
'-': begin
PitchIndex := PitchIndex+SharpOffset - 1;
inc(Position);
end;
End;
if (Position <= TuneStrLen) and
(TuneString[Position] in ['0'..'9']) then begin
NVal(Position,NoteType,Code);
inc(Position, Code - 1)
end;
CheckDots;
{Toca a nota}
NoteTime := Round(DotTime/Tempo/NoteType*240);
PlayTime := Round(NoteTime*PlayFrac/8);
IdleTime := NoteTime-PlayTime;
Sound(PitchArray[PitchIndex]);
Delay(PlayTime);
if IdleTime <> 0 then begin
NoSound;
Delay(IdleTime)
end;
End;
'L' : {Duracao 1 - 64 }
Begin
NVal (Position+1,GenNoteType,Code);
if (GenNoteType < 1) or (GenNoteType > 64) then
GenNoteType := 4;
inc(Position, Code);
End;
'M' : {"S" staccato,"L" legato,"N" normal.}
Begin
if Position < TuneStrLen then
begin
Case upcase(TuneString[Position+1]) Of
'S' : PlayFrac := 6;
'N' : PlayFrac := 7;
'L' : PlayFrac := 8;
End;
inc(Position, 2);
end;
End;
'O' : Begin
NVal (Position+1,Octave,Code);
Octave := Octave+BaseOctave;
if Octave > 7 then
Octave := 3;
inc(Position, Code);
End;
'P' : Begin
NoSound;
NVal (Position+1,NoteType,Code);
if (NoteType < 1) or (NoteType > 64) then
NoteType := GenNoteType;
inc(Position, Code);
CheckDots;
IdleTime := DotTime Div Tempo * (240 Div NoteType);
Delay (IdleTime);
End;
'T' : {Tempo - BPM (32 - 255)}
Begin
NVal (Position+1,Tempo,Code);
if (Tempo < 32) or (Tempo > 255) then
Tempo := 120;
inc(Position, Code);
End;
Else
inc(Position); {Ignore wrong caracters}
End;
Until ((Position > TuneStrLen) Or (PlayDone));
NoSound;
End;
End.
-------------------------------------------------------------
And here, some musics yet for PlaySong.
William Tell Overture
=====================
PlaySong('O2L16T155P8MSO1BBB8BBB8BBO2E8F#8G#8O1BBB8BBO2E8G#G#F#8D#8O1B8BBB8BBB8BBO2E8F#8G#8EG#');
PlaySong('MLB4BMSAG#F#E8G#8E8O3BBB8BBB8BBO4E8F#8G#8O3BBB8BBO4E8G#G#F#8D#8O3B8BBB8BBB8BB');
PlaySong('O4E8F#8G#8MLEG#B4BAG#F#MSE8G#8E8P2');
Familia Adams;
==============
PlaySong('O3T220L8CDEFP4O0L4FP8FP8O3L8DEF#GP4O1L4GP8GP8O3L8DEF#GP4DEF#GP4CDEFP4O1L4FP8FP8');
PlaySong('P4T187O3L8CF.AF.DO2B-.O3GP4FE.GE.CO2A.O3FP4CF.AF.DO2B-.O3GP4FL64EFL8E.CD.EFP4');
PlaySong('O3T220L8CDEFP4O0L4FP8FP8O3L8DEF#GP4O1L4GP8GP8O3L8DEF#GP4DEF#GP4CDEFP4O1L4FP8FP8');
PlaySong('P4T187O3L8CF.AF.DO2B-.O3GP4FE.GE.CO2A.O3FP4CF.AF.DO2B-.O3GP4FL64EFL8E.CD.EFP2');
Beverly Hills Cop
=================
PlaySong('t125msl4o3fg#l8fl16fl8a#l8fd#l4fl4o4cl8o3fl16fl8o4c#co3g#fo4cl8fo3l16fl8d#l16d#l8cl8gl4fp2');
PlaySong('t125msl4o3fg#l8fl16fl8a#l8fd#l4fl4o4cl8o3fl16fl8o4c#co3g#fo4cl8fo3l16fl8d#l16d#l8cl8gl4fp2');
PlaySong('o1l4ffl8d#l16d#l8d#l8cd#l4ffp8l16fl8fcfl4c#c#l8d#l16d#l8d#d#d#fp2l8fco0l8a#g#l4f');
PlaySong('o1l4fl8d#l16d#l8d#l8cd#l4ffp8l16fl8fcfl4c#c#l8d#l16d#l8d#d#d#fp2');
James bond theme
================
PlaySong('mll8t125O1b4ebo2c4o1eo2cc#4o1eo2c#c4o1eo2cO1b4ebo2c4o1eo2cc#4o1eo2c#c4o1eo2c');
PlaySong('t150mno3ef#16f#16f#f#3o2eeemno3eg16g16gg3o2f#F#F#mno3ef#16f#16f#f#3o2eee');
PlaySong('mno3eg16g16gg3o2f#F#F#mno3ef#16f#16f#f#3o2eeemno3eg16g16gg3o2f#F#e');
PlaySong('mlo4d#o3b64o4dd2o2g64bf#64amlg24b1P2');
Leave it to beaver
==================
PlaySong('MST190O2L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFL4DL8<B-L4G..P16');
PlaySong('L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F..P8O3L4AL8AL4G.L8FGFL4E-L8EDE-EFGG+L4A..P8');
PlaySong('O1L4GL8GL4F.L8EFEL4D-L8DDEFG>G<G>C<B-AG.P16O2L8CL4FL8A>C<AFL4GL8B-L4>D');
PlaySong('L8C<B>CFL4DL8<B-L4G..P16O3L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F.L8>FP2');
London Bridge
=============
PlaySong('MST190O2L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFL4DL8<B-L4G..P16');
PlaySong('L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F..P8O3L4AL8AL4G.L8FGFL4E-L8EDE-EFGG+L4A..P8');
PlaySong('O1L4GL8GL4F.L8EFEL4D-L8DDEFG>G<G>C<B-AG.P16O2L8CL4FL8A>C<AFL4GL8B-L4>D');
PlaySong('L8C<B>CFL4DL8<B-L4G..P16O3L8CL4FL8A>C<AFL4GL8B-L4>DL8C<B>CFD<GEL4F.L8>FP2');
My Darling Clementine
=====================
PlaySong('T120MNO2L8G.L16GL4GDL8B.L16BL4BGL8GBO3L4DDL8CO2BL2AL8ABO3L4CCO2L8B.L16AL4BGL8GB');
PlaySong('L4ADL8F#.L16AL2GL8G.L16GL4GDL8B.L16BL4BGL8GBO3L4D.L8DCO2BL2AL8ABO3L4CC');
PlaySong('O2L8B.L16AL4BGL8GBL4ADL8F#.L16AL2GL8G.L16GL4GDL8B.L16BL4BGL8GBO3L4DDL8C');
PlaySong('O2BL2AL8ABO3L4CCP2');
The Entertainers
================
PlaySong('T120MNO3L8DD#EO4L4CO3L8EO4L4CO3L8EO4L4C.P4P8L8CDD#ECDL4EL8O3BL4O4DCP4P4O3L8DD#EL4');
PlaySong('O4CO3L8EO4L4CO3L8EL4O4C.P4P4O3L8AGF#AO4CL4EL8DCO3AO4L4DP4P4O3L8DD#EL4O4C');
PlaySong('O3L8EO4L4CO3L8EO4L4C.P4P4L8CDD#ECDL4EL8O3BO4L4DCP4P4L8CDECDL4EL8CDCECDL4E');
PlaySong('L8CDCECDL4EO3BO4L4ECP2');
---------------------------------------