A simpler undo / redo class for TMemo
lazarus / 31-LCL

----------------------------------------------------------------------
fedkad · 2018-02-23 15:43

I tried to use tomitomy's class:
https://forum.lazarus.freepascal.org/index.php/topic,38714.0.html; but
I had some difficulties with that. And being a guy who likes to use
his own code in his projects, I tried to develop a simpler Undo / Redo
class for TMemo. I think it can be adapted for other controls too. And
it works well in Windows and Linux (beware of the bug
https://bugs.freepascal.org/view.php?id=32669).

I am sharing it in the attached ZIP file. Any comments are welcome.
And of course, if you find it useful you can use it in your own
projects.

----------------------------------------------------------------------
fedkad · 2018-02-25 15:14

A quick question related to this:

As you know, Windows has a default context (popup) menu for a memo as
indicated in the image below.

Is it possible to override or define the code executed when a menu
item is selected from this default pop menu (such as "Undo")?

I do NOT want to define a new pop menu since the default one is good
enough, except its Undo function.

----------------------------------------------------------------------
ASerge · 2018-02-25 16:34

Quote from: fedkad on February 25, 2018, 04:14:21 pmIs it possible to
override or define the code executed when a menu item is selected from
this default pop menu (such as "Undo")?
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
Unit1; {$mode objfpc}{$H+} interface uses  Classes, SysUtils, Forms,
Controls, StdCtrls, Types; type  TForm1 = class(TForm)    Edit1:
TEdit;    procedure Edit1DblClick(Sender: TObject);  private   
function PopupBuiltInMenu(CanUndo, HasSelText, HasText: Boolean):
DWORD;  end; var  Form1: TForm1; implementation uses Windows,
ClipBrd; {$R *.lfm} function TForm1.PopupBuiltInMenu(CanUndo,
HasSelText, HasText: Boolean): DWORD;const  CEnable: array [Boolean]
of DWORD = (MF_DISABLED or MF_GRAYED, MF_ENABLED);  CFlags =
TPM_LEFTALIGN or TPM_RIGHTBUTTON or TPM_NONOTIFY or TPM_RETURNCMD;var 
HUser32: HMODULE;  LMenu, LPopupMenu: HMENU;begin  HUser32 :=
LoadLibraryEx(user32, 0, LOAD_LIBRARY_AS_DATAFILE);  if HUser32 <> 0
then  try    LMenu := LoadMenu(HUser32, MAKEINTRESOURCE(1));    if
LMenu <> 0 then    try      LPopupMenu := GetSubMenu(LMenu, 0);     
EnableMenuItem(LPopupMenu, WM_UNDO, CEnable[CanUndo]);     
EnableMenuItem(LPopupMenu, WM_CUT, CEnable[HasSelText]);     
EnableMenuItem(LPopupMenu, WM_COPY, CEnable[HasSelText]);     
EnableMenuItem(LPopupMenu, WM_PASTE,
CEnable[Clipboard.HasFormat(CF_TEXT)]);     
EnableMenuItem(LPopupMenu, WM_CLEAR, CEnable[HasSelText]);     
EnableMenuItem(LPopupMenu, EM_SETSEL, CEnable[HasText]);     
BOOL(Result) := TrackPopupMenu(LPopupMenu, CFlags, Mouse.CursorPos.x,
Mouse.CursorPos.y, 0, Handle, nil);    finally     
DestroyMenu(LMenu);    end;  finally    FreeLibrary(HUser32); 
end;end; procedure TForm1.Edit1DblClick(Sender: TObject);begin  case
PopupBuiltInMenu(Edit1.CanUndo, Edit1.SelLength > 0, Edit1.GetTextLen
> 0) of    WM_UNDO:      Caption := 'Undo';    EM_SETSEL:      Caption
:= 'Select all';  end;end; end.

----------------------------------------------------------------------
fedkad · 2018-02-25 16:56

It seems a bit complicated and system dependent; but thank you very
much ASerge.

----------------------------------------------------------------------
tomitomy · 2018-04-16 12:07

Please visit the new version through the link bollow(support undo by
word):
https://forum.lazarus.freepascal.org/index.php/topic,54069.0.html



Quote from: fedkad on February 23, 2018, 04:43:47 pmI tried to use
tomitomy's class:
https://forum.lazarus.freepascal.org/index.php/topic,38714.0.html; but
I had some difficulties with that. And being a guy who likes to use
his own code in his projects, I tried to develop a simpler Undo / Redo
class for TMemo. I think it can be adapted for other controls too. And
it works well in Windows and Linux (beware of the bug
https://bugs.freepascal.org/view.php?id=32669).

I am sharing it in the attached ZIP file. Any comments are welcome.
And of course, if you find it useful you can use it in your own
projects.

Thank you for sharing, I read your code, it works well, but it
consumes CPU resources very much. It will make a full content compare
when you type every character into Memo, which is very bad for editing
large text.

I wrote another Undo/Redo class with reference to your code. It
doesn't do any contrastive operation, and it is very fast, but it
can't support drag and drop operation. I hope someone can solve the
drag and drop problem.

The Demo is in the attachment, I tested in lazarus 1.8.2 on Ubuntu
16.04.

uhistory.pas:
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
uhistory; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
StdCtrls, lazUTF8; type   PStep = ^TStep;   TStep = record           
  BytePos : SizeInt;    InsStr  : string;    DelStr  : string;  end;  
{ THistory }   THistory = class  private    FMemo        : TMemo;   
FSteps       : TList;         // History Records    FIndex       :
Integer;       // Based 0    FOldOnChange : TNotifyEvent;    FInEdit 
   : Boolean;    FPrevContent : string;     function  
 GetStep(AIndex: Integer): PStep;      function    CurStep: PStep;   
procedure   AddStep(ABytePos: SizeInt; AInsStr, ADelStr: string);   
procedure   DelStep(Index: Integer);     procedure  
MemoOnChange(Sender: TObject);     function    StrDiff(out BytePos:
SizeInt; out InsStr, DelStr: string): Boolean;  public    constructor
Create(AMemo: TMemo);    destructor  Destroy; override;     function 
 CanUndo: Boolean;    function    CanRedo: Boolean;    procedure  
Undo;    procedure   Redo;  end; implementation { THistory } function
THistory.GetStep(AIndex: Integer): PStep;begin  Result :=
PStep(FSteps[AIndex]);end; function THistory.CurStep: PStep;begin 
Result := GetStep(FIndex);end;      procedure
THistory.AddStep(ABytePos: SizeInt; AInsStr, ADelStr: string);begin 
DelStep(FIndex + 1);   FSteps.Add(new(PStep));  Inc(FIndex);  with
CurStep^ do begin    BytePos  := ABytePos;    InsStr    := AInsStr;  
DelStr    := ADelStr;  end;end; procedure THistory.DelStep(Index:
Integer);var  i: Integer;begin  for i := FSteps.Count - 1 downto Index
do begin    GetStep(i)^.InsStr := '';    GetStep(i)^.DelStr := '';   
dispose(GetStep(i));    FSteps.Delete(i);  end;  FIndex := Index -
1;end; procedure THistory.MemoOnChange(Sender: TObject);var  InsStr,
DelStr: string;  BytePos: SizeInt;begin  if FInEdit and
StrDiff(BytePos, InsStr, DelStr) then begin    AddStep(BytePos,
InsStr, DelStr);    FPrevContent := FMemo.Text;  end;   if
Assigned(FOldOnChange) then    FOldOnChange(Sender);end; function
THistory.StrDiff(out BytePos: SizeInt; out InsStr, DelStr: string):
Boolean;var  DiffLen: SizeInt;begin  DiffLen := Length(FMemo.Text) -
Length(FPrevContent);  // UTF8CharToByteIndex based 0  BytePos :=
UTF8CharToByteIndex(PChar(FMemo.Text), Length(FMemo.Text),
FMemo.SelStart) + 1;   if DiffLen > 0 then begin    BytePos := BytePos
- DiffLen;    InsStr := Copy(FMemo.Text, BytePos, DiffLen); // Copy
based 1    DelStr := '';  end else if DiffLen < 0 then begin    InsStr
:= '';    DelStr := Copy(FPrevContent, BytePos, -DiffLen); // Copy
based 1  end else begin    Result := False;    Exit;  end;  Result :=
True;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  FInEdit := False;  FMemo.OnChange :=
FOldOnChange;  FMemo := nil;  FPrevContent := '';  DelStep(0); 
FSteps.Free;  inherited Destroy;end; function THistory.CanUndo:
Boolean;begin  Result := FIndex >= 0;end; function THistory.CanRedo:
Boolean;begin  Result := FIndex < FSteps.Count - 1;end; procedure
THistory.Undo;var  NewSelStart: SizeInt;begin  if FIndex < 0 then
Exit;  FInEdit := False;   // FPrevContent == FMemo.Text  with
CurStep^ do begin    if InsStr <> '' then begin     
Delete(FPrevContent, BytePos, Length(InsStr));      NewSelStart :=
FMemo.SelStart - UTF8LengthFast(InsStr);    end else if DelStr <> ''
then begin      Insert(DelStr, FPrevContent, BytePos);     
NewSelStart := FMemo.SelStart + UTF8LengthFast(DelStr);    end else
begin      writeln('Invalid history data!');    end;  end;  
FMemo.Text := FPrevContent;   FMemo.SelStart := NewSelStart;  FInEdit
:= True;   Dec(FIndex);end; procedure THistory.Redo;var  NewSelStart:
SizeInt;begin              if FIndex >= FSteps.Count - 1 then Exit; 
FInEdit := False;                    Inc(FIndex);  // FPrevContent ==
FMemo.Text  with CurStep^ do begin    if InsStr <> '' then begin     
Insert(InsStr, FPrevContent, BytePos);      NewSelStart :=
FMemo.SelStart + UTF8LengthFast(InsStr);    end else if DelStr <> ''
then begin      Delete(FPrevContent, BytePos, Length(DelStr));     
NewSelStart := FMemo.SelStart - UTF8LengthFast(DelStr);    end else
begin      writeln('Invalid history data!');    end;  end;  
FMemo.Text := FPrevContent;  FMemo.SelStart := NewSelStart;  FInEdit
:= True;end; end.

----------------------------------------------------------------------
tomitomy · 2018-04-16 16:55

I'm sorry, I was wrong, my code is not faster.  So, I use your
UTF8Diff instead of my StrDiff, make it support drag and drop.

New uhistory.pas:
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
uhistory; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
StdCtrls, lazUTF8; type   PStep = ^TStep;   TStep = record           
  BytePos  : SizeInt;    SelStart : SizeInt;    InsStr   : string;   
DelStr   : string;  end;   { THistory }   THistory = class  private  
FMemo        : TMemo;    FSteps       : TList;         // History
Records    FIndex       : Integer;       // Based 0    FOldOnChange :
TNotifyEvent;    FInEdit      : Boolean;    FPrevContent : string;   
function    GetStep(AIndex: Integer): PStep;      function    CurStep:
PStep;     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr,
ADelStr: string);    procedure   DelStep(Index: Integer);    
procedure   MemoOnChange(Sender: TObject);     function    StrDiff(out
ABytePos, ASelStart: SizeInt; out AInsStr, ADelStr: string): Boolean; 
public    constructor Create(AMemo: TMemo);    destructor  Destroy;
override;     function    CanUndo: Boolean;    function    CanRedo:
Boolean;    procedure   Undo;    procedure   Redo; 
end; implementation { THistory } function THistory.GetStep(AIndex:
Integer): PStep;begin  Result := PStep(FSteps[AIndex]);end; function
THistory.CurStep: PStep;begin  Result := GetStep(FIndex);end;     
procedure THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr,
ADelStr: string);begin  DelStep(FIndex + 1);  
FSteps.Add(new(PStep));  Inc(FIndex);  with CurStep^ do begin   
BytePos  := ABytePos;    SelStart := ASelStart;    InsStr   :=
AInsStr;    DelStr   := ADelStr;  end;end; procedure
THistory.DelStep(Index: Integer);var  i: Integer;begin  for i :=
FSteps.Count - 1 downto Index do begin    GetStep(i)^.InsStr := '';  
GetStep(i)^.DelStr := '';    dispose(GetStep(i));   
FSteps.Delete(i);  end;  FIndex := Index - 1;end; procedure
THistory.MemoOnChange(Sender: TObject);var  InsStr, DelStr: string; 
BytePos, SelStart: SizeInt;  // TickCount: Int64;begin  // TickCount
:= GetTickCount64;  if FInEdit and StrDiff(BytePos, SelStart, InsStr,
DelStr) then begin    // write(GetTickCount64 - TickCount, ' + ');   
// TickCount := GetTickCount64;    AddStep(BytePos, SelStart, InsStr,
DelStr);    FPrevContent := FMemo.Text;  end;             //
writeln(GetTickCount64 - TickCount);   if Assigned(FOldOnChange) then 
  FOldOnChange(Sender);end; function THistory.StrDiff(out ABytePos,
ASelStart: SizeInt; out AInsStr, ADelStr: string): Boolean;var 
CurContent, CurPos, CurEnd, PrevPos: PChar;  CurLen, PrevLen, DiffLen:
SizeInt;  CharLen: Integer;begin  CurContent := PChar(FMemo.Text); 
CurPos := CurContent;  PrevPos := PChar(FPrevContent);   CurLen :=
Length(CurPos);  PrevLen := Length(PrevPos);  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(CurContent, CurPos,
CharLen);  ABytePos := CurPos - CurContent + 1;  if DiffLen > 0 then
begin    AInsStr := Copy(FMemo.Text, ABytePos, DiffLen);    ADelStr :=
'';  end else if DiffLen < 0 then begin    AInsStr := '';    ADelStr
:= Copy(FPrevContent, ABytePos, -DiffLen);  end;    ASelStart :=
FMemo.SelStart;   Result := True;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 
FInEdit := False;  FMemo.OnChange := FOldOnChange;  FMemo := nil; 
FPrevContent := '';  DelStep(0);  FSteps.Free;  inherited
Destroy;end; function THistory.CanUndo: Boolean;begin  Result :=
FIndex >= 0;end; function THistory.CanRedo: Boolean;begin  Result :=
FIndex < FSteps.Count - 1;end; procedure THistory.Undo;var 
NewSelStart: SizeInt;begin  if FIndex < 0 then Exit;  FInEdit :=
False;   // FPrevContent == FMemo.Text  with CurStep^ do begin    if
InsStr <> '' then begin      Delete(FPrevContent, BytePos,
Length(InsStr));      NewSelStart := SelStart -
UTF8LengthFast(InsStr);    end else if DelStr <> '' then begin     
Insert(DelStr, FPrevContent, BytePos);      NewSelStart := SelStart +
UTF8LengthFast(DelStr);    end else begin      writeln('Invalid
history data!');    end;  end;   FMemo.Text := FPrevContent;  
FMemo.SelStart := NewSelStart;  FInEdit := True;  
Dec(FIndex);end; procedure THistory.Redo;var  NewSelStart:
SizeInt;begin              if FIndex >= FSteps.Count - 1 then Exit; 
FInEdit := False;                    Inc(FIndex);  // FPrevContent ==
FMemo.Text  with CurStep^ do begin    if InsStr <> '' then begin     
Insert(InsStr, FPrevContent, BytePos);      NewSelStart := SelStart +
UTF8LengthFast(InsStr);    end else if DelStr <> '' then begin     
Delete(FPrevContent, BytePos, Length(DelStr));      NewSelStart :=
SelStart - UTF8LengthFast(DelStr);    end else begin     
writeln('Invalid history data!');    end;  end;   FMemo.Text :=
FPrevContent;  FMemo.SelStart := NewSelStart;  FInEdit :=
True;end; end.

----------------------------------------------------------------------
tomitomy · 2018-04-17 05:34

I did a speed test (typing at the end of the 10MB text), found the
"FMemo.Text" operation and "Length(PChar)" operation takes up a lot of
time. I made some changes and raised the speed of 46%.

New uhistory.pas
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
uhistory; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
StdCtrls, lazUTF8; type   PStep = ^TStep;   TStep = record           
  BytePos  : SizeInt;    SelStart : SizeInt;    InsStr   : string;   
DelStr   : string;  end;   { THistory }   THistory = class  private  
FMemo        : TMemo;    FSteps       : TList;         // History
Records    FIndex       : Integer;       // Based 0    FOldOnChange :
TNotifyEvent;    FInEdit      : Boolean;    FPrevContent : string;   
function    GetStep(AIndex: Integer): PStep;      function    CurStep:
PStep;     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr,
ADelStr: string);    procedure   DelStep(Index: 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;    function    CanRedo: Boolean;    procedure   Undo;   
procedure   Redo;  end; implementation { THistory } function
THistory.GetStep(AIndex: Integer): PStep;begin  Result :=
PStep(FSteps[AIndex]);end; function THistory.CurStep: PStep;begin 
Result := GetStep(FIndex);end;      procedure
THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr:
string);begin  DelStep(FIndex + 1);  FSteps.Add(new(PStep)); 
Inc(FIndex);  with CurStep^ do begin    BytePos   := ABytePos;   
SelStart  := ASelStart;    InsStr    := AInsStr;    DelStr    :=
ADelStr;  end;end; procedure THistory.DelStep(Index: Integer);var  i:
Integer;begin  for i := FSteps.Count - 1 downto Index do begin   
GetStep(i)^.InsStr := '';    GetStep(i)^.DelStr := '';   
dispose(GetStep(i));    FSteps.Delete(i);  end;  FIndex := Index -
1;end; procedure THistory.MemoOnChange(Sender: TObject);var 
CurContent, InsStr, DelStr: string;  BytePos, SelStart: SizeInt;  //
TickCount: Int64;begin  // TickCount := GetTickCount64;  CurContent :=
FMemo.Text; // Only get FMemo.Text one times.  if FInEdit and
StrDiff(CurContent, BytePos, SelStart, InsStr, DelStr) then begin   
AddStep(BytePos, SelStart, InsStr, DelStr);    FPrevContent :=
CurContent;  end;  // writeln(GetTickCount64 - TickCount);   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; 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  FInEdit := False;  FMemo.OnChange :=
FOldOnChange;  FMemo := nil;  FPrevContent := '';  DelStep(0); 
FSteps.Free;  inherited Destroy;end; function THistory.CanUndo:
Boolean;begin  Result := FIndex >= 0;end; function THistory.CanRedo:
Boolean;begin  Result := FIndex < FSteps.Count - 1;end; procedure
THistory.Undo;var  NewSelStart: SizeInt;begin  if FIndex < 0 then
Exit;  FInEdit := False;   // FPrevContent == FMemo.Text  with
CurStep^ do begin    if InsStr <> '' then begin     
Delete(FPrevContent, BytePos, Length(InsStr));      NewSelStart :=
SelStart - UTF8LengthFast(InsStr);    end else begin     
Insert(DelStr, FPrevContent, BytePos);      NewSelStart := SelStart +
UTF8LengthFast(InsStr);    end;  end;   FMemo.Text := FPrevContent;  
FMemo.SelStart := NewSelStart;  FInEdit := True;  
Dec(FIndex);end; procedure THistory.Redo;var  NewSelStart:
SizeInt;begin              if FIndex >= FSteps.Count - 1 then Exit; 
FInEdit := False;                    Inc(FIndex);  // FPrevContent ==
FMemo.Text  with CurStep^ do begin    if InsStr <> '' then begin     
Insert(InsStr, FPrevContent, BytePos);      NewSelStart := SelStart; 
 end else begin      Delete(FPrevContent, BytePos, Length(DelStr));  
  NewSelStart := SelStart;    end;  end;   FMemo.Text :=
