BSOne.SFC/Tocsg.Module/PatternManager/ManagerPattern.pas

{*******************************************************}
{                                                       }
{       ManagerPattern                                  }
{                                                       }
{       Copyright (C) 2022 kku                          }
{                                                       }
{*******************************************************}

unit ManagerPattern;

interface

uses
  Tocsg.Obj, System.SysUtils, System.Classes, Winapi.Windows,
  System.Generics.Collections, Tocsg.Serializer, superobject;

// 한국어(한국)	ko-KR	0x0412	1042
// 영어(미국)	en-US	0x0409	1033
// 일본어(일본)	ja-JP	0x0411	1041
// 중국어(간체, 중국)	zh-CN	0x0804	2052
// 중국어(번체, 대만)	zh-TW	0x0404	1028
// Code 1

const
  DEF_LANG_ID = $412;
  SER_MGPTR_VER = 1;

  DAT_PTNSCH = 'ptnsch.dat';
  PWD_PTNSCH = 'Deq92So4*1kLp!m';

type
  TRuleType = (rtPattern, rtKeyword, rtExceptPattern, rtExceptKeyword); // ManagerRule.pas에도 있음 변동사항 발생 시 주의
  TRuleSeverity = (rsLow, rsNormal, rsHigh); // ManagerRule.pas에도 있음 변동사항 발생 시 주의

  TManagerPattern = class;
  TPatternBase = class(TTgObject)
  protected
    Owner_: TManagerPattern;
    bUse_: Boolean;
    NameList_: TStringList;
  public
    Constructor Create(aOwner: TManagerPattern; sl: TTgSerializerLoad = nil); virtual;
    Destructor Destroy; override;

    procedure Save(ss: TTgSerializerSave); virtual;

    procedure AddName(wLangId: WORD; sName: String);
    procedure ModName(wLangId: WORD; sName: String);
    procedure DelName(wLangId: WORD);
    function Name: String;
    procedure SetUse(bVal: Boolean);

    property NameList: TStringList read NameList_;
    property Use: Boolean read bUse_;
  end;

  TPatternEnt = class;
  TPatternEntList = class(TList<TPatternEnt>)
  protected
    bFreeEnt_: Boolean;
    nAndCnt_: Integer;
    procedure Notify(const Item: TPatternEnt; Action: TCollectionNotification); override;
  public
    Constructor Create(bFreeEnt: Boolean = true);
    function GetPtrnEntByName(sName: String): TPatternEnt;

    property FreeEnt: Boolean write bFreeEnt_;
    Property AndCount: Integer read nAndCnt_;
  end;

  TPatternEnt = class(TPatternBase)
  private
    Parent_: TPatternEnt;
    ChildList_: TPatternEntList;
    PatternList_: TStringList;
    nIfCnt_: Integer;
  public
    IsAnd: Boolean;
    RType: TRuleType;
    RSeverity: TRuleSeverity;
    Constructor Create(aOwner: TManagerPattern; aParent: TPatternEnt; sl: TTgSerializerLoad = nil; nIfCnt: Integer = 1);
    Destructor Destroy; override;

    procedure Save(ss: TTgSerializerSave); override;
    function PatternCount: Integer;
    function GetSearchText(bIncChild: Boolean = false): String;
    function FullName: String;

    property ChildList: TPatternEntList read ChildList_;
    property PatternList: TStringList read PatternList_;
    property IfCount: Integer read nIfCnt_;
  end;

  TManagerPattern = class(TTgObject)
  private
    wLangId_: WORD;
    EntList_: TPatternEntList;
    procedure SetLangId(wVal: WORD);
    function GetLangId: WORD;
  public
    Constructor Create(sLoadPath: String = '');
    Destructor Destroy; override;

    procedure Save(sPath: String = '');
    procedure Load(sPath: String = '');

    function GetUsePatternEnt(aPatternEntList: TPatternEntList): Integer;
    function GetPatternEntByName(sName: String): TPatternEnt;

    property LangId: WORD read GetLangId write SetLangId;
    property EntList: TPatternEntList read EntList_;
  end;

  TFndEnt = class;
  TFndEntList = class(TList<TFndEnt>)
  protected
    procedure Notify(const Item: TFndEnt; Action: TCollectionNotification); override;
  end;

  TFndEnt = class(TTgObject)
  private
    sName_: String;
    nHitCnt_: Integer;
    ChildList_: TFndEntList;
  public
  {$IFDEF _CTTSCH_}
    pNode: Pointer;
  {$ENDIF}
    Constructor Create(sName: String);
    Destructor Destroy; override;

    function HitCount: Integer;
    function ToJsonObj: ISuperObject;
    function ToEntInfoStr: String;

    property Name: String read sName_;
    property ChildList: TFndEntList read ChildList_;
  end;

  TManagerFound = class(TTgObject)
  private
    EntList_: TFndEntList;
    NameList_: TStringList;
    KwdEnt_: TFndEnt;
  public
    Constructor Create;
    Destructor Destroy; override;

    procedure Clear;
    procedure PushFoundPattern(sName: String; nHits: Integer);
    procedure PushFoundKeyword(sFoundStr: String);
    function ToJsonObj: ISuperObject;
    function ToEntInfoStr: String;

    property EntList: TFndEntList read EntList_;
  end;

