{* UltraStar Deluxe - Karaoke Game
 *
 * UltraStar Deluxe is the legal property of its developers, whose names
 * are too numerous to list here. Please refer to the COPYRIGHT
 * file distributed with this source distribution.
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; see the file COPYING. If not, write to
 * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 * Boston, MA 02110-1301, USA.
 *
 * $URL$
 * $Id$
 *}

unit UAudioCore_Portaudio;

interface

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

{$I ../switches.inc}

uses
  Classes,
  SysUtils,
  portaudio;

type
  TAudioCore_Portaudio = class
    private
      InitCount: integer; ///< keeps track of the number of Initialize/Terminate calls
    public
      constructor Create();
      class function GetInstance(): TAudioCore_Portaudio;
      function Initialize(): boolean;
      function Terminate(): boolean;
      function GetPreferredApiIndex(): TPaHostApiIndex;
      function TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: double): boolean;
  end;

implementation

uses
  ULog;

{*
 * The default API used by Portaudio is the least common denominator
 * and might lack efficiency. In addition it might not even work.
 * We use an array named ApiPreferenceOrder with which we define the order of
 * preferred APIs to use. The first API-type in the list is tried first.
 * If it is not available the next one is tried and so on ...
 * If none of the preferred APIs was found the default API (detected by
 * portaudio) is used.
 *
 * Pascal does not permit zero-length static arrays, so you must use paDefaultApi
 * as an array's only member if you do not have any preferences.
 * You can also append paDefaultApi to a non-zero length preferences array but
 * this is optional because the default API is always used as a fallback.
 *}
const
  paDefaultApi = -1;
const
  ApiPreferenceOrder:
{$IF Defined(MSWINDOWS)}
    // Note1: Portmixer has no mixer support for paASIO and paWASAPI at the moment
    // Note2: Windows Default-API is MME, but DirectSound is faster
    array[0..0] of TPaHostApiTypeId = ( paDirectSound );
{$ELSEIF Defined(DARWIN)}
    array[0..0] of TPaHostApiTypeId = ( paDefaultApi ); // paCoreAudio
{$ELSEIF Defined(UNIX)}
    // Note: Portmixer has no mixer support for JACK at the moment
    array[0..2] of TPaHostApiTypeId = ( paALSA, paJACK, paOSS );
{$ELSE}
    array[0..0] of TPaHostApiTypeId = ( paDefaultApi );
{$IFEND}


{ TAudioInput_Portaudio }

var
  Instance: TAudioCore_Portaudio;

constructor TAudioCore_Portaudio.Create();
begin
  inherited;
  InitCount := 0;
end;

class function TAudioCore_Portaudio.GetInstance(): TAudioCore_Portaudio;
begin
  if not assigned(Instance) then
    Instance := TAudioCore_Portaudio.Create();
  Result := Instance;
end;

function TAudioCore_Portaudio.Initialize(): boolean;
var
  Err: TPaError;
begin
  // initialize only once
  if (InitCount > 0) then
  begin
    Inc(InitCount);
    Result := true;
    Exit;
  end;

  // init Portaudio
  Err := Pa_Initialize();
  if (Err <> paNoError) then
  begin
    Log.LogError(Pa_GetErrorText(Err), 'TAudioCore_Portaudio.Initialize');
    Result := false;
    Exit;
  end;

  // only increment on success
  Inc(InitCount);
  Result := true;
end;

function TAudioCore_Portaudio.Terminate(): boolean;
var
  Err: TPaError;
begin
  // decrement usage count
  Dec(InitCount);
  if (InitCount > 0) then
  begin
    // do not terminate yet
    Result := true;
    Exit;
  end;

  // terminate if usage count is 0
  Err := Pa_Terminate();
  if (Err <> paNoError) then
  begin
    Log.LogError(Pa_GetErrorText(Err), 'TAudioCore_Portaudio.Terminate');
    Result := false;
    Exit;
  end;

  Result := true;
end;

function TAudioCore_Portaudio.GetPreferredApiIndex(): TPaHostApiIndex;
var
  i:        integer;
  apiIndex: TPaHostApiIndex;
  apiInfo:  PPaHostApiInfo;
begin
  result := -1;

  // select preferred sound-API
  for i:= 0 to High(ApiPreferenceOrder) do
  begin
    if (ApiPreferenceOrder[i] <> paDefaultApi) then
    begin
      // check if API is available
      apiIndex := Pa_HostApiTypeIdToHostApiIndex(ApiPreferenceOrder[i]);
      if (apiIndex >= 0) then
      begin
        // we found an API but we must check if it works
        // (on linux portaudio might detect OSS but does not provide
        // any devices if ALSA is enabled)
        apiInfo := Pa_GetHostApiInfo(apiIndex);
        if (apiInfo^.deviceCount > 0) then
        begin
          Result := apiIndex;
          break;
        end;
      end;
    end;
  end;

  // None of the preferred APIs is available -> use default
  if (result < 0) then
  begin
    result := Pa_GetDefaultHostApi();
  end;
