Arsip: Mengubah SourceCode Delphi menjadi Rumus Biasa

 
user image
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.
user image
more 18 years ago

gormet

ke atas kan lagi ah.... :) siapa tau ada yang bantu....
user image
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.
user image
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
user image
more 18 years ago

gormet

unit ini sptnya berisi ttg PCM audio, coba di wikipedia aj banyak rumus ttg frequency, modulasi, amplitudo, stereo PCM dll
terimakasih mas Tbawor, beberapa rumus dari wikipedia masih dalam tahap dipelajari. mungkin ada informasi yang lebih spesifik?
more ...
  • Pages:
  • 1
Share to

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

Random Topic

Local Business Directory, Search Engine Submission & SEO Tools FreeWebSubmission.com SonicRun.com