function LangIdToStr(wLangId: WORD): String;

implementation

uses
  Tocsg.Safe, Tocsg.Exception, Tocsg.Encrypt, Tocsg.Path, Tocsg.Strings;

function LangIdToStr(wLangId: WORD): String;
begin
  case wLangId of
    $0412 : Result := '한국어';
    $0409 : Result := '영어';
    $0411 : Result := '일본어';
    $0804 : Result := '중국어(간체)';
    $0404 : Result := '중국어(번체)';
    1     : Result := 'Code';
    else Result := Format('Unknown(%X)', [wLangId]);
  end;
end;

{ TPatternBase }

Constructor TPatternBase.Create(aOwner: TManagerPattern; sl: TTgSerializerLoad = nil);
var
  i, nCnt: Integer;
  wLangId: WORD;
  sVal: String;
begin
  Inherited Create;
  Owner_ := aOwner;
  NameList_ := TStringList.Create;

  if sl <> nil then
  begin
    try
      bUse_ := sl.L_Boolean;
      nCnt := sl.L_Integer;
      for i := 0 to nCnt - 1 do
      begin
        wLangId := sl.L_WORD;
        sVal := sl.L_UTF8String;

        if (wLangId <> 0) and (sVal <> '') then
          NameList_.AddObject(sVal, TObject(wLangId));
//        if (wLangId <> '') and (sVal <> '') then
//          NameList_.Values[sName] := sVal;
      end;
    except
      on E: Exception do
        ETgException.TraceException(Self, E, 'Fail .. Create() .. Load()');
    end;
  end else bUse_ := true;
end;

Destructor TPatternBase.Destroy;
begin
  FreeAndNil(NameList_);
  Inherited;
end;

procedure TPatternBase.Save(ss: TTgSerializerSave);
var
  i: Integer;
begin
  try
    ss.S_Boolean(bUse_);
    ss.S_Integer(NameList_.Count);
    for i := 0 to NameList_.Count - 1 do
    begin
      ss.S_WORD(WORD(NameList_.Objects[i]));
      ss.S_UTF8String(NameList_[i]);
    end;
  except
    on E: Exception do
      ETgException.TraceException(Self, E, 'Fail .. Save()');
  end;
end;

procedure TPatternBase.AddName(wLangId: WORD; sName: String);
begin
  if NameList_.IndexOfObject(TObject(wLangId)) = -1 then
    NameList_.AddObject(sName, TObject(wLangId));
end;

procedure TPatternBase.ModName(wLangId: WORD; sName: String);
var
  i: Integer;
begin
  i := NameList_.IndexOfObject(TObject(wLangId));
  if i <> -1 then
    NameList_.Strings[i] := sName;
end;

procedure TPatternBase.DelName(wLangId: WORD);
var
  i: Integer;
begin
  i := NameList_.IndexOfObject(TObject(wLangId));
  if i <> -1 then
    NameList_.Delete(i);
end;

function TPatternBase.Name: String;
var
  i: Integer;
begin
  Result := '';
  i := NameList_.IndexOfObject(TObject(Owner_.wLangId_));
  if i = -1 then
  begin
    i := NameList_.IndexOfObject(TObject(DEF_LANG_ID));
    if i = -1 then i := 0;
  end;

  if i <> -1 then
    Result := NameList_[i];
end;

procedure TPatternBase.SetUse(bVal: Boolean);
begin
  bUse_ := bVal;
end;

{ TPatternEnt }

Constructor TPatternEnt.Create(aOwner: TManagerPattern; aParent: TPatternEnt; sl: TTgSerializerLoad = nil; nIfCnt: Integer = 1);
var
  i, nCnt: Integer;
