На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
Модераторы: Rouse_, jack128, Krid
  
    > Алгоритм поиска всех уникальных слов в файле , Реализация на основе дихотомии...
      ExpandedWrap disabled
        ////////////////////////////////////////////////////////////////////////////////
        //
        //  ****************************************************************************
        //  * Unit Name : Dictionary
        //  * Purpose   : Набор классов для работы с индексированным списком поиска
        //  * Author    : Александр Багель
        //  * Version   : 1.00
        //  ****************************************************************************
        //
         
        unit Dictionary;
         
        interface
         
        uses
          Windows, Classes, SysUtils{, FullTextGetter};
         
        type
          // Класс отвечающий за создание словаря уникальных слов
          TDictionaryFounder = class
          private
            FDict: TList;
            FDictMem: array of String;
            FDictMemCount: Integer;
          protected
            function GetPos(const Value: String): Integer; virtual;
            procedure Insert(Value: String; Position: Integer); virtual;
            function Prepare(const Value: String): String; virtual;
          public
            constructor Create;
            destructor Destroy; override;
            procedure AddData(Value: String); //overload;
           // procedure AddData(ObjText: IFullTextGetter); overload;
            procedure SaveToStream(var AStream: TMemoryStream);
          end;
         
          // Класс осуществляющий поиск в словаре
          // полученном от TDictionaryFounder
          TDictionaryFinder = class
          private
            FDict: array of ShortString;
            FDictLength: Cardinal;
          protected
            function GetPos(const Value: ShortString;
              const SubStr: Boolean = False): Boolean; virtual;
          public
            destructor Destroy; override;
            procedure LoadFromStream(const AStream: TMemoryStream);
            function Find(const Value: String;
              const SubStr: Boolean = False): Boolean;
          end;
         
        implementation
         
        { TDictionaryFounder }
         
        //
        //  Добавление информации для построения массива индексов
        // =============================================================================
        procedure TDictionaryFounder.AddData(Value: String);
        var
          Tmp: String;
          Position, I: Integer;
          S: TStringList;
        begin
          Value := Prepare(Value);
          S := TStringList.Create;
          try
            S.Text := Value;
            for I := 0 to S.Count - 1 do
            begin
              Tmp := S[I];
              if Tmp = '' then Continue;
              if FDict.Count = 0 then
                Insert(Tmp, 0)
              else
              begin
                Position := GetPos(Tmp);
                if (Position >= 0) then
                  if FDict.Count > Position then
                  begin
                    if String(FDict.Items[Position]) <> Tmp then
                      Insert(Tmp, Position);
                  end
                  else
                    Insert(Tmp, Position);
              end;
            end;
          finally
            S.Free;
          end;
        end;
         
        //
        //  Добавление информации для построения массива индексов
        //  Информация приходит из интерфейса
        // =============================================================================
        {procedure TDictionaryFounder.AddData(ObjText: IFullTextGetter);
        var
          S: String;
        begin
          if ObjText = nil then
            raise Exception.Create('IFullTextGetter is empty.');
          S := ObjText.GetText;
          AddData(S);
        end;   }
         
        constructor TDictionaryFounder.Create;
        begin
          FDict := TList.Create;
        end;
         
        destructor TDictionaryFounder.Destroy;
        begin
          FDict.Free;
          FDictMemCount := 0;
          SetLength(FDictMem, FDictMemCount);
          inherited;
        end;
         
        //
        //  Возвращает номер позиции где находится слово, или должно находится...
        //  Поиск методом половинного деления...
        // =============================================================================
        function TDictionaryFounder.GetPos(const Value: String): Integer;
        var
          FLeft, FRight, FCurrent: Cardinal;
        begin
          if FDict.Count = 0 then
          begin
            Result := 0;
            Exit;
          end;
          FLeft := 0;
          FRight := FDict.Count - 1;
          FCurrent := (FRight + FLeft) div 2;
          if String(FDict.Items[FLeft]) > Value then
          begin
            Result := 0;
            Exit;
          end;
          if String(FDict.Items[FRight]) < Value then
          begin
            Result := FRight + 1;
            Exit;
          end;
          repeat
            if String(FDict.Items[FCurrent]) = Value then
            begin
              Result := FCurrent;
              Exit;
            end;
            if String(FDict.Items[FCurrent]) < Value then
              FLeft := FCurrent
            else
              FRight := FCurrent;
            FCurrent := (FRight + FLeft) div 2;
          until FLeft = FCurrent;
          if String(FDict.Items[FCurrent]) < Value then Inc(FCurrent);
          Result := FCurrent;
        end;
         
        //
        //  Добавление нового индекса в массив индексов
        // =============================================================================
        procedure TDictionaryFounder.Insert(Value: String; Position: Integer);
        begin
          if FDictMemCount < FDict.Count + 1 then
          begin
            Inc(FDictMemCount, FDict.Count + 1);
            SetLength(FDictMem, FDictMemCount);
          end;
          FDictMem[FDict.Count] := Value;
          FDict.Insert(Position, @FDictMem[FDict.Count][1]);
        end;
         
        //
        //  Сохранение массива индексов в поток
        // =============================================================================
        procedure TDictionaryFounder.SaveToStream(var AStream: TMemoryStream);
        var
          I: Integer;
          S: PChar;
          TmpS: TStringList;
        begin
          if AStream = nil then Exit;
          TmpS := TStringList.Create;
          try
            for I := 0 to FDict.Count - 1 do
            begin
              S := FDict.Items[I];
              TmpS.Add(S);
            end;
            AStream.Position := 0;
            AStream.Size := Length(TmpS.Text);
            AStream.Write(TmpS.Text[1], Length(TmpS.Text));
            AStream.Position := 0;
          finally
            TmpS.Free;
          end;
        end;
         
        //
        //  Подготовка данных к обработке...
        //  Удаляются все не буквенные символы, каждое слово начинется с новой строки...
        // =============================================================================
        function TDictionaryFounder.Prepare(const Value: String): String;
        var
          I: Integer;
          Len: Cardinal;
          C: PAnsiChar;
          LastEnter: Boolean;
        begin
          SetLength(Result, Length(Value) * 2);
          Len := 0;
          LastEnter := False;
          for I := 1 to Length(Value) do
          begin
            C := CharLower(@Value[I]);
            if C^ in ['a'..'z', 'а'..'я'] then
            begin
              Inc(Len);
              Result[Len] := C^;
              LastEnter := False;
            end
            else
              if not LastEnter then
              begin
                Inc(Len);
                Result[Len] := #13;
                Inc(Len);
                Result[Len] := #10;
                LastEnter := True;
              end;
          end;
          SetLength(Result, Len);
        end;
         
        { TDictionaryFinder }
         
        destructor TDictionaryFinder.Destroy;
        begin
          FDictLength := 0;
          SetLength(FDict, FDictLength);
          inherited;
        end;
         
        //
        //  Поиск введенных слов...
        // =============================================================================
        function TDictionaryFinder.Find(const Value: String;
          const SubStr: Boolean = False): Boolean;
        var
          S: TStringList;
          I: Integer;
        begin
          Result := False;
          if Value = '' then Exit;
          S := TStringList.Create;
          try
            S.Text := StringReplace(Value, ' ', #13#10, [rfReplaceAll]);
            S.Text := AnsiLowerCase(S.Text);
            if S.Count = 0 then Exit;
            for I := 0 to S.Count - 1 do
            begin
              Result := GetPos(S.Strings[I], SubStr);
              if not Result then Exit;
            end;
          finally
            S.Free;
          end;
        end;
         
        //
        //  Поиск каждого слова в массиве индексов
        // =============================================================================
        function TDictionaryFinder.GetPos(const Value: ShortString;
          const SubStr: Boolean = False): Boolean;
        var
          FLeft, FRight, FCurrent, I: Cardinal;
        begin
          Result := False;
          if SubStr then
          begin
            for I := 0 to FDictLength - 1 do
              if Pos(Value, FDict[I]) > 0 then
              begin
                Result := True;
                Exit;
              end;
          end
          else
          begin
            if FDictLength = 0 then Exit;
            FLeft := 0;
            FRight := FDictLength - 1;
            FCurrent := (FRight + FLeft) div 2;
            if FDict[FLeft] > Value then Exit;
            if FDict[FRight] < Value then Exit;
            if FDict[FLeft] = Value then
            begin
              Result := True;
              Exit;
            end;
            if FDict[FRight] = Value then
            begin
              Result := True;
              Exit;
            end;
            repeat
              if FDict[FCurrent] = Value then
              begin
                Result := True;
                Exit;
              end;
              if FDict[FCurrent] < Value then
                FLeft := FCurrent
              else
                FRight := FCurrent;
              FCurrent := (FRight + FLeft) div 2;
            until FLeft = FCurrent;
          end;
        end;
         
        //
        //  Загрузка массива индексов из потока
        // =============================================================================
        procedure TDictionaryFinder.LoadFromStream(const AStream: TMemoryStream);
        var
          S: TStringList;
          I: Integer;
        begin
          S := TStringList.Create;
          try
            AStream.Position := 0;
            S.LoadFromStream(AStream);
            FDictLength := S.Count;
            if FDictLength = 0 then Exit;
            SetLength(FDict, FDictLength);
            for I := 0 to FDictLength - 1 do
              FDict[I] := S.Strings[I];
          finally
            S.Free;
          end;
        end;
         
        end.


      пример использования:

      ExpandedWrap disabled
        unit Unit1;
         
        interface
         
        uses
          Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
          Dialogs, StdCtrls, ComCtrls, Dictionary;
         
        type
          TForm1 = class(TForm)
            Button1: TButton;
            ProgressBar1: TProgressBar;
            Button2: TButton;
            Edit1: TEdit;
            Label1: TLabel;
            CheckBox1: TCheckBox;
            procedure Button1Click(Sender: TObject);
            procedure Button2Click(Sender: TObject);
          end;
         
        var
          Form1: TForm1;
         
        implementation
         
        uses ComObj;
         
        {$R *.dfm}
         
        procedure TForm1.Button1Click(Sender: TObject);
        var
          SH: TDictionaryFounder;
          S: TStringList;
          M: TMemoryStream;
          I: Integer;
          Start: Cardinal;
        begin
          S := TStringList.Create;
          try
            S.LoadFromFile('c:\1.txt');
            ProgressBar1.Position := 0;
            ProgressBar1.Max := S.Count;
            SH := TDictionaryFounder.Create;
            try
              Start := GetTickCount;
              for I := 0 to S.Count - 1 do
              begin
                SH.AddData(S.Strings[I]);
                ProgressBar1.Position := I;
              end;
              ShowMessage('Время составления словаря: ' + IntToStr(GetTickCount - Start));
              M := TMemoryStream.Create;
              try
                SH.SaveToStream(M);
                M.SaveToFile('c:\2.txt');
                ProgressBar1.Position := 0;
                Button2.Enabled := True;
              finally
                M.Free;
              end;
            finally
              SH.Free;
            end;
          finally
            S.Free;
          end;
        end;
         
         
        procedure TForm1.Button2Click(Sender: TObject);
        var
          S: TDictionaryFinder;
          M: TMemoryStream;
        begin
          S := TDictionaryFinder.Create;
          try
            M := TMemoryStream.Create;
            try
              M.LoadFromFile('c:\2.txt');        
              S.LoadFromStream(M);
              if S.Find(Edit1.Text, CheckBox1.Checked) then
                ShowMessage('Элемент найден')
              else
                ShowMessage('Элемент не найден');
            finally
              M.Free;
            end;
          finally
            S.Free;
          end;
        end;
         
        end.
      0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
      0 пользователей:


      Рейтинг@Mail.ru
      [ Script execution time: 0,0253 ]   [ 17 queries used ]   [ Generated: 28.03.24, 08:53 GMT ]