Arsip: Mengubah SourceCode Delphi menjadi Rumus Biasa
more 18 years ago
gormet
saya mendapatkan source code delphi tentang 'bagaimana menggenerate suara dengan frekuensi tertentu'.
berikut ini source code delphi tersebut:
unit Beeper;
{
2000 Aug 11 Make generator a separate unit, Beeper
2001 Jul 16 Version for Delphi 5 (unchanged)
2002 Oct 25 Add Risetime and Falltime properties
2002 Oct 30 Add Amplitude property (must be less than 1)
Currently written on the assumption that the amplitude ..
.. will be set much less often than the frequency
Copyright © David J Taylor, Edinburgh
Web site: www.satsignal.net
E-mail: [email protected]
}
interface
uses
Windows, Controls, MMsystem, Classes, SysUtils, Messages;
const
SampleRate = 44100;
// Sampling rate for audio, i.e. best CD quality. Note: 10 ms -> exactly 441 samples
type
PAudioSample = ^TAudioSample;
// Pointer to TAudioSample, 16-bit signed audio value
TAudioSample = -32767..32767;
// For 16-bit signed audio
PStereoArray = ^TStereoArray;
// Output buffer type, points to mixed L-R audio samples
TStereoArray = array of TAudioSample;
// Array of audio samples, mixed L-R-L-R for 2-channels
TStereoPair = array of TAudioSample;
// L-R pair of samples, used to compute buffer size from number of stereo samples
const
MaxBufferSamples = SampleRate;
sine_table_size = 2048;
type
TSineTable = array of TAudioSample;
{$A-}
const
pcm16: TWaveFormatEx = ( // wave format descriptor
wFormatTag: wave_Format_PCM; // it's PCM data
nChannels: 2; // 2 channels
nSamplesPerSec: SampleRate; // set the 44.1KHz rate
nAvgBytesPerSec: 4 SampleRate; // two channels of two bytes per sample
nBlockAlign: 4; // for 2-channel 16-bit audio
wBitsPerSample: 16; // 16-bit audio
cbSize: 0);
{$A+}
type
TToneburst = class (TCustomControl)
private
pcm: TWaveFormatEx;
sine_table: TSineTable;
sine_table_valid: boolean;
angle: integer;
hWaveOutHeader: HGlobal; // wave out header handles
WaveOutHeader: PWaveHdr; // wave out header pointers
hStereoOutBuffer: HGlobal; // output buffer handles
StereoOutBuffer: PStereoArray; // output buffer pointers
hWave_out: hWaveOut;
status: integer;
samples: integer;
FFrequency: integer;
FDuration: integer;
FBusy: boolean;
FRisetime: integer;
FFalltime: integer;
FAmplitude: single;
procedure declick_buffer (bfr: PStereoArray);
procedure fill_buffer (bfr: PStereoArray; new_freq: integer);
procedure mm_wom_open (var msg: TMessage); message mm_wom_open;
procedure mm_wom_done (var msg: TMessage); message mm_wom_done;
procedure mm_wom_close (var msg: TMessage); message mm_wom_close;
procedure write_next_buffer (header: pWaveHdr);
procedure SetAmplitude(const Value: single);
public
property Amplitude: single read FAmplitude write SetAmplitude;
property Busy: boolean read FBusy;
property Duration: integer read FDuration write FDuration;
property Falltime: integer read FFalltime write FFalltime;
property Frequency: integer read FFrequency write FFrequency;
property Risetime: integer read FRisetime write FRisetime;
constructor Create (AOwner: TComponent); override;
destructor Destroy; override;
procedure Shutdown;
procedure Sound;
end;
implementation
{ TToneburst }
constructor TToneburst.Create (AOwner: TComponent);
begin
Inherited;
pcm := pcm16;
// Get the memory required for wave output headers
// Lock the buffers in memory
hWaveOutHeader := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));
WaveOutHeader := pWaveHdr (GlobalLock (hWaveOutHeader));
// Get the memory required for output buffers
hStereoOutBuffer := GlobalAlloc (gHnd or gMem_Share, MaxBufferSamples SizeOf (TStereoPair));
StereoOutBuffer := PStereoArray (GlobalLock (hStereoOutBuffer));
// Populate the first wave header
with WaveOutHeader^ do
begin
lpData := pChar (StereoOutBuffer); // pointer to the data
dwBufferLength := MaxBufferSamples pcm.nBlockAlign;
dwBytesRecorded := 0;
dwUser := 0;
dwFlags := 0;
dwLoops := 1; // normally, just a single loop
lpNext := nil;
reserved := 0;
end;
Amplitude := 0.3;
angle := 0;
FBusy := False;
end;
destructor TToneburst.Destroy;
begin
// in case the header is still "prepared", unPrepare it
waveOutUnprepareHeader (hWave_out, WaveOutHeader, SizeOf (TWaveHdr));
// Return allocated memory for the output buffers
GlobalUnlock (hWaveOutHeader);
GlobalFree (hWaveOutHeader);
GlobalUnlock (hStereoOutBuffer);
GlobalFree (hStereoOutBuffer);
Inherited;
end;
procedure TToneburst.mm_wom_open (var msg: TMessage);
begin
fill_buffer (StereoOutBuffer, FFrequency);
WaveOutHeader^.dwBufferLength := samples pcm.nBlockAlign;
waveOutPrepareHeader (hWave_out, WaveOutHeader, SizeOf (TWaveHdr));
write_next_buffer (WaveOutHeader);
end;
procedure TToneburst.mm_wom_close (var msg: TMessage);
begin
waveOutReset (hWave_out);
hWave_out := 0;
FBusy := False;
end;
procedure TToneburst.mm_wom_done (var msg: TMessage);
begin
waveOutReset (hWave_out);
waveOutClose (hWave_out);
end;
procedure TToneburst.Sound;
var
err_text: array of char;
begin
if not FBusy then
begin
FFrequency := frequency;
samples := duration SampleRate div 1000;
if samples > MaxBufferSamples then samples := MaxBufferSamples;
status := waveOutOpen (@hWave_out, wave_mapper, @pcm,
Handle, 0, callback_window);
if status = MMSYSERR_NOERROR
then
FBusy := True
else
begin
FBusy := False;
hWave_out := 0;
waveOutGetErrorText (status, err_text, SizeOf (err_text));
Raise Exception.CreateFmt ('Error %d opening wave output - %s', [status, err_text]);
end;
end;
end;
procedure TToneburst.declick_buffer (bfr: PStereoArray);
var
rise_samples, fall_samples: integer;
sample: integer;
gain: single;
i: integer;
begin
// Point to left sample at start of final roll-off
rise_samples := FRisetime SampleRate div 1000;
if rise_samples < samples - 1 then
begin
sample := 0;
for i := 0 to rise_samples - 1 do
begin
gain := i / rise_samples;
bfr^ [sample] := round (bfr^ [sample] gain);
Inc (sample);
bfr^ [sample] := round (bfr^ [sample] gain);
Inc (sample);
end;
end;
fall_samples := FFalltime SampleRate div 1000;
if fall_samples < samples - 1 then
begin
sample := 2 samples - 1;
for i := 0 to fall_samples - 1 do
begin
gain := i / fall_samples;
bfr^ [sample] := round (bfr^ [sample] gain);
Dec (sample);
bfr^ [sample] := round (bfr^ [sample] gain);
Dec (sample);
end;
end;
end;
procedure TToneburst.fill_buffer (bfr: PStereoArray; new_freq: integer);
var
i: integer;
d_angle: integer;
max_angle: integer;
begin
if not sine_table_valid then
begin
for i := 0 to sine_table_size - 1 do
sine_table [i] := round
(FAmplitude 32767.0 sin (i 2.0 pi / sine_table_size));
sine_table_valid := True;
end;
d_angle := round (256.0 sine_table_size new_freq / SampleRate);
max_angle := 256 sine_table_size - 1;
// Fill the channels
for i := 0 to samples - 1 do
begin
// Left channel
PStereoArray (bfr)^ [2 i] := sine_table [angle shr 8];
// Right channel
PStereoArray (bfr)^ [2 * i + 1] := sine_table [angle shr 8];
Inc (angle, d_angle);
angle := angle and max_angle;
end;
if (FRisetime > 0) or (FFalltime > 0) then declick_buffer (bfr);
end;
procedure TToneburst.write_next_buffer (header: pWaveHdr);
var
err_text: array of char;
begin
// Write the buffer, will result in a mm_wom_done message
status := waveOutWrite (hWave_out, header, SizeOf (TWaveHdr));
if status <> MMSYSERR_NOERROR
then
begin
waveOutGetErrorText (status, err_text, SizeOf (err_text));
Raise Exception.CreateFmt ('Error %d writing wave output - %s', [status, err_text]);
end;
end;
procedure TToneburst.Shutdown;
begin
if FBusy then waveOutReset (hWave_out);
end;
procedure TToneburst.SetAmplitude (const Value: single);
begin
FAmplitude := Value;
if Famplitude < 0 then FAmplitude := 0.0;
if FAmplitude > 1.0 then FAmplitude := 1.0;
sine_table_valid := False;
end;
end.
karena saya kurang paham dengan code delphi, maka saya kesulitan untuk menerjemahkan source code delphi menjadi rumus biasa?
adakah yang bisa membantu??
NB:
code delphi nya diubah menjadi rumus biasa, agar saya bisa memahami / mempelajari rumus yang ada pada unit beeper tersebut.
more 18 years ago
gormet
pada Mas-mas, Mba-mba yang ada di sini....
di tunggu bala bantuannya, bisa berupa saran, link ke situs yang berkaitan, atau apalah agar pertanyaan saya dapat terpecahkan...
makasih sebelumnya.
more 18 years ago
Tbawor
unit ini sptnya berisi ttg PCM audio, coba di wikipedia aj banyak rumus ttg frequency, modulasi, amplitudo, stereo PCM dll
more 18 years ago
gormet
unit ini sptnya berisi ttg PCM audio, coba di wikipedia aj banyak rumus ttg frequency, modulasi, amplitudo, stereo PCM dllterimakasih mas Tbawor, beberapa rumus dari wikipedia masih dalam tahap dipelajari. mungkin ada informasi yang lebih spesifik?
more ...
- Pages:
- 1
reply |
Report Obsolete
AI Forward
🚀 We're thrilled to partner with Alibaba Cloud for "AI Forward - Alibaba Cloud Global Developer Summit 2025" in Jakarta! Join us and explore the future of AI. Register now:
https://int.alibabacloud.com/m/1000400772/
#AlibabaCloud #DeveloperSummit #Jakarta #AIFORWARD
Last Articles
Last Topic
- PascalTalk #6: (Podcast) Kuliah IT di luar negeri, susah gak sih?
by LuriDarmawan in Tutorial & Community Project more 5 years ago - PascalTalk #5: UX: Research, Design and Engineer
by LuriDarmawan in Tutorial & Community Project more 5 years ago - PascalTalk #4: Obrolan Ringan Seputar IT
by LuriDarmawan in Tutorial & Community Project more 5 years ago - PascalTalk #2: Membuat Sendiri SMART HOME
by LuriDarmawan in Tutorial & Community Project more 5 years ago - PascalTalk #3: RADically Fast and Easy Mobile Apps Development with Delphi
by LuriDarmawan in Tutorial & Community Project more 5 years ago - PascalTalk #1: Pemanfaatan Artificial Intelligence di Masa Covid-19
by LuriDarmawan in Tutorial & Community Project more 5 years ago - Tempat Latihan Posting
by LuriDarmawan in OOT more 5 years ago - Archive
- Looping lagi...
by idhiel in Hal umum tentang Pascal Indonesia more 13 years ago - [ask] koneksi ke ODBC user Dsn saat runtime dengan ado
by halimanh in FireBird more 13 years ago - Validasi menggunakan data tanggal
by mas_kofa in Hal umum tentang Pascal Indonesia more 13 years ago
Random Topic
- mencari data update pada tabel relasi?
by dels in MsSQL more 17 years ago - filter combobox
by nurez in Hal umum tentang Pascal Indonesia more 18 years ago - cara memasukkan data ke program......
by yulizar in Tip n Trik Pemrograman more 18 years ago - Program yang bisa diupdate
by Fransisca_cicilia in Hal umum tentang Pascal Indonesia more 16 years ago - ada yang salah g' dng SQL commandku
by arjuna_1982 in MySQL more 16 years ago - Gimana cara buat popup?
by jancky in Tip n Trik Pemrograman more 17 years ago - Ada yang tau komponentnya?
by p2bf in Tip n Trik Pemrograman more 18 years ago - beda tabel beda fungsi..?
by nurez in OOT more 19 years ago - Print-out dinamis
by irosyidi in Tip n Trik Pemrograman more 19 years ago - mau tanya tentang listview
by epitra in Tip n Trik Pemrograman more 17 years ago