begin
  Inherited Create(aOwner, sl);
  Parent_ := aParent;
  ChildList_ := TPatternEntList.Create;
  PatternList_ := TStringList.Create;
  nIfCnt_ := nIfCnt;

  IsAnd := false;
  RType := rtPattern;
  RSeverity := rsNormal;

  try
    if sl <> nil then
    begin
      nCnt := sl.L_Integer;
      for i := 0 to nCnt - 1 do
        PatternList_.Add(sl.L_UTF8String);

      nCnt := sl.L_Integer;
      for i := 0 to nCnt - 1 do
        ChildList_.Add(TPatternEnt.Create(aOwner, Self, sl));
    end;
  except
    on E: Exception do
      ETgException.TraceException(Self, E, 'Fail .. Create() .. Load()');
  end;
end;

Destructor TPatternEnt.Destroy;
begin
  FreeAndNil(PatternList_);
  FreeAndNil(ChildList_);
  Inherited;
end;

procedure TPatternEnt.Save(ss: TTgSerializerSave);
var
  i: Integer;
begin
  Inherited Save(ss);

  try
    ss.S_Integer(PatternList_.Count);
    for i := 0 to PatternList_.Count - 1 do
      ss.S_UTF8String(PatternList_[i]);

    ss.S_Integer(ChildList_.Count);
    for i := 0 to ChildList_.Count - 1 do
      ChildList_[i].Save(ss);
  except
    on E: Exception do
      ETgException.TraceException(Self, E, 'Fail .. Save()');
  end;
end;

function TPatternEnt.PatternCount: Integer;
var
  i: Integer;
begin
  Result := PatternList_.Count;
  for i := 0 to ChildList_.Count - 1 do
    Inc(Result, ChildList_[i].PatternCount);
end;

function TPatternEnt.GetSearchText(bIncChild: Boolean = false): String;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to PatternList_.Count - 1 do
    SumString(Result, PatternList_[i], '|', true);

  if bIncChild then
  begin
    for i := 0 to ChildList_.Count - 1 do
      SumString(Result, ChildList_[i].GetSearchText, '|', true);
  end;
end;

function TPatternEnt.FullName: String;
begin
  Result := Name;
  if Parent_ <> nil then
    Result := Parent_.FullName + '\' + Result;
end;

{ TPatternEntList }

Constructor TPatternEntList.Create(bFreeEnt: Boolean = true);
begin
  Inherited Create;
  nAndCnt_ := 0;
  bFreeEnt_ := bFreeEnt;
end;

procedure TPatternEntList.Notify(const Item: TPatternEnt; Action: TCollectionNotification);
begin
  case Action of
    cnAdded   :
    begin
      if Item.IsAnd then
        Inc(nAndCnt_);
    end;
    cnRemoved :
    begin
      if Item.IsAnd then
      begin
        Dec(nAndCnt_);
        if nAndCnt_ < 0 then
          nAndCnt_ := 0;
      end;

      if bFreeEnt_ then
        Item.Free;
    end;
  end;
end;

function TPatternEntList.GetPtrnEntByName(sName: String): TPatternEnt;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to Count - 1 do
  begin
    if Items[i].Name = sName then
    begin
      Result := Items[i];
      exit;
    end;

    if Items[i].ChildList_.Count > 0 then
    begin
      Result := Items[i].ChildList_.GetPtrnEntByName(sName);
      if Result <> nil then
        exit;
    end;
  end;

end;

{ TManagerPattern }

Constructor TManagerPattern.Create(sLoadPath: String = '');
begin
  Inherited Create;
  SetLangId(DEF_LANG_ID);
  EntList_ := TPatternEntList.Create;
  Load(sLoadPath);
end;

Destructor TManagerPattern.Destroy;
begin
  FreeAndNil(EntList_);
  Inherited;
end;

procedure TManagerPattern.SetLangId(wVal: WORD);
begin
  wLangId_ := wVal;
end;

function TManagerPattern.GetLangId: WORD;
begin
  Result := wLangId_;
end;

procedure TManagerPattern.Save(sPath: String = '');
var
  ss: TTgSerializerSave;
  i: Integer;
  ms: TMemoryStream;
  enc: TTgEncrypt;
