 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2006, <kouriakine@mail.ru>
 Speaker, can speak English\Russian, uses Speech API.
 For working, it needs two COM objects to be installed:
 1)Freeware Microsoft Speech API 4.0 from URL:
   http://activex.microsoft.com/activex/controls/sapi/spchapi.exe
 2)Freeware speech engine Lernout&Hauspie Text-To-Speech from URL:
   http://activex.microsoft.com/activex/controls/agent2/lhttseng.exe - UK English
   http://activex.microsoft.com/activex/controls/agent2/lhttsrur.exe - Russin
 Modifications:
 20060325 - Creation & test
 20060906 - TextData(CHARSET_TEXT, 1, ... - enable \tags\
 ****************************************************************************
 }

unit _spk; { SPeaKer - Speech API client }

{$I _sysdef}

interface

uses
 SysUtils, Windows, Math, ActiveX, ComObj,
 _alloc, _str, _fio, speech;

 //////////////////////////////////////////////////////////////////////////////
 // Speech API control class.
 // 1)Use Speaker.Engine property to activate speech engines.
 //   Speaker.Engine:=-1; - switch off and free speech engine.
 //   Speaker.Engine:=n;  - n>=0, initialize and select speech engine number n.
 // 2)Use Speaker.Engines to enumerate available speech engines.
 // 3)Use Speaker.Speak property to set what you need to speak.
 //   Speaker.Speak:='Hello my dear!';
 // 4)Use Speaker.Pitch\Speed\Volume to control sound tone\speed\volume.
 // 5)Use Speaker.Pause\Stop to control sound playing.
 // Example:
 //  Speaker.Engine:=0;                        // Switch on speaker, 1st engine
 //  writeln(Speaker.Engines.Count);           // Number of available engines 
 //  Speaker.Engine:=Speaker.Engines.Count-1;  // Switch on last avail engine
 //  Speaker.Speak:='Hello, world.';           // Speak something
 //  Speaker.Engine:=-1;                       // Switch off speaker
 //////////////////////////////////////////////////////////////////////////////
