unit uBafTranslationModule;

// this code is under the BAF fair use license (BFUL) - https://bafbal.de/index.php?title=Bful
// module for translation
// https://bafbal.de/index.php?title=Modul_Translation

interface

uses System.Math, System.SysUtils, System.Classes, uBafTypes, uBafInterpreter,
    DB;

type
  TBafTranslationObject = class
    FTrans: string;
    FTrans2: string;
  end;

  TBafTranslationModule = class(TBafInterpreterCustomModule)
  protected
    procedure SetLanguage;
    function Translate(AKey: string): string;
    function GetLanguage(AParam: string): string;
    class procedure FillCache;
    class procedure AddCache(AWord, ATrans1, ATrans2: string);
  public
    constructor Create; override;
    destructor Destroy; override;
    function InterpretLine(AExecInter: TBafCustomInterpreter): boolean; override;
    function ReplaceFunction(ACommand: string; AParams: TStrings; var AResult: string): boolean; override;
    class procedure ClassSetLanguage(ALanguage: string);
    class function BafTranslate(AKey: string): string;
  end;

var
  gvLanguageId: string;
  gvLanguageId2: string;


implementation

{ TBafTranslationModule }

uses dmMain, uBafDataCache;

const
  QNAME = 'Translation';

var
  mvTranslationCache: TStringList;
  mvLanguageName: string;


class procedure TBafTranslationModule.AddCache(AWord, ATrans1, ATrans2: string);
var
  LObject: TBafTranslationObject;
begin
  LObject := TBafTranslationObject.Create;
  LObject.FTrans := ATrans1;
  LObject.FTrans2 := ATrans2;
  mvTranslationCache.AddObject(AWord, LObject);
end;

constructor TBafTranslationModule.Create;
begin
  inherited;
end;

destructor TBafTranslationModule.Destroy;
begin

  inherited;
end;

class procedure TBafTranslationModule.FillCache;
var
  LSql: string;
  LParams: TBafParams;
  LDataset: TDataSet;
begin
  mvTranslationCache.Clear;
  case dataMain.DefaultCon.BafGen of
    bg303TT:
      LSql := 'select w.word, t1.translation as trans_1, t2.translation as trans_2 '
        + 'from  neuland.translate_word w '
        + '  left outer join neuland.translate_translation t1 '
        + '    on t1.translate_word_id = w.translate_word_id '
        + '    and t1.translate_language_id = :k1 '
        + '  left outer join neuland.translate_translation t2 '
        + '    on t2.translate_word_id = w.translate_word_id '
        + '    and t2.translate_language_id = :k2 ';
    else
      LSql := 'select w.word, t1.translation as trans_1, t2.translation as trans_2 '
        + 'from  translate_word w '
        + '  left outer join translate_translation t1 '
        + '    on t1.translate_word_id = w.translate_word_id '
        + '    and t1.translate_language_id = :k1 '
        + '  left outer join translate_translation t2 '
        + '    on t2.translate_word_id = w.translate_word_id '
        + '    and t2.translate_language_id = :k2 ';
  end;
  LParams := dataMain.QueryPrepare(dataMain.DefaultCon, QNAME, LSql);
  LParams.ParamAsString('k1', gvLanguageId);
  LParams.ParamAsString('k2', gvLanguageId2);
  LDataset := dataMain.QueryOpen(dataMain.DefaultCon, QNAME);
  while not LDataset.Eof do begin
    AddCache(LDataset.FieldByName('word').AsString,
        LDataset.FieldByName('trans_1').AsString,
        LDataset.FieldByName('trans_2').AsString);
    LDataset.Next;
  end;
end;

function TBafTranslationModule.GetLanguage(AParam: string): string;
begin
  AParam := AnsiLowerCase(AParam);
  if AParam = 'id' then
    result := gvLanguageId
  else
    result := mvLanguageName;
end;

function TBafTranslationModule.ReplaceFunction(ACommand: string;
  AParams: TStrings; var AResult: string): boolean;
begin
  inherited;
  result := true;
  if ACommand = '$T' then AResult := Translate(AParams[0])
  else if ACommand = '$LANGUAGE' then AResult := GetLanguage(AParams[0])

  else result := false;

end;

class function TBafTranslationModule.BafTranslate(AKey: string): string;
var
  LIx: integer;
  LObject: TBafTranslationObject;
  LSql: string;
  LParams: TBafParams;