FPrevContent;  FMemo.SelStart := NewSelStart;  FInEdit :=
True;end; end.
------------------------------------------------------------

Add Note: There is an error in line #204 of history.pas, the code
"NewSelStart := SelStart + UTF8LengthFast(InsStr);" should be
"NewSelStart := SelStart + UTF8LengthFast(DelStr);"

------------------------------------------------------------

Add Note: Using this code below to instead of "THistory.StrDiff" in
above code can increase the speed by 30% (the OnChange speed, not the
Undo/Redo speed). But does not support drag and drop (Because of the
wrong FMemo.SelStart after drag and drop).

The attachment does not updated.

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i 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; function THistory.StrDiff(const ACurContent: string; 
out ABytePos, ASelStart: SizeInt;  out AInsStr, ADelStr: string):
Boolean;var  DiffLen: SizeInt;begin  DiffLen := Length(ACurContent) -
Length(FPrevContent);  // UTF8CharToByteIndex based 0  // ABytePos :=
UTF8CharToByteIndex(PChar(ACurContent), Length(ACurContent),
FMemo.SelStart) + 1;  ABytePos := UTF8PosToBytePos(PChar(ACurContent),
Length(ACurContent), FMemo.SelStart + 1);                           
 ASelStart := FMemo.SelStart;  if DiffLen > 0 then begin    ABytePos