type
 TSpeaker = class;
 ESpeaker = class(Exception);
 TSpeakerTextDataDoneCallback    = function (aSpeaker:TSpeaker; qTimeStamp:QWORD; dwFlags:DWORD):HResult;
 TSpeakerTextDataStartedCallback = function (aSpeaker:TSpeaker; qTimeStamp:QWORD):HResult;
 TSpeakerBookMarkCallback        = function (aSpeaker:TSpeaker; qTimeStamp:QWORD; dwMarkNum:DWORD):HResult;
 TSpeakerWordPositionCallback    = function (aSpeaker:TSpeaker; qTimeStamp:QWORD; dwByteOffset:DWORD):HResult;
 //
 // Speaker notify sink, for internal use only.
 //
 TSpeakerNotifySink = class(TInterfacedObject, ITTSBufNotifySink)
 private
  myOwner : TSpeaker;
 public
  // Construction/destrunction
  constructor Create(aOwner:TSpeaker);
  destructor  Destroy; override;
 public
  // ITTSBufNotifySink methods
  function TextDataDone(qTimeStamp: QWORD; dwFlags: DWORD): HResult; stdcall;
  function TextDataStarted(qTimeStamp: QWORD): HResult; stdcall;
  function BookMark(qTimeStamp: QWORD; dwMarkNum: DWORD): HResult; stdcall;
  function WordPosition(qTimeStamp: QWORD; dwByteOffset: DWORD): HResult; stdcall;
 end;
 //
 // General speaker class
 //
 TSpeaker = class(TLatch)
 private
  myIAMM           : IAudioMultimediaDevice; // To control audio device
  myTTSEnum        : ITTSEnum;               // To enumerate speech engines
  myITTSCentral    : ITTSCentral;            // Central to control speech
  myITTSAttributes : ITTSAttributes;         // Speech attributes
  myPause          : Boolean;                // Is device paused
  myEngines        : TText;                  // List of engines
  myEngine         : Integer;                // Selected engine
  myITTSBufNotifySink : ITTSBufNotifySink;   // Notification sink
  myOnTextDataDone    : TSpeakerTextDataDoneCallback;
  myOnTextDataStarted : TSpeakerTextDataStartedCallback;
  myOnBookMark        : TSpeakerBookMarkCallback;
  myOnWordPosition    : TSpeakerWordPositionCallback;
  procedure   FreeAllInterfaces;
  function    GetEngines:TText;
  function    GetEngine:Integer;
  procedure   SetEngine(aEngine:Integer);
  procedure   SetSpeak(const aPhrase:LongString);
  function    GetPause:Boolean;
  procedure   SetPause(aPause:Boolean);
  function    GetPitch:Word;
  procedure   SetPitch(aPitch:Word);
  function    GetSpeed:DWord;
  procedure   SetSpeed(aSpeed:DWord);
  function    GetVolume:DWord;
  procedure   SetVolume(aVolume:DWord);
  procedure   SetOnTextDataDone(aCallback:TSpeakerTextDataDoneCallback);
  procedure   SetOnTextDataStarted(aCallback:TSpeakerTextDataStartedCallback);
  procedure   SetOnBookMark(aCallBack:TSpeakerBookMarkCallback);
  procedure   SetOnWordPosition(aCallBack:TSpeakerWordPositionCallback);
 public
  constructor Create;
  destructor  Destroy; override;
  property    Engine  : Integer    read GetEngine write SetEngine;
  property    Engines : TText      read GetEngines;
  property    Speak   : LongString                write SetSpeak;
  property    Pause   : Boolean    read GetPause  write SetPause;
  property    Pitch   : Word       read GetPitch  write SetPitch;
  property    Speed   : DWord      read GetSpeed  write SetSpeed;
  property    Volume  : DWord      read GetVolume write SetVolume;
  property    OnTextDataDone    : TSpeakerTextDataDoneCallback    write SetOnTextDataDone;
  property    OnTextDataStarted : TSpeakerTextDataStartedCallback write SetOnTextDataStarted;
  property    OnBookMark        : TSpeakerBookMarkCallback        write SetOnBookMark;
  property    OnWordPosition    : TSpeakerWordPositionCallback    write SetOnWordPosition;
  procedure   Stop;
 end;

procedure Kill(var TheObject:TSpeaker); overload;

function Speaker:TSpeaker;

function SpeechApiInstalled:Boolean;

implementation

function SpeechApiInstalled:Boolean;
var str,key:ShortString;
begin
 Result:=False;
 try
  key:=Format('CLSID\%s\InprocServer32',[GuidToString(CLSID_MMAudioDest)]);
  str:=ReadRegistryString(HKEY_CLASSES_ROOT,key,'');
  if not FileExists(str) then Exit;
  key:=Format('CLSID\%s\InprocServer32',[GuidToString(CLSID_TTSEnumerator)]);
  str:=ReadRegistryString(HKEY_CLASSES_ROOT,key,'');
  if not FileExists(str) then Exit;
  key:=Format('Interface\%s',[GuidToString(IID_ITTSEnum)]);
  str:=ReadRegistryString(HKEY_CLASSES_ROOT,key,'');
  if IsEmptyStr(str) then Exit;
  key:=Format('Interface\%s',[GuidToString(IID_ITTSCentral)]);
  str:=ReadRegistryString(HKEY_CLASSES_ROOT,key,'');
  if IsEmptyStr(str) then Exit;
  key:=Format('Interface\%s',[GuidToString(IID_ITTSAttributes)]);
  str:=ReadRegistryString(HKEY_CLASSES_ROOT,key,'');
  if IsEmptyStr(str) then Exit;
  Result:=true;
 except
  on E:Exception do BugReport(E);
 end;
end;

constructor TSpeaker.Create;
begin
 inherited;
 myEngines:=NewText(0,8);
 myEngines.Master:=myEngines;
 myEngine:=-1;
end;

destructor TSpeaker.Destroy;
begin
 FreeAllInterfaces;
 Kill(myEngines);
 inherited;