begin
  if copy(AKey, 1, 3) = '$T(' then begin
    AKey := copy(AKey, 4, Length(AKey) - 4);
    LIx := mvTranslationCache.IndexOf(AKey);
    if LIx = -1 then begin     // we don't have
      try
        case dataMain.DefaultCon.BafGen of
          bg303TT:
            LSql := 'insert into neuland.translate_word (translate_word_id, word, datechg) '
                + 'values (:kid, :kword, :kdatechg)';
          else
            LSql := 'insert into translate_word (translate_word_id, word, datechg) '
                + 'values (:kid, :kword, :kdatechg)';
        end;
        LParams := dataMain.QueryPrepare(dataMain.DefaultCon, QNAME, LSql);
        LParams.ParamAsString('kid', BafGetGuid);
        LParams.ParamAsString('kword', AKey);
        LParams.ParamAsDateTime('kdatechg', now);
        dataMain.QueryExecute(dataMain.DefaultCon, QNAME);
        AddCache(AKey, '', '');
        result := AKey;
      except

      end;
    end
    else
    begin   // we have
      LObject := mvTranslationCache.Objects[LIx] as TBafTranslationObject;
      result := LObject.FTrans;
      if result = '' then
        result := LObject.FTrans2;
      if result = '' then
        result := AKey;
    end;
  end
  else
    result := AKey;
end;

class procedure TBafTranslationModule.ClassSetLanguage(ALanguage: string);
var
  LParams: TBafParams;
  LDataset: TDataSet;
begin
  try
    case dataMain.DefaultCon.BafGen of
      bg303TT:
        LParams := dataMain.QueryPrepare(dataMain.DefaultCon, QNAME,
            'select * from neuland.translate_language where upper(name) = upper(:kname)');
      else
        LParams := dataMain.QueryPrepare(dataMain.DefaultCon, QNAME,
            'select * from translate_language where upper(name) = upper(:kname)');
    end;
    LParams.ParamAsString('kname', ALanguage);
    LDataset := dataMain.QueryOpen(dataMain.DefaultCon, QNAME);
    if not LDataset.Eof then begin
      mvLanguageName := LDataset.FieldByName('name').AsString;
      gvLanguageId := LDataset.FieldByName('translate_language_id').AsString;
      dataMain.UserIni.WriteString(CAT_LANGUAGE, 'Language', mvLanguageName);
      dataMain.UserIni.UpdateFile;
      FillCache;
      gvBafDataCache.RefreshAll;
    end
    else begin
      FillCache;
      gvBafDataCache.RefreshAll;
    end;
  except
    // probably no table translate_language yet
  end;
end;

procedure TBafTranslationModule.SetLanguage;
begin
  TBafTranslationModule.ClassSetLanguage(FindParamStringReplaced('z', ''));
  FInter.ChangeLanguage;
end;

function TBafTranslationModule.Translate(AKey: string): string;
var
  LIx: integer;
  LObject: TBafTranslationObject;
  LSql: string;
  LParams: TBafParams;
begin
  LIx := mvTranslationCache.IndexOf(AKey);
  if LIx = -1 then begin     // we don't have
    try
      case dataMain.DefaultCon.BafGen of
        bg303TT:
          LSql := 'insert into neuland.translate_word (translate_word_id, word, datechg) '
              + 'values (:kid, :kword, :datechg)';
        else
          LSql := 'insert into translate_word (translate_word_id, word, datechg) '
              + 'values (:kid, :kword, :datechg)';
      end;
      LParams := dataMain.QueryPrepare(dataMain.DefaultCon, QNAME, LSql);
      LParams.ParamAsString('kid', BafGetGuid);
      LParams.ParamAsString('kword', AKey);
      LParams.ParamAsDateTime('datechg', now);
      dataMain.QueryExecute(dataMain.DefaultCon, QNAME);
      AddCache(AKey, '', '');
      result := AKey;
    except

    end;
  end
  else
  begin   // we have
    LObject := mvTranslationCache.Objects[LIx] as TBafTranslationObject;
    result := LObject.FTrans;
    if result = '' then
      result := LObject.FTrans2;
    if result = '' then
      result := AKey;
  end;
end;

function TBafTranslationModule.InterpretLine(AExecInter: TBafCustomInterpreter): boolean;
var
  LInter: TBafCustomInterpreter;
begin
  LInter := FExecInter;
  try
    FExecInter := AExecInter;

    result := true;
    if FExecInter.LineF = '#set_language' then SetLanguage
    else if FExecInter.LineF = '#setlanguage' then SetLanguage
    else if FExecInter.LineF = '#language_set' then SetLanguage


    else result := false;
  finally
    FExecInter := LInter;
  end;
end;

initialization
  mvTranslationCache := TStringList.Create;
  mvTranslationCache.Sorted := true;
  mvTranslationCache.OwnsObjects := true;

finalization
  FreeAndNil(mvTranslationCache);

end.