end;

{*
 * Portaudio test callback used by TestDevice().
 *}
function TestCallback(input: pointer; output: pointer; frameCount: longword;
      timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags;
      inputDevice: pointer): integer; cdecl;
begin
  // this callback is called only once
  result := paAbort;
end;

(*
 * Tests if the callback works. Some devices can be opened without
 * an error but the callback is never called. Calling Pa_StopStream() on such
 * a stream freezes USDX then. Probably because the callback-thread is deadlocked
 * due to some bug in portaudio. The blocking Pa_ReadStream() and Pa_WriteStream()
 * block forever too and though can't be used for testing.
 *
 * To avoid freezing Pa_AbortStream (or Pa_CloseStream which calls Pa_AbortStream)
 * can be used to force the stream to stop. But for some reason this stops debugging
 * in gdb with a "no process found" message.
 *
 * Because freezing devices are non-working devices we test the devices here to
 * be able to exclude them from the device-selection list.
 *
 * Portaudio does not provide any test to check this error case (probably because
 * it should not even occur). So we have to open the device, start the stream and
 * check if the callback is called (the stream is stopped if the callback is called
 * for the first time, so we can poll until the stream is stopped).
 *
 * Another error that occurs is that some devices (even the default device) might
 * work at the beginning but stop after a few calls (maybe 50) of the callback.
 * For me this problem occurs with the default output-device. The "dmix" or "front"
 * device must be selected instead. Another problem is that (due to a bug in
 * portaudio or ALSA) the "front" device is not detected every time portaudio
 * is started. Sometimes it needs two or more restarts.
 *
 * There is no reasonable way to test for these errors. For the first error-case
 * we could test if the callback is called 50 times but this can take a second
 * for each device and it can fail in the 51st or even 100th callback call then.
 *
 * The second error-case cannot be tested at all. How should we now that one
 * device is missing if portaudio is not even able to detect it.
 * We could start and terminate Portaudio for several times and see if the device
 * count changes but this is ugly.
 *
 * Conclusion: We are not able to autodetect a working device with
 *   portaudio (at least not with the newest v19_20071207) at the moment.
 *   So we have to provide the possibility to manually select an output device
 *   in the UltraStar options if we want to use portaudio instead of SDL.
 *)
function TAudioCore_Portaudio.TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: double): boolean;
const
  altSampleRates: array[0..1] of double = (44100, 48000); // alternative sample-rates
var
  stream:  PPaStream;
  err:     TPaError;
  cbWorks: boolean;
  cbPolls: integer;
  i:       integer;
begin
  Result := false;

  if (sampleRate <= 0) then
    sampleRate := 44100;

  // check if device supports our input-format
  err := Pa_IsFormatSupported(inParams, outParams, sampleRate);
  if (err <> paNoError) then
  begin
    // we cannot fix the error -> exit
    if (err <> paInvalidSampleRate) then
      Exit;

    // try alternative sample-rates to the detected one
    sampleRate := 0;
    for i := 0 to High(altSampleRates) do
    begin
      // do not check the detected sample-rate twice
      if (altSampleRates[i] = sampleRate) then
        continue;
      // check alternative
      err := Pa_IsFormatSupported(inParams, outParams, altSampleRates[i]);
      if (err = paNoError) then
      begin
        // sample-rate works
        sampleRate := altSampleRates[i];
        break;
      end;
    end;
    // no working sample-rate found
    if (sampleRate = 0) then
      Exit;
  end;

  // FIXME: for some reason gdb stops after a call of Pa_AbortStream()
  // which is implicitely called by Pa_CloseStream().
  // gdb's stops with the message: "ptrace: no process found".
  // Probably because the callback-thread is killed what confuses gdb.
  {$IF Defined(Debug) and Defined(Linux)}
  cbWorks := true;
  {$ELSE}
  // open device for testing
  err := Pa_OpenStream(stream, inParams, outParams, sampleRate,
          paFramesPerBufferUnspecified,
          paNoFlag, @TestCallback, nil);
  if (err <> paNoError) then
  begin
    exit;
  end;

  // start the callback
  err := Pa_StartStream(stream);
  if (err <> paNoError) then
  begin
    Pa_CloseStream(stream);
    exit;
  end;

  cbWorks := false;
  // check if the callback was called (poll for max. 200ms)
  for cbPolls := 1 to 20 do
  begin
    // if the test-callback was called it should be aborted now
    if (Pa_IsStreamActive(stream) = 0) then
    begin
      cbWorks := true;
      break;
    end;
    // not yet aborted, wait and try (poll) again
    Pa_Sleep(10);
  end;

  // finally abort the stream
  Pa_CloseStream(stream);
  {$IFEND}
  
  Result := cbWorks;
end;

end.