end;

procedure TSpeaker.FreeAllInterfaces;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   myITTSBufNotifySink:=nil;
   myITTSAttributes:=nil;
   myITTSCentral:=nil;
   myTTSEnum:=nil;
   myIAMM:=nil;
   myEngines.Count:=0;
   myEngine:=-1;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function  TSpeaker.GetEngines:TText;
begin
 Result:=nil;
 if Assigned(Self) then begin
  Lock;
  Result:=myEngines;
  Unlock;
 end;
end;

function TSpeaker.GetEngine:Integer;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myEngine;
  Unlock;
 end;
end;

procedure TSpeaker.SetEngine(aEngine:Integer);
var
 NumFound : DWord;
 ModeInfo : TTSModeInfo;
 hInput   : THandle;
 hOutput  : THandle;
 hError   : THandle;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if aEngine<0 then aEngine:=-1;
   if aEngine<>myEngine then begin
    FreeAllInterfaces;
    if aEngine>=0 then begin
     if not SpeechApiInstalled
     then RAISE ESpeaker.Create('Speech API is not properly installed.'+CRLF+
                                'Please download & install two freeware components first:'+CRLF+
                                '1) http://activex.microsoft.com/activex/controls/sapi/spchapi.exe'+CRLF+
                                '2) http://activex.microsoft.com/activex/controls/agent2/lhttsrur.exe');
     hInput:=GetStdHandle(STD_INPUT_HANDLE);
     hOutput:=GetStdHandle(STD_OUTPUT_HANDLE);
     hError:=GetStdHandle(STD_ERROR_HANDLE);
     try
      // Switch off standard I/O hanles to avoide
      // possible problems with anonimous pipes.
      SetStdHandle(STD_INPUT_HANDLE,0);
      SetStdHandle(STD_OUTPUT_HANDLE,0);
      SetStdHandle(STD_ERROR_HANDLE,0);
      // Initialize audio device
      if not Succeeded(CoCreateInstance(CLSID_MMAudioDest, Nil, CLSCTX_ALL,
                                        IID_IAudioMultiMediaDevice, myIAMM))
      then RAISE ESpeaker.Create(Format('Interface %s is not available!',
                                       [GuidToString(CLSID_MMAudioDest)]));
      // Create speech engine enumerator
      if not Succeeded(CoCreateInstance(CLSID_TTSEnumerator, Nil, CLSCTX_ALL,
                                        IID_ITTSEnum, myTTSEnum))
      then RAISE ESpeaker.Create(Format('Interface %s is not available!',
                                       [GuidToString(CLSID_TTSEnumerator)]));
     finally
      SetStdHandle(STD_INPUT_HANDLE,hInput);
      SetStdHandle(STD_OUTPUT_HANDLE,hOutput);
      SetStdHandle(STD_ERROR_HANDLE,hError);
     end;
     // Check interfaces
     if not Assigned(myIAMM)
     then RAISE ESpeaker.Create(Format('Interface %s is not available!',
                                      [GuidToString(CLSID_MMAudioDest)]));
     if not Assigned(myTTSEnum)
     then RAISE ESpeaker.Create(Format('Interface %s is not available!',
                                      [GuidToString(CLSID_TTSEnumerator)]));
     // Select first engine
     if not Succeeded(myTTSEnum.Reset)
     then RAISE ESpeaker.Create('Could not TTSEnum.Reset');
     if not Succeeded(myTTSEnum.Next(1, ModeInfo, @NumFound))
     then RAISE ESpeaker.Create('Fails TTSEnum.Next');
     // Enumerate engines
     while NumFound > 0 do begin
      myEngines.Addln(StrPas(ModeInfo.szModeName));
      if not Succeeded(myTTSEnum.Next(1, ModeInfo, @NumFound))
      then RAISE ESpeaker.Create('Fails TTSEnum.Next');
     end;
     // Check if any speech engines found
     if myEngines.Count>0
     then aEngine:=Min(aEngine,myEngines.Count-1)
     else RAISE ESpeaker.Create('Speech engines is not found.');
     // Select engine aEngine
     if not Succeeded(myTTSEnum.Reset)
     then RAISE ESpeaker.Create('Could not TTSEnum.Reset');
     if not Succeeded(myTTSEnum.Skip(aEngine))
     then RAISE ESpeaker.Create('Fails TTSEnum.Skip');
     if not Succeeded(myTTSEnum.Next(1, ModeInfo, @NumFound))
     then RAISE ESpeaker.Create('Could not TTSEnum.Next');
     // Create speech engine Central interface
     if not Succeeded(myTTSEnum.Select(ModeInfo.gModeID, myITTSCentral, IUnknown(myIAMM)))
     then RAISE ESpeaker.Create('Fails TTSEnum.Select');
     if not Assigned(myITTSCentral)
     then RAISE ESpeaker.Create(Format('Interface %s is not available!',
                                      [GuidToString(IID_ITTSCentral)]));
     // Create speech engine attributes interface
     if not Succeeded(myITTSCentral.QueryInterface(IID_ITTSAttributes, myITTSAttributes))
     then RAISE ESpeaker.Create(Format('Interface %s is not available!',
                                    [GuidToString(IID_ITTSAttributes)]));
     // Create notify sink
     myITTSBufNotifySink:=TSpeakerNotifySink.Create(Self);
     // Now it's Ok.
     myEngine:=aEngine;
    end;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do begin
   FreeAllInterfaces;
   BugReport(E,Self);
  end;
 end;