begin
  try
    Guard(ss, TTgSerializerSave.Create);
    ss.SaveHeader(SER_MGPTR_VER);

    ss.S_WORD(wLangId_);
    ss.S_Integer(EntList_.Count);
    for i := 0 to EntList_.Count - 1 do
      EntList_[i].Save(ss);

    if sPath = '' then
      sPath := GetRunExePathDir + DAT_PTNSCH;

    ss.Stream.Position := 0;
    Guard(ms, TMemoryStream.Create);
    Guard(enc, TTgEncrypt.Create(PWD_PTNSCH));
    if not enc.EncryptStream(ss.Stream, ms) then
    begin
      _Trace('Fail .. Save() .. EncryptStream()');
      exit;
    end;
    ms.SaveToFile(sPath);
  except
    on E: Exception do
      ETgException.TraceException(Self, E, 'Fail .. Save()');
  end;
end;

procedure TManagerPattern.Load(sPath: String = '');
var
  sl: TTgSerializerLoad;
  i, nCnt: Integer;
  ms: TMemoryStream;
  enc: TTgEncrypt;
begin
  if sPath = '' then
    sPath := GetRunExePathDir + DAT_PTNSCH;

  try
    EntList_.Clear;
    if not FileExists(sPath) then
      exit;

    Guard(sl, TTgSerializerLoad.Create);
    Guard(ms, TMemoryStream.Create);
    ms.LoadFromFile(sPath);
    ms.Position := 0;
    Guard(enc, TTgEncrypt.Create(PWD_PTNSCH));
    if not enc.DecryptStream(ms, sl.Stream) then
    begin
      _Trace('Fail .. Load() .. DecryptStream()');
      exit;
    end;

    sl.Stream.Position := 0;
    if not sl.LoadHeader then
    begin
      _Trace('Fail .. Load() .. LoadHeader()');
      exit;
    end;
    ASSERT(sl.Header.nVer = SER_MGPTR_VER); // todo : 버전 관리

//    wLangId_ := sl.L_WORD;
    sl.L_WORD; // 저장된거 안씀 22_0804 09:02:07 kku
    nCnt := sl.L_Integer;
    for i := 0 to nCnt - 1 do
      EntList_.Add(TPatternEnt.Create(Self, nil, sl));
  except
    on E: Exception do
      ETgException.TraceException(Self, E, 'Fail .. Load()');
  end;
end;

function TManagerPattern.GetUsePatternEnt(aPatternEntList: TPatternEntList): Integer;

  procedure FindUsePatternEnt(aEnt: TPatternEnt);
  var
    i: Integer;
  begin
    if aEnt.bUse_ then
    begin
      aPatternEntList.Add(aEnt);

      for i := 0 to aEnt.ChildList_.Count - 1 do
        FindUsePatternEnt(aEnt.ChildList_[i]);
    end;
  end;
var
  i: Integer;

begin
  Result := 0;
  try
    aPatternEntList.Clear;
    for i := 0 to EntList_.Count - 1 do
      FindUsePatternEnt(EntList_[i]);
    Result := aPatternEntList.Count;
  except
    on E: Exception do
      ETgException.TraceException(Self, E, 'Fail .. GetUsePatternEnt()');
  end;
end;

function TManagerPattern.GetPatternEntByName(sName: String): TPatternEnt;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to EntList_.Count - 1 do
  begin
    Result := EntLIst_.GetPtrnEntByName(sName);
    if Result <> nil then
      exit;
  end;
end;

{ TFndEntList }

procedure TFndEntList.Notify(const Item: TFndEnt; Action: TCollectionNotification);
begin
  if Action = cnRemoved then
    Item.Free;
end;

{ TFndEnt }

Constructor TFndEnt.Create(sName: String);
begin
  Inherited Create;
{$IF _CTTSCH_}
  pNode := nil;
{$ENDIF}
  sName_ := sName;
  nHitCnt_ := 0;
  ChildList_ := TFndEntList.Create;
end;

Destructor TFndEnt.Destroy;
begin
  FreeAndNil(ChildList_);
  Inherited;
end;

function TFndEnt.HitCount: Integer;
var
  i: Integer;
begin
  Result := nHitCnt_;
  for i := 0 to ChildList_.Count - 1 do
    Inc(Result, ChildList_[i].HitCount);
end;

function TFndEnt.ToJsonObj: ISuperObject;
var
  OA, O: ISuperObject;
  i: Integer;
