unit uhistory;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, StdCtrls, Forms, Clipbrd;
type
PStep = ^TStep;
// one step of history data
TStep = record
SelStart : SizeInt; // < 0 means Delete text, > 0 means Insert text
SelText : string; // Insert or Delete text
HalfStep : Integer; // 0 means full step, 1 means first half step, 2 means second half step.
end;
{ THistory }
THistory = class
private
FMemo : TMemo;
FOldOnChange : TNotifyEvent;
FPrevContent : string;
FSteps : TList; // history records
FIndex : Integer; // index of history record, based 0
FSize : SizeInt;
FInEdit : Boolean;
FixOnChangeBug : Boolean;
FHalfEvent : Boolean;
FOldApplicationIdle : TIdleEvent;
FPrevSelStart : SizeInt;
function GetStep(AIndex: Integer): PStep; inline;
function CurStep: PStep; inline;
procedure AddStep(ASelStart: SizeInt; ASelText: string; AHalfEvent: Boolean);
procedure DelStep(AIndex: Integer);
procedure MemoOnChange(Sender: TObject);
procedure ApplicationIdle(Sender: TObject; var Done: Boolean);
function StrDiff(const ACurContent: string; out ASelStart: SizeInt;
out ASelText: string; out AHalfEvent: Boolean): Boolean;
function StrDiff1(const ACurContent: string; out ASelStart: SizeInt;
out ASelText: string; out AHalfEvent: Boolean): Boolean;
function StrDiff2(const ACurContent: string; out ASelStart: SizeInt;
out ASelText: string; out AHalfEvent: Boolean): Boolean;
public
constructor Create(AMemo: TMemo);
destructor Destroy; override;
function CanUndo: Boolean; inline;
function CanRedo: Boolean; inline;
procedure Undo;
procedure Redo;
// you should use Paste function to paste text instead of FMemo.PasteFromClipboard function,
// this function can reduce the calculation.
procedure PasteText;
// 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;
{ Custom Functions }
function UTF8PosToBytePos(const Text: PChar; const Size: SizeInt; UPos: SizeInt): SizeInt;
function UTF8PosToBytePos(const Text: String; const UPos: SizeInt): SizeInt; inline;
function UTF8LengthFast(const Text: PChar; const Size: SizeInt): SizeInt;
function UTF8LengthFast(const AStr: String): SizeInt; inline;
implementation
// uses lazUTF8;
{ 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(ASelStart: SizeInt; ASelText: string; AHalfEvent: Boolean);
begin
// remove tailing steps
DelStep(FIndex + 1);
// correct the previous step
if AHalfEvent and (FIndex >= 0) then
GetStep(FIndex)^.HalfStep := 1; // first half step
// add current step
FSteps.Add(new(PStep));
Inc(FIndex);
Inc(FSize, Sizeof(TStep) + Length(ASelText));
with CurStep^ do begin
SelStart := ASelStart;
SelText := ASelText;
if AHalfEvent then
HalfStep := 2 // second half step
else
HalfStep := 0; // full step
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);
// Size
Dec(FSize, Sizeof(TStep) + Length(Step^.SelText));
// Memory
Step^.SelText := '';
dispose(Step);
// List
FSteps.Delete(i);
end;
// Index
FIndex := AIndex - 1;
end;
constructor THistory.Create(AMemo: TMemo);
begin
inherited Create;
FSteps := TList.Create;
FIndex := -1;
FMemo := AMemo;
FOldOnChange := FMemo.OnChange;
FMemo.OnChange := @MemoOnChange;
FPrevContent := FMemo.Text;
FOldApplicationIdle := Application.OnIdle;
Application.OnIdle := @ApplicationIdle;
FHalfEvent := False;
FInEdit := True;
end;
destructor THistory.Destroy;
begin
Application.OnIdle := FOldApplicationIdle;
FMemo.OnChange := FOldOnChange;
FMemo := nil;
DelStep(0);
FSteps.Free;
inherited Destroy;
end;
procedure THistory.MemoOnChange(Sender: TObject);
var
CurContent, ASelText : string;
ASelStart : SizeInt;
AHalfEvent : Boolean;
begin
if FInEdit then begin
CurContent := FMemo.Text;
if StrDiff(CurContent, ASelStart, ASelText, AHalfEvent) then
AddStep(ASelStart, ASelText, AHalfEvent);
FPrevContent := CurContent;
end;
FixOnChangeBug := False;
if Assigned(FOldOnChange) then
FOldOnChange(Sender);
end;
procedure THistory.ApplicationIdle(Sender: TObject; var Done: Boolean);
begin
FHalfEvent := False;
FPrevSelStart := FMemo.SelStart;
if Assigned(FOldApplicationIdle) then
FOldApplicationIdle(Sender, Done);
end;
function THistory.StrDiff(const ACurContent: string; out ASelStart: SizeInt;
out ASelText: string; out AHalfEvent: Boolean): Boolean;
begin
if FMemo.SelLength = 0 then begin
Result := StrDiff1(ACurContent, ASelStart, ASelText, AHalfEvent);
end else begin
Result := StrDiff2(ACurContent, ASelStart, ASelText, AHalfEvent);
end;
end;
// Get the difference between ACurContent and FPrevContent(FMemo.SelStart nust be correct, need less calculations).
// The difference can only be insert or delete text in one place, not allowed other difference
// ASelStart: the SelStart of the difference, based 1. if > 0 means add text, if < 0 means delete content
// ASelText: the content of the difference
// AHalfEvent: is it half event of one user operation
function THistory.StrDiff1(const ACurContent: string; out ASelStart: SizeInt;
out ASelText: string; out AHalfEvent: Boolean): Boolean;
var
BytePos, DiffLen: SizeInt;
begin
Result := False;
DiffLen := Length(ACurContent) - Length(FPrevContent);
// UTF8CharToByteIndex based 0.
// BytePos := lazUTF8.UTF8CharToByteIndex(PChar(ACurContent), Length(ACurContent), FMemo.SelStart) + 1;
// Custom function based 1.
BytePos := UTF8PosToBytePos(ACurContent, FMemo.SelStart + 1);
if DiffLen > 0 then begin // add text
BytePos := BytePos - DiffLen;
ASelText := Copy(ACurContent, BytePos, DiffLen);
ASelStart := FMemo.SelStart - UTF8LengthFast(ASelText) + 1;
{ special case: drag in from other control }
if ASelStart - 1 <> FPrevSelStart then begin
Result := StrDiff2(AcurContent, ASelStart, ASelText, AHalfEvent);
Exit;
end;
end else if DiffLen < 0 then begin // delete text
ASelText := Copy(FPrevContent, BytePos, -DiffLen);
ASelStart := -(FMemo.SelStart + 1);
end else
Exit;
Result := True;
AHalfEvent := FHalfEvent;
FHalfEvent := True;
end;
// get the difference between ACurContent and FPrevContent(FMemo.SelStart does not need correct, need more calculations).
// the difference can only be insert or delete text in one place, not allowed other difference
// ASelStart : the SelStart of the difference, based 1. if > 0 means add text, if < 0 means delete content
// ASelText : the content of the difference
// AHalfEvent : is it half event of one user operation
function THistory.StrDiff2(const ACurContent: string; out ASelStart: SizeInt;
out ASelText: string; out AHalfEvent: Boolean): Boolean;
var
CurStart, PrevStart, CurPos, PrevPos, CurEnd: PChar;
BytePos, CurLen, PrevLen, DiffLen: SizeInt;
begin
Result := False;
CurStart := PChar(ACurContent);
PrevStart := PChar(FPrevContent);
CurLen := Length(ACurContent); // for speed, use Length(string) DO NOT use Length(PChar)
PrevLen := Length(FPrevContent);
DiffLen := CurLen - PrevLen;
if DiffLen < 0 then
CurEnd := CurStart + CurLen - 1
else if DiffLen > 0 then
CurEnd := CurStart + PrevLen - 1
else
Exit;
// byte-by-byte comparison
CurPos := CurStart;
PrevPos := PrevStart;
while CurPos <= CurEnd do begin
if CurPos^ <> PrevPos^ then Break;
Inc(CurPos);
Inc(PrevPos);
end;
// lazUTF8.Utf8TryFindCodepointStart(CurContent, CurPos, CharLen);
// custom find codepoint start
while CurPos > CurStart do
case CurPos^ of
#0..#127, #192..#247: break;
else Dec(CurPos);
end;
BytePos := CurPos - CurStart + 1;
if DiffLen > 0 then begin // add text
ASelText := Copy(ACurContent, BytePos, DiffLen);
ASelStart := UTF8LengthFast(CurStart, BytePos);
end else begin // delete text
ASelText := Copy(FPrevContent, BytePos, -DiffLen);
ASelStart := -UTF8LengthFast(PChar(FPrevContent), BytePos);
end;
Result := True;
AHalfEvent := FHalfEvent;
FHalfEvent := 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
Half: Integer;
begin
if FIndex < 0 then Exit;
FInEdit := False;
FixOnChangeBug := True;
// FPrevContent == FMemo.Text
with CurStep^ do begin
Half := HalfStep;
if SelStart > 0 then begin
// writeln(Format('Undo: %d, %s, %d', [SelStart-1, SelText, HalfStep]));
FMemo.SelStart := SelStart - 1; // from "baseed 1" to "based 0"
FMemo.SelLength := UTF8LengthFast(SelText);
FMemo.SelText := '';
end else begin
// writeln(Format('Undo: %d, %s, %d', [-SelStart-1, SelText, HalfStep]));
FMemo.SelStart := -SelStart - 1; // from "baseed 1" to "based 0"
FMemo.SelLength := 0;
FMemo.SelText := SelText;
end;
end;
Dec(FIndex);
FPrevContent := FMemo.Text;
if FixOnChangeBug then MemoOnChange(FMemo);
FInEdit := True;
if Half = 2 then Undo; // trigger another half step
end;
procedure THistory.Redo;
var
Half: Integer;
begin
if FIndex >= FSteps.Count - 1 then Exit;
FInEdit := False;
FixOnChangeBug := True;
Inc(FIndex);
// FPrevContent == FMemo.Text
with CurStep^ do begin
Half := HalfStep;
if SelStart > 0 then begin
// writeln(Format('Redo: %d, %s, %d', [SelStart-1, SelText, HalfStep]));
FMemo.SelStart := SelStart - 1; // from "baseed 1" to "based 0"
FMemo.SelLength := 0;
FMemo.SelText := SelText;
end else begin
// writeln(Format('Redo: %d, %s, %d', [-SelStart-1, SelText, HalfStep]));
FMemo.SelStart := -SelStart - 1; // from "baseed 1" to "based 0"
FMemo.SelLength := UTF8LengthFast(SelText);
FMemo.SelText := '';
end;
end;
FPrevContent := FMemo.Text;
if FixOnChangeBug then MemoOnChange(FMemo);
FInEdit := True;
if Half = 1 then Redo; // trigger another half step
end;
procedure THistory.PasteText;
var
ClipBoardText: string;
begin
ClipBoardText := ClipBoard.AsText;
if ClipBoardText = '' then Exit;
FInEdit := False;
FixOnChangeBug := True;
// FPrevContent == FMemo.Text
if FMemo.SelLength > 0 then begin
AddStep(-(FMemo.SelStart+1), FMemo.SelText, False);
AddStep(FMemo.SelStart + 1, ClipBoardText, True);
end else
AddStep(FMemo.SelStart + 1, ClipBoardText, False);
FMemo.SelText := ClipBoardText;
FPrevContent := FMemo.Text;
if FixOnChangeBug then MemoOnChange(FMemo);
FInEdit := True;
end;
procedure THistory.DeleteText;
begin
if FMemo.SelLength = 0 then Exit;
FInEdit := False;
FixOnChangeBug := True;
// FPrevContent == FMemo.Text
AddStep(-(FMemo.SelStart+1), FMemo.SelText, False);
FMemo.SelText := '';
FPrevContent := FMemo.Text;
if FixOnChangeBug then MemoOnChange(FMemo);
FInEdit := True;
end;
procedure THistory.Reset; inline;
begin
DelStep(0);
end;
{ ========== Custom Functions ========== }
// Convert the character index of a UTF8 string to a byte index. Returns 0 if
// UPos <= 0, return Size + 1 if UPos > Size. This function does not check the
// integrity of the UTF8 encoding, multi-codepoint character will be treated
// as multiple characters.
// Text : UTF8 string
// Size : size of UTF8 string
// UPos : index of character, based 1
// return value : byte index of UPos, based 1
function UTF8PosToBytePos(const Text: PChar; const Size: SizeInt; UPos: SizeInt): SizeInt;
begin
Result := 0;
if UPos <= 0 then Exit;
while (UPos > 1) and (Result < Size) do begin
case Text[Result] of
// #0 ..#127: Inc(Pos);
#192..#223: Inc(Result, 2);
#224..#239: Inc(Result, 3);
#240..#247: Inc(Result, 4);
else Inc(Result);
end;
Dec(UPos);
end;
Inc(Result);
end;
function UTF8PosToBytePos(const Text: String; const UPos: SizeInt): SizeInt; inline;
begin
Result := UTF8PosToBytePos(PChar(Text), Length(Text), UPos);
end;
// Get characters count of a UTF8 string.
// This function does not check the integrity of the UTF8 encoding,
// multi-codepoint character will be treated as multiple characters.
function UTF8LengthFast(const Text: PChar; const Size: SizeInt): SizeInt;
var
Pos: Integer;
begin
Result := 0;
Pos := 0;
while Pos < Size do begin
case Text[Pos] of
// #0 ..#127: Inc(Pos);
#192..#223: Inc(Pos, 2);
#224..#239: Inc(Pos, 3);
#240..#247: Inc(Pos, 4);
else Inc(Pos);
end;
Inc(Result);
end;
end;
function UTF8LengthFast(const AStr: String): SizeInt; inline;
begin
Result := UTF8LengthFast(PChar(AStr), Length(AStr));
end;
end.