unit uhistory;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, StdCtrls, lazUTF8, Clipbrd;
type
PStep = ^TStep;
// 单步历史记录数据
// one step of history data
TStep = record
BytePos : SizeInt;
SelStart : SizeInt; // used to restore the cursor position（用于恢复光标位置）
InsStr : string;
DelStr : string;
end;
{ THistory }
THistory = class
private
FMemo : TMemo;
FSteps : TList; // history records data（历史记录数据）
FIndex : Integer; // history index, based 0（历史记录索引，从 0 开始）
FOldOnChange : TNotifyEvent;
FInEdit : Boolean;
// OnChange 事件之前的 FMemo 内容
// the content of FMemo before OnChange event
FPrevContent : string;
FSize : SizeInt; // all steps size（所有历史步骤的总大小）
FixOnChangeBug : Boolean;
function GetStep(AIndex: Integer): PStep; inline;
function CurStep: PStep; inline;
procedure AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
procedure DelStep(AIndex: Integer);
procedure MemoOnChange(Sender: TObject);
function StrDiff(const ACurContent: string;
out ABytePos, ASelStart: SizeInt;
out AInsStr, ADelStr: string): Boolean;
public
constructor Create(AMemo: TMemo);
destructor Destroy; override;
function CanUndo: Boolean; inline;
function CanRedo: Boolean; inline;
procedure Undo;
procedure Redo;
// 你应该使用 Paste 函数粘贴文本，而不是 FMemo.PasteFromClipboard 函数，
// 否则你的粘贴操作可能需要撤销两次才能恢复到粘贴之前的状态。
// you should use Paste function to paste text instead of FMemo.PasteFromClipboard function,
// otherwise your paste operation may need to perform twice Undo to restore to the state before paste.
procedure PasteText;
// 你应该使用 DeleteText 函数删除文本，而不是 FMemo.Text := '' 方法，
// 否则你的删除操作可能不会触发 OnChange 事件。
// you should use the DeleteText function to delete text instead of the FMemo.Text := '' method,
// otherwise your delete operation may not trigger the OnChange event.
procedure DeleteText;
procedure Reset; inline;
property Size: SizeInt read FSize;
end;
implementation
{ THistory }
function THistory.GetStep(AIndex: Integer): PStep; inline;
begin
Result := PStep(FSteps[AIndex]);
end;
function THistory.CurStep: PStep; inline;
begin
Result := GetStep(FIndex);
end;
procedure THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
begin
DelStep(FIndex + 1);
FSteps.Add(new(PStep));
Inc(FIndex);
Inc(FSize, Sizeof(TStep) + Length(AInsStr) + Length(ADelStr));
with CurStep^ do begin
BytePos := ABytePos;
SelStart := ASelStart;
InsStr := AInsStr;
DelStr := ADelStr;
end;
end;
procedure THistory.DelStep(AIndex: Integer);
var
i: Integer;
Step: PStep;
begin
for i := FSteps.Count - 1 downto AIndex do begin
Step := GetStep(i);
Dec(FSize, Sizeof(TStep) + Length(Step^.InsStr) + Length(Step^.DelStr));
Step^.InsStr := '';
Step^.DelStr := '';
dispose(Step);
FSteps.Delete(i);
end;
FIndex := AIndex - 1;
end;
constructor THistory.Create(AMemo: TMemo);
begin
inherited Create;
FSteps := TList.Create;
FMemo := AMemo;
FOldOnChange := FMemo.OnChange;
FMemo.OnChange := @MemoOnChange;
FPrevContent := FMemo.Text;
FIndex := -1;
FInEdit := True;
end;
destructor THistory.Destroy;
begin
FMemo.OnChange := FOldOnChange;
FMemo := nil;
DelStep(0);
FSteps.Free;
inherited Destroy;
end;
procedure THistory.MemoOnChange(Sender: TObject);
var
CurContent, InsStr, DelStr: string;
BytePos, SelStart: SizeInt;
begin
if FInEdit then begin
CurContent := FMemo.Text;
if StrDiff(CurContent, BytePos, SelStart, InsStr, DelStr) then
AddStep(BytePos, SelStart, InsStr, DelStr);
FPrevContent := CurContent;
end;
FixOnChangeBug := False;
if Assigned(FOldOnChange) then
FOldOnChange(Sender);
end;
function THistory.StrDiff(const ACurContent: string;
out ABytePos, ASelStart: SizeInt;
out AInsStr, ADelStr: string): Boolean;
var
CurStart, CurPos, CurEnd, PrevPos: PChar;
CurLen, PrevLen, DiffLen: SizeInt;
CharLen: Integer;
begin
CurStart := PChar(ACurContent);
CurPos := CurStart;
PrevPos := PChar(FPrevContent);
CurLen := Length(ACurContent); // Use Length(string) DO NOT use Length(PChar)
PrevLen := Length(FPrevContent);
DiffLen := CurLen - PrevLen;
if DiffLen < 0 then
CurEnd := CurPos + CurLen - 1
else if DiffLen > 0 then
CurEnd := CurPos + PrevLen - 1
else begin
Result := False;
Exit;
end;
while (CurPos <= CurEnd) do begin
if CurPos^ <> PrevPos^ then Break;
Inc(CurPos);
Inc(PrevPos);
end;
Utf8TryFindCodepointStart(CurStart, CurPos, CharLen);
ABytePos := CurPos - CurStart + 1;
if DiffLen > 0 then begin
AInsStr := Copy(ACurContent, ABytePos, DiffLen);
ADelStr := '';
end else begin
AInsStr := '';
ADelStr := Copy(FPrevContent, ABytePos, -DiffLen);
end;
ASelStart := FMemo.SelStart;
Result := True;
end;
function THistory.CanUndo: Boolean; inline;
begin
Result := FIndex >= 0;
end;
function THistory.CanRedo: Boolean; inline;
begin
Result := FIndex < FSteps.Count - 1;
end;
procedure THistory.Undo;
var
NewSelStart: SizeInt;
begin
if FIndex < 0 then Exit;
FInEdit := False;
FixOnChangeBug := True;
// FPrevContent == FMemo.Text
with CurStep^ do begin
if InsStr <> '' then begin
Delete(FPrevContent, BytePos, Length(InsStr));
NewSelStart := SelStart - UTF8LengthFast(InsStr);
end;
if DelStr <>'' then begin
Insert(DelStr, FPrevContent, BytePos);
NewSelStart := SelStart + UTF8LengthFast(DelStr);
end;
end;
FMemo.Lines.Text := FPrevContent;
FMemo.SelStart := NewSelStart;
Dec(FIndex);
if FixOnChangeBug then MemoOnChange(FMemo);
FInEdit := True;
end;
procedure THistory.Redo;
var
NewSelStart: SizeInt;
begin
if FIndex >= FSteps.Count - 1 then Exit;
FInEdit := False;
FixOnChangeBug := True;
Inc(FIndex);
// FPrevContent == FMemo.Text
with CurStep^ do begin
if DelStr <> '' then begin
Delete(FPrevContent, BytePos, Length(DelStr));
NewSelStart := SelStart;
end;
if InsStr <> '' then begin
Insert(InsStr, FPrevContent, BytePos);
NewSelStart := SelStart;
end;
end;
FMemo.Lines.Text := FPrevContent;
FMemo.SelStart := NewSelStart;
if FixOnChangeBug then MemoOnChange(FMemo);
FInEdit := True;
end;
function UTF8PosToBytePos(const AStr: string; const ASize: SizeInt; APos: SizeInt): SizeInt;
begin
if APos < 1 then Result := -1 else Result := 0;
while (APos > 1) and (Result < ASize) do begin
case AStr[Result] of
// #0..#127: Inc(Result);
#192..#223: Inc(Result, 2);
#224..#239: Inc(Result, 3);
#240..#247: Inc(Result, 4);
else Inc(Result);
end;
Dec(APos);
end;
Inc(Result)
end;
procedure THistory.PasteText;
var
BytePos: SizeInt;
ClipBoardText: string;
begin
FInEdit := False;
ClipBoardText := ClipBoard.AsText;
if ClipBoardText <> '' then begin
FixOnChangeBug := True;
// FPrevContent == FMemo.Text
BytePos := UTF8PosToBytePos(FPrevContent, Length(FPrevContent), FMemo.SelStart + 1);
AddStep(BytePos, FMemo.SelStart, ClipBoardText, FMemo.SelText);
FMemo.SelText := ClipBoardText;
FPrevContent := FMemo.Text;
if FixOnChangeBug then MemoOnChange(FMemo);
end;
FInEdit := True;
end;
procedure THistory.DeleteText;
var
BytePos: SizeInt;
begin
FInEdit := False;
if FMemo.SelLength > 0 then begin
FixOnChangeBug := True;
// FPrevContent == FMemo.Text
BytePos := UTF8PosToBytePos(FPrevContent, Length(FPrevContent), FMemo.SelStart + 1);
AddStep(BytePos, FMemo.SelStart, '', FMemo.SelText);
FMemo.SelText := '';
FPrevContent := FMemo.Text;
if FixOnChangeBug then MemoOnChange(FMemo);
end;
FInEdit := True;
end;
procedure THistory.Reset; inline;
begin
DelStep(0);
FPrevContent := FMemo.Text;
end;
end.
Bookstore
