unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls,adlib,
mmsystem, windows,DynLibs;
const
Channels = 2;
BitsPerSample = 16;
SampleRate = 44100; // Nombre d'échantillons par seconde
BufSize = 8192+1024 ; // Taille du tampon audio x 2 // buffersize == module speed !! (neointro.hsc) is now ok !!
BufferCount = 4;
type
{ TForm1 }
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Opl_Process(BufferIndex: Integer);
private
buffers: array[0..BufferCount-1] of array[0..BufSize-1] of Byte;
waveHeaders: array[0..BufferCount-1] of TWaveHdr;
currentBuffer: Integer;
public
end;
var
Form1: TForm1;
waveOut: HWAVEOUT;
ok_flag: Boolean = false;
libHandle: TLibHandle;
error: DWORD;
core: boolean = false;
opl : Pointer; // file pointer !!
tick : integer;
implementation
{$R *.lfm}
procedure HandleError(const Str: PAnsiChar);
begin
if Str <> nil then
begin
ShowMessage('Error: ' + Str);
Halt(1);
end;
end;
procedure SavePCMBuffer(const Buffer: Pointer; BufferSize: Integer; const FileName: string);
var
FileHandle: TFileStream;
begin
try
FileHandle := TFileStream.Create(FileName, fmOpenWrite or fmCreate);
try
// Écrire les données du tampon
FileHandle.Write(Buffer^, BufferSize);
finally
FileHandle.Free;
end;
except
on E: Exception do
ShowMessage('Erreur lors de la sauvegarde du fichier PCM: ' + E.Message);
end;
end;
function WaveOutCallback(hwo: HWAVEOUT; uMsg: UINT; dwInstance, dwParam1, dwParam2: DWORD_PTR): DWORD; stdcall;
begin
if uMsg = WOM_DONE then
begin
Form1.Opl_Process(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_NORMAL);
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 lors de l''ouverture du périphérique audio');
// buffers init
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 ;
dwFlags := 0;
end;
waveOutPrepareHeader(waveOut, @Form1.waveHeaders[i], SizeOf(TWaveHdr));
waveOutWrite(waveOut, @Form1.waveHeaders[i], SizeOf(TWaveHdr));
end;
Form1.currentBuffer := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
FileName : string;
begin
libHandle := LoadLibrary('adlib.dll');
if libHandle = 0 then
begin
error := GetLastError;
ShowMessage('Erreur chargement DLL: ' + IntToStr(error));
end;
// FileName := 'kya.dmo'; // Benjamin Gérardin Twin-tracker
// FileName := 'neo_intro.xms'; // the famous Neo-Intro when PC had FM OPL soundchip and AMIGA PAULA !!! :)
// FileName := 'ezerious.hsc'; // Hannes Seifert / Input
FileName := 'neo intro.hsc'; // Neo-Intro hsc format
core := CreateCore(44100,true,true,0); // create OPL core : srate / 16bit? / stereo? / core type 0,1,2,3
{Harekiet's, 0} // CWemuopl
{Ken Silverman's, 1} // CKemuopl
{Jarek Burczynski's, 2}// CEmuopl
{Nuked OPL3, 3} // CNemuopl
ShowMessage('Init OPL Core OK !! ' );
Set_OPLchip(2); // TYPE_OPL2, TYPE_OPL3, TYPE_DUAL_OPL2 -- 0/1/2 --
Init_Opl();
opl := Load_Mod(Pchar(filename));
// Opl_Process(Form1.currentBuffer);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
InitAudio;
ok_flag := true;
end;
procedure TForm1.Opl_Process(BufferIndex: Integer);
var
smp_to_read: Integer;
begin
smp_to_read := BufSize div (Channels * (BitsPerSample div 8));
Write_pcm(@buffers[BufferIndex][0], smp_to_read);
Player_Update();
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
end;
end.
Recent