begin
  try
    Result := SO;
    Result.S['Name'] := sName_;
    Result.I['Count'] := HitCount;

    OA := TSuperObject.Create(stArray);
    for i := 0 to ChildList_.Count - 1 do
    begin
      O := ChildList_[i].ToJsonObj;
      if O <> nil then
        OA.AsArray.Add(O);
    end;

    if OA.AsArray.Length > 0 then
      Result.O['Child'] := OA;
  except
    on E: Exception do
    begin
      Result := nil;
      ETgException.TraceException(Self, E, 'Fail .. ToJsonObj()');
    end;
  end;
end;

function TFndEnt.ToEntInfoStr: String;
var
  i: Integer;
begin
  if nHitCnt_ > 0 then
    Result := Format('%s:%d', [sName_, nHitCnt_])
  else
    Result := '';

  for i := 0 to ChildList_.Count - 1 do
    SumString(Result, ChildList_[i].ToEntInfoStr, ';');
end;

{ TManagerFound }

Constructor TManagerFound.Create;
begin
  Inherited Create;
  KwdEnt_ := nil;
  EntList_ := TFndEntList.Create;
  NameList_ := TStringList.Create;
end;

Destructor TManagerFound.Destroy;
begin
  FreeAndNil(NameList_);
  FreeAndNil(EntList_);
  Inherited;
end;

procedure TManagerFound.Clear;
begin
  EntList_.Clear;
  KwdEnt_ := nil;
end;

function FindEntByName(aList: TFndEntList; s: String): TFndEnt;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to aList.Count - 1 do
    if CompareText(aList[i].sName_, s) = 0 then
    begin
      Result := aList[i];
      exit;
    end;
end;

procedure TManagerFound.PushFoundPattern(sName: String; nHits: Integer);
var
  i: Integer;
  FEnt,
  TmpEnt: TFndEnt;
begin
  SplitString(sName, '\', NameList_);
  for i := 0 to NameList_.Count - 1 do
  begin
    if i = 0 then
    begin
      FEnt := FindEntByName(EntList_, NameList_[i]);
      if FEnt = nil then
      begin
        FEnt := TFndEnt.Create(NameList_[i]);
        if KwdEnt_ <> nil then
          EntList_.Insert(EntList_.Count - 1, FEnt)
        else
          EntList_.Add(FEnt);
      end;
    end else begin
      ASSERT(FEnt <> nil);
      TmpEnt := FindEntByName(FEnt.ChildList_, NameList_[i]);
      if TmpEnt = nil then
      begin
        TmpEnt := TFndEnt.Create(NameList_[i]);
        FEnt.ChildList_.Add(TmpEnt);
        FEnt := TmpEnt;
      end else
        FEnt := TmpEnt;
    end;
  end;

  Inc(FEnt.nHitCnt_, nHits);
end;

procedure TManagerFound.PushFoundKeyword(sFoundStr: String);
var
  StrList: TStringList;
  i, nPos, nLen, nHit: Integer;
  sKwd: String;
  FEnt: TFndEnt;
begin
  if KwdEnt_ = nil then
  begin
    KwdEnt_ := TFndEnt.Create('키워드');
    EntList_.Add(KwdEnt_);
  end;

  Guard(StrList, TStringList.Create);
  if SplitString(sFoundStr, ',', StrList) = 0 then
    exit;

  for i := 0 to StrList.Count - 1 do
  begin
    sKwd := StrList[i];
    nPos := Pos('(x', sKwd);
    if nPos > 0 then
    begin
      nLen := Length(sKwd) - 1;
      SetLength(sKwd, nLen);
      nHit := StrToIntDef(Copy(sKwd, nPos + 2, nLen - nPos + 2), 1);
      SetLength(sKwd, nPos - 1);
    end else
      nHit := 1;

    FEnt := FindEntByName(KwdEnt_.ChildList_, sKwd);
    if FEnt = nil then
    begin
      FEnt := TFndEnt.Create(sKwd);
      KwdEnt_.ChildList_.Add(FEnt);
    end;
    Inc(FEnt.nHitCnt_, nHit);
  end;
end;

function TManagerFound.ToJsonObj: ISuperObject;
var
  i: Integer;
  O: ISuperObject;
begin
  Result := TSuperObject.Create(stArray);
  for i := 0 to EntList_.Count - 1 do
  begin
    O := EntList_[i].ToJsonObj;
    if O <> nil then
      Result.AsArray.Add(O);
  end;
end;

function TManagerFound.ToEntInfoStr: String;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to EntList_.Count - 1 do
    SumString(Result, EntList_[i].ToEntInfoStr, ';');
end;

end.