unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
ExtCtrls, Spin, mmsystem, windows, openmpt;
const
Channels = 2;
BitsPerSample = 16;
SampleRate = 44100; // number of samples per second
BufSize = 8192 ; // multiple of 2
BufferCount = 2;
type
{ TForm1 }
TForm1 = class(TForm)
bt_stop: TButton;
bt_play: TButton;
bt_pause: TButton;
FloatSpinEdit1: TFloatSpinEdit;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Timer1: TTimer;
TrackBar1: TTrackBar;
procedure bt_pauseClick(Sender: TObject);
procedure bt_playClick(Sender: TObject);
procedure bt_stopClick(Sender: TObject);
procedure FloatSpinEdit1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
private
buffers: array[0..BufferCount-1] of array[0..BufSize-1] of SmallInt;
waveHeaders: array[0..BufferCount-1] of TWaveHdr;
currentBuffer: Integer;
public
end;
var
Form1: TForm1;
waveOut: HWAVEOUT;
waveHeader: TWaveHdr;
ok_flag : boolean = false;
o_mod : Pointer;
o_mod_paramindex : Integer;
o_mod_info : String;
o_mod_repeat : Integer;
o_mod_duration, o_mod_position,o_mod_set_pos : Single;
ctl : POpenMPTModuleInitialCtl;
lgfct : Pointer;
lgusr : Pointer;
sc : Pointer;
implementation
{$R *.lfm}
{ TForm1 }
procedure FillBuff(bufferIndex: Integer);
var
GenSmp, NumSmp: Integer;
begin
if ok_flag then
begin
bufferIndex := Form1.currentBuffer;
NumSmp := BufSize div (Channels * (BitsPerSample div 16));
// GenSmp := openmpt_module_read_mono(o_mod,44100,NumSmp, @Form1.buffers[bufferIndex][0]);
// GenSmp := openmpt_module_read_stereo(o_mod,44100,NumSmp, @Form1.buffers[bufferIndex][0],@Form1.buffers[bufferIndex][0]);
GenSmp := openmpt_module_read_interleaved_stereo(o_mod,44100, NumSmp,@Form1.buffers[bufferIndex][0]); // Channels = 2
end;
end;
function WaveOutCallback(hwo: HWAVEOUT; uMsg: UINT; dwInstance, dwParam1, dwParam2: DWORD_PTR): DWORD; stdcall;
begin
if uMsg = WOM_DONE then
begin
FillBuff(Form1.currentBuffer);
waveOutWrite(hwo, @Form1.waveHeaders[Form1.currentBuffer], SizeOf(TWaveHdr));
Form1.currentBuffer := (Form1.currentBuffer + 1) mod BufferCount;
end;
Result := 0;
end;
procedure InitAudio;
var
wFormat: TWaveFormatEx;
i: Integer;
begin
// SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_LOWEST);
with wFormat do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := Channels;
nSamplesPerSec := SampleRate;
wBitsPerSample := BitsPerSample;
nBlockAlign := (wBitsPerSample * nChannels) div 8;
nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
cbSize := 0;
end;
if waveOutOpen(@waveOut, WAVE_MAPPER, @wFormat, QWORD(@WaveOutCallback), 0, CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
raise Exception.Create('Erreur ouverture periph audio');
// buffers
for i := 0 to BufferCount - 1 do
begin
ZeroMemory(@Form1.waveHeaders[i], SizeOf(TWaveHdr));
with Form1.waveHeaders[i] do
begin
lpData := @Form1.buffers[i][0];
dwBufferLength := BufSize * SizeOf(SmallInt);
dwFlags := 0;
end;
waveOutPrepareHeader(waveOut, @Form1.waveHeaders[i], SizeOf(TWaveHdr));
end;
Form1.currentBuffer := 0;
for i := 0 to BufferCount - 1 do
begin
FillBuff(i);
waveOutWrite(waveOut, @Form1.waveHeaders[i], SizeOf(TWaveHdr));
end;
end;
procedure LoadBinaryFileToBuffer(const FileName: string; var Buffer: TBytes);
var
MemoryStream: TMemoryStream;
begin
MemoryStream := TMemoryStream.Create;
try
MemoryStream.LoadFromFile(FileName);
SetLength(Buffer, MemoryStream.Size); // Ajuste la taille du buffer
MemoryStream.ReadBuffer(Buffer[0], MemoryStream.Size);
finally
MemoryStream.Free;
end;
end;
procedure DisplayMetadata(mod_: Pointer; const key: pchar; memo: TMemo);//inline;
var
answer: pchar;
begin
answer := openmpt_module_get_metadata(mod_, key);
if assigned(answer) then
begin
if length(answer) > 0 then
memo.Lines.Add(key + ' : ' + answer);
// free mem
openmpt_free_string(answer);
end
else
begin
memo.Lines.Add('No Data For : ' + key);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Buf: array of Byte;
FileName: string;
begin
FileName := 'amegas.mod';
try
LoadBinaryFileToBuffer(FileName, Buf);
except
on E: Exception do
ShowMessage('Erreur Fichier : ' );
end;
// load module to memory from buffer !
o_mod := openmpt_module_create_from_memory2(@Buf[0],Length(Buf),nil,lgusr,nil,nil,nil,nil,ctl);
o_mod_repeat := openmpt_module_set_repeat_count(o_mod,-1); //-1 infinite ; 0 play once ; n>0 play once and repeat n times after
o_mod_paramindex := openmpt_module_set_render_param(o_mod,2,50);
DisplayMetadata(o_mod,'tracker',memo1);
DisplayMetadata(o_mod,'type',memo1); //type_long
DisplayMetadata(o_mod,'artist',memo1);
DisplayMetadata(o_mod,'title',memo1);
DisplayMetadata(o_mod,'date',memo1);
DisplayMetadata(o_mod,'message',memo1); // message_raw
o_mod_duration := openmpt_module_get_duration_seconds(o_mod);
Memo1.Lines.Add('Duration : ' + FloatToStrF( o_mod_duration, ffFixed, 8, 2 ));
end;
procedure TForm1.FormShow(Sender: TObject);
begin
InitAudio;
ok_flag := true;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if ok_flag then
begin
o_mod_position := openmpt_module_get_position_seconds(o_mod);
label1.Caption := 'Position : ' + FloatToStrF(o_mod_position, ffFixed, 8, 2) ;
end;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
if ok_flag then
o_mod_paramindex := openmpt_module_set_render_param(o_mod,2,TrackBar1.Position); // 2 = stereo sep
//RENDER_MASTERGAIN_MILLIBEL = 1,
//RENDER_STEREOSEPARATION_PERCENT = 2, 0-100
//RENDER_INTERPOLATIONFILTER_LENGTH = 3,
//RENDER_VOLUMERAMPING_STRENGTH = 4
end;
procedure TForm1.FloatSpinEdit1Change(Sender: TObject);
begin
if ok_flag then
o_mod_set_pos := openmpt_module_set_position_seconds(o_mod,FloatSpinEdit1.value);
end;
procedure TForm1.bt_stopClick(Sender: TObject);
var
i : integer;
begin
ok_flag := false;
// free buffer data !!
for i := 0 to BufferCount - 1 do
begin
ZeroMemory(@Form1.waveHeaders[i], SizeOf(TWaveHdr));
end;
waveOutClose(waveOut);
o_mod_set_pos := openmpt_module_set_position_seconds(o_mod, 0);
label1.Caption := 'Position : ' + '0.00' ;
end;
procedure TForm1.bt_playClick(Sender: TObject);
begin
// if not Assigned(waveOut) then
InitAudio;
ok_flag := true;
o_mod_position := openmpt_module_get_position_seconds(o_mod);
o_mod_set_pos := openmpt_module_set_position_seconds(o_mod,o_mod_position);
end;
procedure TForm1.bt_pauseClick(Sender: TObject);
begin
ok_flag := false;
waveOutPause(waveOut);
end;
end.
Recent