:= ABytePos - DiffLen;    AInsStr := Copy(ACurContent, ABytePos,
DiffLen); // Copy based 1    ADelStr := '';  end else if DiffLen < 0
then begin    AInsStr := '';    ADelStr := Copy(FPrevContent,
ABytePos, -DiffLen); // Copy based 1  end else begin    Result :=
False;    Exit;  end;   Result := True;end;
------------------------------------------------------------

----------------------------------------------------------------------
tomitomy · 2018-04-17 08:19

This code can make the Paste has a better Undo/Redo, if you selected
some text then paste, you will undo twice to back to the before of
paste, this code only need undo one times.

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
uhistory; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
StdCtrls, lazUTF8, Clipbrd; type   PStep = ^TStep;   TStep = record  
BytePos  : SizeInt;    SelStart : SizeInt;    InsStr   : string;   
DelStr   : string;  end;   { THistory }   THistory = class  private  
FMemo        : TMemo;    FSteps       : TList;         // History
Records    FIndex       : Integer;       // Based 0    FOldOnChange :
TNotifyEvent;    FInEdit      : Boolean;    FPrevContent : string;   
function    GetStep(AIndex: Integer): PStep;    function    CurStep:
PStep;     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr,
ADelStr: string);    procedure   DelStep(Index: 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;    function    CanRedo: Boolean;    procedure   Undo;   
procedure   Redo;    procedure   Paste;  end; implementation {
THistory } function THistory.GetStep(AIndex: Integer): PStep;begin 
Result := PStep(FSteps[AIndex]);end; function THistory.CurStep:
PStep;begin  Result := GetStep(FIndex);end; procedure
THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr:
string);begin  DelStep(FIndex + 1);   FSteps.Add(new(PStep)); 
Inc(FIndex);  with CurStep^ do begin    BytePos  := ABytePos;   
SelStart := ASelStart;    InsStr   := AInsStr;    DelStr   :=
ADelStr;  end;end; procedure THistory.DelStep(Index: Integer);var  i:
Integer;begin  for i := FSteps.Count - 1 downto Index do begin   
GetStep(i)^.InsStr := '';    GetStep(i)^.DelStr := '';   
dispose(GetStep(i));    FSteps.Delete(i);  end;  FIndex := Index -
1;end; procedure THistory.MemoOnChange(Sender: TObject);var 
CurContent, InsStr, DelStr: string;  BytePos, SelStart: SizeInt;  //
TickCount: Int64;begin  // TickCount := GetTickCount64;  CurContent :=
FMemo.Text; // Only get FMemo.Text one times.  if FInEdit and
StrDiff(CurContent, BytePos, SelStart, InsStr, DelStr) then   
AddStep(BytePos, SelStart, InsStr, DelStr);  FPrevContent :=
CurContent;  // writeln(GetTickCount64 - TickCount);   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; 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  FInEdit := False;  FMemo.OnChange :=
FOldOnChange;  FMemo := nil;  FPrevContent := '';  DelStep(0); 
FSteps.Free;  inherited Destroy;end; function THistory.CanUndo:
Boolean;begin  Result := FIndex >= 0;end; function THistory.CanRedo:
Boolean;begin  Result := FIndex < FSteps.Count - 1;end; procedure
THistory.Undo;var  NewSelStart: SizeInt;begin  if FIndex < 0 then
Exit;  FInEdit := False;   // 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.Text :=
FPrevContent;  FMemo.SelStart := NewSelStart;  Dec(FIndex);   FInEdit
:= True;end; procedure THistory.Redo;var  NewSelStart: SizeInt;begin 
if FIndex >= FSteps.Count - 1 then Exit;  FInEdit := False;  
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.Text := FPrevContent; 
FMemo.SelStart := NewSelStart;   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.Paste;var  BytePos: SizeInt; 
ClipBoardText: string;begin  FInEdit := False;   ClipBoardText :=
ClipBoard.AsText;  if ClipBoardText <> '' then begin    //
FPrevContent == FMemo.Text    BytePos :=
UTF8PosToBytePos(FPrevContent, Length(FPrevContent), FMemo.SelStart +
1);    AddStep(BytePos, FMemo.SelStart, ClipBoardText,
FMemo.SelText);    FMemo.SelText := ClipBoardText;  end;   FInEdit :=
True;end; end.

----------------------------------------------------------------------
tomitomy · 2018-04-23 01:32

Fix the OnChange bug (https://bugs.freepascal.org/view.php?id=32669).

uhistory.pas:
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i 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.