end;

procedure TSpeaker.SetSpeak(const aPhrase:LongString);
var
 SData  : TSData;
 Buffer : LongString;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSCentral) then begin
    Buffer:=Trim(aPhrase);
    SData.dwSize := Length(Buffer) + 1;
    SData.pData  := pChar(Buffer);
    if myPause then begin
     if not Succeeded(myITTSCentral.AudioResume)
     then RAISE ESpeaker.Create('Fails ITTSCentral.AudioResume');
     myPause:=False;
    end;
    if not Succeeded(myITTSCentral.TextData(CHARSET_TEXT, 1, SData, Pointer(myITTSBufNotifySink), IID_ITTSBufNotifySink))
    then RAISE ESpeaker.Create('Fails ITTSCentral.TextData');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TSpeaker.GetPause:Boolean;
begin
 Result:=false;
 if Assigned(Self) then begin
  Lock;
  Result:=myPause;
  Unlock;
 end; 
end;

procedure TSpeaker.SetPause(aPause:Boolean);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSCentral) then begin
    if myPause <> aPause then begin
     if aPause then begin
      if not Succeeded(myITTSCentral.AudioPause)
      then RAISE ESpeaker.Create('Fails ITTSCentral.AudioPause');
     end else begin
      if not Succeeded(myITTSCentral.AudioResume)
      then RAISE ESpeaker.Create('Fails ITTSCentral.AudioResume');
     end;
     myPause:=aPause;
    end;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TSpeaker.Stop;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSCentral) then begin
    if not Succeeded(myITTSCentral.AudioReset)
    then RAISE ESpeaker.Create('Fails ITTSCentral.AudioReset');
    myPause:=False;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function  TSpeaker.GetPitch:Word;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSAttributes) then begin
    if not Succeeded(myITTSAttributes.PitchGet(Result))
    then RAISE ESpeaker.Create('Fails ITTSAttributes.PitchGet.');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TSpeaker.SetPitch(aPitch:Word);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSAttributes) then begin
    if not Succeeded(myITTSAttributes.PitchSet(aPitch))
    then RAISE ESpeaker.Create('Fails ITTSAttributes.PitchSet.');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function  TSpeaker.GetSpeed:DWord;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSAttributes) then begin
    if not Succeeded(myITTSAttributes.SpeedGet(Result))
    then RAISE ESpeaker.Create('Fails ITTSAttributes.SpeedGet.');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TSpeaker.SetSpeed(aSpeed:DWord);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSAttributes) then begin
    if not Succeeded(myITTSAttributes.SpeedSet(aSpeed))
    then RAISE ESpeaker.Create('Fails ITTSAttributes.SpeedGet.');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function  TSpeaker.GetVolume:DWord;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSAttributes) then begin
    if not Succeeded(myITTSAttributes.VolumeGet(Result))
    then RAISE ESpeaker.Create('Fails ITTSAttributes.VolumeGet.');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TSpeaker.SetVolume(aVolume:DWord);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Assigned(myITTSAttributes) then begin
    if not Succeeded(myITTSAttributes.VolumeSet(aVolume))
    then RAISE ESpeaker.Create('Fails ITTSAttributes.VolumeGet.');
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TSpeaker.SetOnTextDataDone(aCallback:TSpeakerTextDataDoneCallback);
begin
 if Assigned(Self) then begin
  Lock;
  myOnTextDataDone:=aCallBack;
  Unlock;
 end;
end;

procedure TSpeaker.SetOnTextDataStarted(aCallback:TSpeakerTextDataStartedCallback);
begin
 if Assigned(Self) then begin
  Lock;
  myOnTextDataStarted:=aCallBack;
  Unlock;
 end;
end;

procedure TSpeaker.SetOnBookMark(aCallBack:TSpeakerBookMarkCallback);
begin
 if Assigned(Self) then begin
  Lock;
  myOnBookMark:=aCallBack;
  Unlock;
 end;
end;

procedure TSpeaker.SetOnWordPosition(aCallBack:TSpeakerWordPositionCallback);
begin
 if Assigned(Self) then begin
  Lock;
  myOnWordPosition:=aCallBack;
  Unlock;
 end;
end;

procedure Kill(var TheObject:TSpeaker); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

constructor TSpeakerNotifySink.Create(aOwner:TSpeaker);
begin
 inherited Create;
 myOwner:=aOwner;
end;

destructor TSpeakerNotifySink.Destroy;
begin
 inherited;
end;

function TSpeakerNotifySink.TextDataDone(qTimeStamp: QWORD; dwFlags: DWORD): HResult; stdcall;
begin
 Result:=E_FAIL;
 try
  if Assigned(myOwner) then
  if Assigned(myOwner.myOnTextDataDone) then
  Result:=myOwner.myOnTextDataDone(myOwner,qTimeStamp, dwFlags);
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TSpeakerNotifySink.TextDataStarted(qTimeStamp: QWORD): HResult; stdcall;
begin
 Result:=E_FAIL;
 try
  if Assigned(myOwner) then
  if Assigned(myOwner.myOnTextDataStarted) then
  Result:=myOwner.myOnTextDataStarted(myOwner,qTimeStamp);
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TSpeakerNotifySink.BookMark(qTimeStamp: QWORD; dwMarkNum: DWORD): HResult; stdcall;
begin
 Result:=E_FAIL;
 try
  if Assigned(myOwner) then
  if Assigned(myOwner.myOnBookMark) then
  Result:=myOwner.myOnBookMark(myOwner, qTimeStamp,dwMarkNum);
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TSpeakerNotifySink.WordPosition(qTimeStamp: QWORD; dwByteOffset: DWORD): HResult; stdcall;
begin
 Result:=E_FAIL;
 try
  if Assigned(myOwner) then
  if Assigned(myOwner.myOnWordPosition) then
  Result:=myOwner.myOnWordPosition(myOwner, qTimeStamp, dwByteOffset);
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

 ///////////////////////////////////////////////////////////////////////////////
 // Speaker implementation
 ///////////////////////////////////////////////////////////////////////////////
const
 TheSpeaker : TSpeaker = nil;

function Speaker:TSpeaker;
begin
 if not Assigned(TheSpeaker) then begin
  TheSpeaker:=TSpeaker.Create;
  TheSpeaker.Master:=TheSpeaker;
 end;
 Result:=TheSpeaker;
end;

initialization

 Speaker.Ok;

finalization

 Kill(TheSpeaker);

end.
