Recent

Author Topic: A simpler undo / redo class for TMemo  (Read 4172 times)

fedkad

  • Full Member
  • ***
  • Posts: 176
A simpler undo / redo class for TMemo
« on: February 23, 2018, 04:43:47 pm »
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.
Lazarus 2.2.6 / FPC 3.2.2 on x86_64-linux-gtk2 (Ubuntu/GNOME) and x86_64-win64-win32/win64 (Windows 11)

fedkad

  • Full Member
  • ***
  • Posts: 176
Re: A simpler undo / redo class for TMemo
« Reply #1 on: February 25, 2018, 04:14:21 pm »
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.
« Last Edit: February 25, 2018, 04:21:46 pm by fedkad »
Lazarus 2.2.6 / FPC 3.2.2 on x86_64-linux-gtk2 (Ubuntu/GNOME) and x86_64-win64-win32/win64 (Windows 11)

ASerge

  • Hero Member
  • *****
  • Posts: 2222
Re: A simpler undo / redo class for TMemo
« Reply #2 on: February 25, 2018, 05:34:13 pm »
Is 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][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, Forms, Controls, StdCtrls, Types;
  9.  
  10. type
  11.   TForm1 = class(TForm)
  12.     Edit1: TEdit;
  13.     procedure Edit1DblClick(Sender: TObject);
  14.   private
  15.     function PopupBuiltInMenu(CanUndo, HasSelText, HasText: Boolean): DWORD;
  16.   end;
  17.  
  18. var
  19.   Form1: TForm1;
  20.  
  21. implementation
  22.  
  23. uses Windows, ClipBrd;
  24.  
  25. {$R *.lfm}
  26.  
  27. function TForm1.PopupBuiltInMenu(CanUndo, HasSelText, HasText: Boolean): DWORD;
  28. const
  29.   CEnable: array [Boolean] of DWORD = (MF_DISABLED or MF_GRAYED, MF_ENABLED);
  30.   CFlags = TPM_LEFTALIGN or TPM_RIGHTBUTTON or TPM_NONOTIFY or TPM_RETURNCMD;
  31. var
  32.   HUser32: HMODULE;
  33.   LMenu, LPopupMenu: HMENU;
  34. begin
  35.   HUser32 := LoadLibraryEx(user32, 0, LOAD_LIBRARY_AS_DATAFILE);
  36.   if HUser32 <> 0 then
  37.   try
  38.     LMenu := LoadMenu(HUser32, MAKEINTRESOURCE(1));
  39.     if LMenu <> 0 then
  40.     try
  41.       LPopupMenu := GetSubMenu(LMenu, 0);
  42.       EnableMenuItem(LPopupMenu, WM_UNDO, CEnable[CanUndo]);
  43.       EnableMenuItem(LPopupMenu, WM_CUT, CEnable[HasSelText]);
  44.       EnableMenuItem(LPopupMenu, WM_COPY, CEnable[HasSelText]);
  45.       EnableMenuItem(LPopupMenu, WM_PASTE, CEnable[Clipboard.HasFormat(CF_TEXT)]);
  46.       EnableMenuItem(LPopupMenu, WM_CLEAR, CEnable[HasSelText]);
  47.       EnableMenuItem(LPopupMenu, EM_SETSEL, CEnable[HasText]);
  48.       BOOL(Result) := TrackPopupMenu(LPopupMenu, CFlags, Mouse.CursorPos.x, Mouse.CursorPos.y, 0, Handle, nil);
  49.     finally
  50.       DestroyMenu(LMenu);
  51.     end;
  52.   finally
  53.     FreeLibrary(HUser32);
  54.   end;
  55. end;
  56.  
  57. procedure TForm1.Edit1DblClick(Sender: TObject);
  58. begin
  59.   case PopupBuiltInMenu(Edit1.CanUndo, Edit1.SelLength > 0, Edit1.GetTextLen > 0) of
  60.     WM_UNDO:
  61.       Caption := 'Undo';
  62.     EM_SETSEL:
  63.       Caption := 'Select all';
  64.   end;
  65. end;
  66.  
  67. end.

fedkad

  • Full Member
  • ***
  • Posts: 176
Re: A simpler undo / redo class for TMemo
« Reply #3 on: February 25, 2018, 05:56:51 pm »
It seems a bit complicated and system dependent; but thank you very much ASerge.
Lazarus 2.2.6 / FPC 3.2.2 on x86_64-linux-gtk2 (Ubuntu/GNOME) and x86_64-win64-win32/win64 (Windows 11)

tomitomy

  • Sr. Member
  • ****
  • Posts: 251
Re: A simpler undo / redo class for TMemo
« Reply #4 on: April 16, 2018, 02:07:59 pm »
Please visit the new version through the link bollow(support undo by word):
https://forum.lazarus.freepascal.org/index.php/topic,54069.0.html



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.

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][+][-]
  1. unit uhistory;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, StdCtrls, lazUTF8;
  9.  
  10. type
  11.  
  12.   PStep = ^TStep;
  13.  
  14.   TStep = record          
  15.     BytePos : SizeInt;
  16.     InsStr  : string;
  17.     DelStr  : string;
  18.   end;
  19.  
  20.   { THistory }
  21.  
  22.   THistory = class
  23.   private
  24.     FMemo        : TMemo;
  25.     FSteps       : TList;         // History Records
  26.     FIndex       : Integer;       // Based 0
  27.     FOldOnChange : TNotifyEvent;
  28.     FInEdit      : Boolean;
  29.     FPrevContent : string;
  30.  
  31.     function    GetStep(AIndex: Integer): PStep;  
  32.     function    CurStep: PStep;
  33.  
  34.     procedure   AddStep(ABytePos: SizeInt; AInsStr, ADelStr: string);
  35.     procedure   DelStep(Index: Integer);
  36.  
  37.     procedure   MemoOnChange(Sender: TObject);
  38.  
  39.     function    StrDiff(out BytePos: SizeInt; out InsStr, DelStr: string): Boolean;
  40.   public
  41.     constructor Create(AMemo: TMemo);
  42.     destructor  Destroy; override;
  43.  
  44.     function    CanUndo: Boolean;
  45.     function    CanRedo: Boolean;
  46.     procedure   Undo;
  47.     procedure   Redo;
  48.   end;
  49.  
  50. implementation
  51.  
  52. { THistory }
  53.  
  54. function THistory.GetStep(AIndex: Integer): PStep;
  55. begin
  56.   Result := PStep(FSteps[AIndex]);
  57. end;
  58.  
  59. function THistory.CurStep: PStep;
  60. begin
  61.   Result := GetStep(FIndex);
  62. end;
  63.      
  64. procedure THistory.AddStep(ABytePos: SizeInt; AInsStr, ADelStr: string);
  65. begin
  66.   DelStep(FIndex + 1);
  67.  
  68.   FSteps.Add(new(PStep));
  69.   Inc(FIndex);
  70.   with CurStep^ do begin
  71.     BytePos  := ABytePos;
  72.     InsStr    := AInsStr;
  73.     DelStr    := ADelStr;
  74.   end;
  75. end;
  76.  
  77. procedure THistory.DelStep(Index: Integer);
  78. var
  79.   i: Integer;
  80. begin
  81.   for i := FSteps.Count - 1 downto Index do begin
  82.     GetStep(i)^.InsStr := '';
  83.     GetStep(i)^.DelStr := '';
  84.     dispose(GetStep(i));
  85.     FSteps.Delete(i);
  86.   end;
  87.   FIndex := Index - 1;
  88. end;
  89.  
  90. procedure THistory.MemoOnChange(Sender: TObject);
  91. var
  92.   InsStr, DelStr: string;
  93.   BytePos: SizeInt;
  94. begin
  95.   if FInEdit and StrDiff(BytePos, InsStr, DelStr) then begin
  96.     AddStep(BytePos, InsStr, DelStr);
  97.     FPrevContent := FMemo.Text;
  98.   end;
  99.  
  100.   if Assigned(FOldOnChange) then
  101.     FOldOnChange(Sender);
  102. end;
  103.  
  104. function THistory.StrDiff(out BytePos: SizeInt; out InsStr, DelStr: string): Boolean;
  105. var
  106.   DiffLen: SizeInt;
  107. begin
  108.   DiffLen := Length(FMemo.Text) - Length(FPrevContent);
  109.   // UTF8CharToByteIndex based 0
  110.   BytePos := UTF8CharToByteIndex(PChar(FMemo.Text), Length(FMemo.Text), FMemo.SelStart) + 1;
  111.  
  112.   if DiffLen > 0 then begin
  113.     BytePos := BytePos - DiffLen;
  114.     InsStr := Copy(FMemo.Text, BytePos, DiffLen); // Copy based 1
  115.     DelStr := '';
  116.   end else if DiffLen < 0 then begin
  117.     InsStr := '';
  118.     DelStr := Copy(FPrevContent, BytePos, -DiffLen); // Copy based 1
  119.   end else begin
  120.     Result := False;
  121.     Exit;
  122.   end;
  123.   Result := True;
  124. end;
  125.  
  126. constructor THistory.Create(AMemo: TMemo);
  127. begin
  128.   inherited Create;
  129.   FSteps := TList.Create;
  130.   FMemo := AMemo;
  131.   FOldOnChange := FMemo.OnChange;
  132.   FMemo.OnChange := @MemoOnChange;
  133.   FPrevContent := FMemo.Text;
  134.   FIndex := -1;
  135.   FInEdit := True;
  136. end;
  137.  
  138. destructor THistory.Destroy;
  139. begin
  140.   FInEdit := False;
  141.   FMemo.OnChange := FOldOnChange;
  142.   FMemo := nil;
  143.   FPrevContent := '';
  144.   DelStep(0);
  145.   FSteps.Free;
  146.   inherited Destroy;
  147. end;
  148.  
  149. function THistory.CanUndo: Boolean;
  150. begin
  151.   Result := FIndex >= 0;
  152. end;
  153.  
  154. function THistory.CanRedo: Boolean;
  155. begin
  156.   Result := FIndex < FSteps.Count - 1;
  157. end;
  158.  
  159. procedure THistory.Undo;
  160. var
  161.   NewSelStart: SizeInt;
  162. begin
  163.   if FIndex < 0 then Exit;
  164.   FInEdit := False;
  165.  
  166.   // FPrevContent == FMemo.Text
  167.   with CurStep^ do begin
  168.     if InsStr <> '' then begin
  169.       Delete(FPrevContent, BytePos, Length(InsStr));
  170.       NewSelStart := FMemo.SelStart - UTF8LengthFast(InsStr);
  171.     end else if DelStr <> '' then begin
  172.       Insert(DelStr, FPrevContent, BytePos);
  173.       NewSelStart := FMemo.SelStart + UTF8LengthFast(DelStr);
  174.     end else begin
  175.       writeln('Invalid history data!');
  176.     end;
  177.   end;
  178.  
  179.   FMemo.Text := FPrevContent;
  180.   FMemo.SelStart := NewSelStart;
  181.   FInEdit := True;
  182.  
  183.   Dec(FIndex);
  184. end;
  185.  
  186. procedure THistory.Redo;
  187. var
  188.   NewSelStart: SizeInt;
  189. begin            
  190.   if FIndex >= FSteps.Count - 1 then Exit;
  191.   FInEdit := False;
  192.                  
  193.   Inc(FIndex);
  194.   // FPrevContent == FMemo.Text
  195.   with CurStep^ do begin
  196.     if InsStr <> '' then begin
  197.       Insert(InsStr, FPrevContent, BytePos);
  198.       NewSelStart := FMemo.SelStart + UTF8LengthFast(InsStr);
  199.     end else if DelStr <> '' then begin
  200.       Delete(FPrevContent, BytePos, Length(DelStr));
  201.       NewSelStart := FMemo.SelStart - UTF8LengthFast(DelStr);
  202.     end else begin
  203.       writeln('Invalid history data!');
  204.     end;
  205.   end;
  206.  
  207.   FMemo.Text := FPrevContent;
  208.   FMemo.SelStart := NewSelStart;
  209.   FInEdit := True;
  210. end;
  211.  
  212. end.
« Last Edit: April 11, 2021, 07:22:20 am by tomitomy »

tomitomy

  • Sr. Member
  • ****
  • Posts: 251
Re: A simpler undo / redo class for TMemo
« Reply #5 on: April 16, 2018, 06:55:39 pm »
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][+][-]
  1. unit uhistory;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, StdCtrls, lazUTF8;
  9.  
  10. type
  11.  
  12.   PStep = ^TStep;
  13.  
  14.   TStep = record          
  15.     BytePos  : SizeInt;
  16.     SelStart : SizeInt;
  17.     InsStr   : string;
  18.     DelStr   : string;
  19.   end;
  20.  
  21.   { THistory }
  22.  
  23.   THistory = class
  24.   private
  25.     FMemo        : TMemo;
  26.     FSteps       : TList;         // History Records
  27.     FIndex       : Integer;       // Based 0
  28.     FOldOnChange : TNotifyEvent;
  29.     FInEdit      : Boolean;
  30.     FPrevContent : string;
  31.  
  32.     function    GetStep(AIndex: Integer): PStep;  
  33.     function    CurStep: PStep;
  34.  
  35.     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  36.     procedure   DelStep(Index: Integer);
  37.  
  38.     procedure   MemoOnChange(Sender: TObject);
  39.  
  40.     function    StrDiff(out ABytePos, ASelStart: SizeInt; out AInsStr, ADelStr: string): Boolean;
  41.   public
  42.     constructor Create(AMemo: TMemo);
  43.     destructor  Destroy; override;
  44.  
  45.     function    CanUndo: Boolean;
  46.     function    CanRedo: Boolean;
  47.     procedure   Undo;
  48.     procedure   Redo;
  49.   end;
  50.  
  51. implementation
  52.  
  53. { THistory }
  54.  
  55. function THistory.GetStep(AIndex: Integer): PStep;
  56. begin
  57.   Result := PStep(FSteps[AIndex]);
  58. end;
  59.  
  60. function THistory.CurStep: PStep;
  61. begin
  62.   Result := GetStep(FIndex);
  63. end;
  64.      
  65. procedure THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  66. begin
  67.   DelStep(FIndex + 1);
  68.  
  69.   FSteps.Add(new(PStep));
  70.   Inc(FIndex);
  71.   with CurStep^ do begin
  72.     BytePos  := ABytePos;
  73.     SelStart := ASelStart;
  74.     InsStr   := AInsStr;
  75.     DelStr   := ADelStr;
  76.   end;
  77. end;
  78.  
  79. procedure THistory.DelStep(Index: Integer);
  80. var
  81.   i: Integer;
  82. begin
  83.   for i := FSteps.Count - 1 downto Index do begin
  84.     GetStep(i)^.InsStr := '';
  85.     GetStep(i)^.DelStr := '';
  86.     dispose(GetStep(i));
  87.     FSteps.Delete(i);
  88.   end;
  89.   FIndex := Index - 1;
  90. end;
  91.  
  92. procedure THistory.MemoOnChange(Sender: TObject);
  93. var
  94.   InsStr, DelStr: string;
  95.   BytePos, SelStart: SizeInt;
  96.   // TickCount: Int64;
  97. begin
  98.   // TickCount := GetTickCount64;
  99.   if FInEdit and StrDiff(BytePos, SelStart, InsStr, DelStr) then begin
  100.     // write(GetTickCount64 - TickCount, ' + ');
  101.     // TickCount := GetTickCount64;
  102.     AddStep(BytePos, SelStart, InsStr, DelStr);
  103.     FPrevContent := FMemo.Text;
  104.   end;          
  105.   // writeln(GetTickCount64 - TickCount);
  106.  
  107.   if Assigned(FOldOnChange) then
  108.     FOldOnChange(Sender);
  109. end;
  110.  
  111. function THistory.StrDiff(out ABytePos, ASelStart: SizeInt; out AInsStr, ADelStr: string): Boolean;
  112. var
  113.   CurContent, CurPos, CurEnd, PrevPos: PChar;
  114.   CurLen, PrevLen, DiffLen: SizeInt;
  115.   CharLen: Integer;
  116. begin
  117.   CurContent := PChar(FMemo.Text);
  118.   CurPos := CurContent;
  119.   PrevPos := PChar(FPrevContent);
  120.  
  121.   CurLen := Length(CurPos);
  122.   PrevLen := Length(PrevPos);
  123.   DiffLen := CurLen - PrevLen;
  124.  
  125.   if DiffLen < 0 then
  126.     CurEnd := CurPos + CurLen - 1
  127.   else if DiffLen > 0 then
  128.     CurEnd := CurPos + PrevLen - 1
  129.   else begin
  130.     Result := False;
  131.     Exit;
  132.   end;
  133.  
  134.   while (CurPos <= CurEnd) do begin
  135.     if CurPos^ <> PrevPos^ then
  136.       Break;
  137.     Inc(CurPos);
  138.     Inc(PrevPos);
  139.   end;
  140.   Utf8TryFindCodepointStart(CurContent, CurPos, CharLen);
  141.   ABytePos := CurPos - CurContent + 1;
  142.   if DiffLen > 0 then begin
  143.     AInsStr := Copy(FMemo.Text, ABytePos, DiffLen);
  144.     ADelStr := '';
  145.   end else if DiffLen < 0 then begin
  146.     AInsStr := '';
  147.     ADelStr := Copy(FPrevContent, ABytePos, -DiffLen);
  148.   end;  
  149.   ASelStart := FMemo.SelStart;
  150.  
  151.   Result := True;
  152. end;
  153.  
  154. constructor THistory.Create(AMemo: TMemo);
  155. begin
  156.   inherited Create;
  157.   FSteps := TList.Create;
  158.   FMemo := AMemo;
  159.   FOldOnChange := FMemo.OnChange;
  160.   FMemo.OnChange := @MemoOnChange;
  161.   FPrevContent := FMemo.Text;
  162.   FIndex := -1;
  163.   FInEdit := True;
  164. end;
  165.  
  166. destructor THistory.Destroy;
  167. begin
  168.   FInEdit := False;
  169.   FMemo.OnChange := FOldOnChange;
  170.   FMemo := nil;
  171.   FPrevContent := '';
  172.   DelStep(0);
  173.   FSteps.Free;
  174.   inherited Destroy;
  175. end;
  176.  
  177. function THistory.CanUndo: Boolean;
  178. begin
  179.   Result := FIndex >= 0;
  180. end;
  181.  
  182. function THistory.CanRedo: Boolean;
  183. begin
  184.   Result := FIndex < FSteps.Count - 1;
  185. end;
  186.  
  187. procedure THistory.Undo;
  188. var
  189.   NewSelStart: SizeInt;
  190. begin
  191.   if FIndex < 0 then Exit;
  192.   FInEdit := False;
  193.  
  194.   // FPrevContent == FMemo.Text
  195.   with CurStep^ do begin
  196.     if InsStr <> '' then begin
  197.       Delete(FPrevContent, BytePos, Length(InsStr));
  198.       NewSelStart := SelStart - UTF8LengthFast(InsStr);
  199.     end else if DelStr <> '' then begin
  200.       Insert(DelStr, FPrevContent, BytePos);
  201.       NewSelStart := SelStart + UTF8LengthFast(DelStr);
  202.     end else begin
  203.       writeln('Invalid history data!');
  204.     end;
  205.   end;
  206.  
  207.   FMemo.Text := FPrevContent;
  208.   FMemo.SelStart := NewSelStart;
  209.   FInEdit := True;
  210.  
  211.   Dec(FIndex);
  212. end;
  213.  
  214. procedure THistory.Redo;
  215. var
  216.   NewSelStart: SizeInt;
  217. begin            
  218.   if FIndex >= FSteps.Count - 1 then Exit;
  219.   FInEdit := False;
  220.                  
  221.   Inc(FIndex);
  222.   // FPrevContent == FMemo.Text
  223.   with CurStep^ do begin
  224.     if InsStr <> '' then begin
  225.       Insert(InsStr, FPrevContent, BytePos);
  226.       NewSelStart := SelStart + UTF8LengthFast(InsStr);
  227.     end else if DelStr <> '' then begin
  228.       Delete(FPrevContent, BytePos, Length(DelStr));
  229.       NewSelStart := SelStart - UTF8LengthFast(DelStr);
  230.     end else begin
  231.       writeln('Invalid history data!');
  232.     end;
  233.   end;
  234.  
  235.   FMemo.Text := FPrevContent;
  236.   FMemo.SelStart := NewSelStart;
  237.   FInEdit := True;
  238. end;
  239.  
  240. end.

tomitomy

  • Sr. Member
  • ****
  • Posts: 251
Re: A simpler undo / redo class for TMemo
« Reply #6 on: April 17, 2018, 07:34:08 am »
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][+][-]
  1. unit uhistory;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, StdCtrls, lazUTF8;
  9.  
  10. type
  11.  
  12.   PStep = ^TStep;
  13.  
  14.   TStep = record          
  15.     BytePos  : SizeInt;
  16.     SelStart : SizeInt;
  17.     InsStr   : string;
  18.     DelStr   : string;
  19.   end;
  20.  
  21.   { THistory }
  22.  
  23.   THistory = class
  24.   private
  25.     FMemo        : TMemo;
  26.     FSteps       : TList;         // History Records
  27.     FIndex       : Integer;       // Based 0
  28.     FOldOnChange : TNotifyEvent;
  29.     FInEdit      : Boolean;
  30.     FPrevContent : string;
  31.  
  32.     function    GetStep(AIndex: Integer): PStep;  
  33.     function    CurStep: PStep;
  34.  
  35.     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  36.     procedure   DelStep(Index: Integer);
  37.  
  38.     procedure   MemoOnChange(Sender: TObject);
  39.  
  40.     function    StrDiff(const ACurContent: string;
  41.                         out ABytePos, ASelStart: SizeInt;
  42.                         out AInsStr, ADelStr: string): Boolean;
  43.   public
  44.     constructor Create(AMemo: TMemo);
  45.     destructor  Destroy; override;
  46.  
  47.     function    CanUndo: Boolean;
  48.     function    CanRedo: Boolean;
  49.     procedure   Undo;
  50.     procedure   Redo;
  51.   end;
  52.  
  53. implementation
  54.  
  55. { THistory }
  56.  
  57. function THistory.GetStep(AIndex: Integer): PStep;
  58. begin
  59.   Result := PStep(FSteps[AIndex]);
  60. end;
  61.  
  62. function THistory.CurStep: PStep;
  63. begin
  64.   Result := GetStep(FIndex);
  65. end;
  66.      
  67. procedure THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  68. begin
  69.   DelStep(FIndex + 1);
  70.   FSteps.Add(new(PStep));
  71.   Inc(FIndex);
  72.   with CurStep^ do begin
  73.     BytePos   := ABytePos;
  74.     SelStart  := ASelStart;
  75.     InsStr    := AInsStr;
  76.     DelStr    := ADelStr;
  77.   end;
  78. end;
  79.  
  80. procedure THistory.DelStep(Index: Integer);
  81. var
  82.   i: Integer;
  83. begin
  84.   for i := FSteps.Count - 1 downto Index do begin
  85.     GetStep(i)^.InsStr := '';
  86.     GetStep(i)^.DelStr := '';
  87.     dispose(GetStep(i));
  88.     FSteps.Delete(i);
  89.   end;
  90.   FIndex := Index - 1;
  91. end;
  92.  
  93. procedure THistory.MemoOnChange(Sender: TObject);
  94. var
  95.   CurContent, InsStr, DelStr: string;
  96.   BytePos, SelStart: SizeInt;
  97.   // TickCount: Int64;
  98. begin
  99.   // TickCount := GetTickCount64;
  100.   CurContent := FMemo.Text; // Only get FMemo.Text one times.
  101.   if FInEdit and StrDiff(CurContent, BytePos, SelStart, InsStr, DelStr) then begin
  102.     AddStep(BytePos, SelStart, InsStr, DelStr);
  103.     FPrevContent := CurContent;
  104.   end;
  105.   // writeln(GetTickCount64 - TickCount);
  106.  
  107.   if Assigned(FOldOnChange) then
  108.     FOldOnChange(Sender);
  109. end;
  110.  
  111. function THistory.StrDiff(const ACurContent: string;
  112.   out ABytePos, ASelStart: SizeInt;
  113.   out AInsStr, ADelStr: string): Boolean;
  114. var
  115.   CurStart, CurPos, CurEnd, PrevPos: PChar;
  116.   CurLen, PrevLen, DiffLen: SizeInt;
  117.   CharLen: Integer;
  118. begin
  119.   CurStart := PChar(ACurContent);
  120.   CurPos := CurStart;
  121.   PrevPos := PChar(FPrevContent);
  122.  
  123.   CurLen := Length(ACurContent);   // Use Length(string) DO NOT use Length(PChar)
  124.   PrevLen := Length(FPrevContent);
  125.   DiffLen := CurLen - PrevLen;
  126.  
  127.   if DiffLen < 0 then
  128.     CurEnd := CurPos + CurLen - 1
  129.   else if DiffLen > 0 then
  130.     CurEnd := CurPos + PrevLen - 1
  131.   else begin
  132.     Result := False;
  133.     Exit;
  134.   end;
  135.  
  136.   while (CurPos <= CurEnd) do begin
  137.     if CurPos^ <> PrevPos^ then Break;
  138.     Inc(CurPos);
  139.     Inc(PrevPos);
  140.   end;
  141.  
  142.   Utf8TryFindCodepointStart(CurStart, CurPos, CharLen);
  143.   ABytePos := CurPos - CurStart + 1;
  144.  
  145.   if DiffLen > 0 then begin
  146.     AInsStr := Copy(ACurContent, ABytePos, DiffLen);
  147.     ADelStr := '';
  148.   end else begin
  149.     AInsStr := '';
  150.     ADelStr := Copy(FPrevContent, ABytePos, -DiffLen);
  151.   end;
  152.     ASelStart := FMemo.SelStart;
  153.  
  154.   Result := True;
  155. end;
  156.  
  157. constructor THistory.Create(AMemo: TMemo);
  158. begin
  159.   inherited Create;
  160.   FSteps := TList.Create;
  161.   FMemo := AMemo;
  162.   FOldOnChange := FMemo.OnChange;
  163.   FMemo.OnChange := @MemoOnChange;
  164.   FPrevContent := FMemo.Text;
  165.   FIndex := -1;
  166.   FInEdit := True;
  167. end;
  168.  
  169. destructor THistory.Destroy;
  170. begin
  171.   FInEdit := False;
  172.   FMemo.OnChange := FOldOnChange;
  173.   FMemo := nil;
  174.   FPrevContent := '';
  175.   DelStep(0);
  176.   FSteps.Free;
  177.   inherited Destroy;
  178. end;
  179.  
  180. function THistory.CanUndo: Boolean;
  181. begin
  182.   Result := FIndex >= 0;
  183. end;
  184.  
  185. function THistory.CanRedo: Boolean;
  186. begin
  187.   Result := FIndex < FSteps.Count - 1;
  188. end;
  189.  
  190. procedure THistory.Undo;
  191. var
  192.   NewSelStart: SizeInt;
  193. begin
  194.   if FIndex < 0 then Exit;
  195.   FInEdit := False;
  196.  
  197.   // FPrevContent == FMemo.Text
  198.   with CurStep^ do begin
  199.     if InsStr <> '' then begin
  200.       Delete(FPrevContent, BytePos, Length(InsStr));
  201.       NewSelStart := SelStart - UTF8LengthFast(InsStr);
  202.     end else begin
  203.       Insert(DelStr, FPrevContent, BytePos);
  204.       NewSelStart := SelStart + UTF8LengthFast(InsStr);
  205.     end;
  206.   end;
  207.  
  208.   FMemo.Text := FPrevContent;
  209.   FMemo.SelStart := NewSelStart;
  210.   FInEdit := True;
  211.  
  212.   Dec(FIndex);
  213. end;
  214.  
  215. procedure THistory.Redo;
  216. var
  217.   NewSelStart: SizeInt;
  218. begin            
  219.   if FIndex >= FSteps.Count - 1 then Exit;
  220.   FInEdit := False;
  221.                  
  222.   Inc(FIndex);
  223.   // FPrevContent == FMemo.Text
  224.   with CurStep^ do begin
  225.     if InsStr <> '' then begin
  226.       Insert(InsStr, FPrevContent, BytePos);
  227.       NewSelStart := SelStart;
  228.     end else begin
  229.       Delete(FPrevContent, BytePos, Length(DelStr));
  230.       NewSelStart := SelStart;
  231.     end;
  232.   end;
  233.  
  234.   FMemo.Text := FPrevContent;
  235.   FMemo.SelStart := NewSelStart;
  236.   FInEdit := True;
  237. end;
  238.  
  239. 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][+][-]
  1. function UTF8PosToBytePos(const AStr: string; const ASize: SizeInt; APos: SizeInt): SizeInt;
  2. begin
  3.   if APos < 1 then Result := -1 else Result := 0;
  4.  
  5.   while (APos > 1) and (Result < ASize) do begin
  6.     case AStr[Result] of
  7.       // #0..#127: Inc(Result);
  8.       #192..#223: Inc(Result, 2);
  9.       #224..#239: Inc(Result, 3);
  10.       #240..#247: Inc(Result, 4);
  11.       else Inc(Result);
  12.     end;
  13.     Dec(APos);
  14.   end;
  15.  
  16.   Inc(Result)
  17. end;
  18.  
  19. function THistory.StrDiff(const ACurContent: string;
  20.   out ABytePos, ASelStart: SizeInt;
  21.   out AInsStr, ADelStr: string): Boolean;
  22. var
  23.   DiffLen: SizeInt;
  24. begin
  25.   DiffLen := Length(ACurContent) - Length(FPrevContent);
  26.   // UTF8CharToByteIndex based 0
  27.   // ABytePos := UTF8CharToByteIndex(PChar(ACurContent), Length(ACurContent), FMemo.SelStart) + 1;
  28.   ABytePos := UTF8PosToBytePos(PChar(ACurContent), Length(ACurContent), FMemo.SelStart + 1);
  29.                              
  30.   ASelStart := FMemo.SelStart;
  31.   if DiffLen > 0 then begin
  32.     ABytePos := ABytePos - DiffLen;
  33.     AInsStr := Copy(ACurContent, ABytePos, DiffLen); // Copy based 1
  34.     ADelStr := '';
  35.   end else if DiffLen < 0 then begin
  36.     AInsStr := '';
  37.     ADelStr := Copy(FPrevContent, ABytePos, -DiffLen); // Copy based 1
  38.   end else begin
  39.     Result := False;
  40.     Exit;
  41.   end;
  42.  
  43.   Result := True;
  44. end;

------------------------------------------------------------
« Last Edit: April 19, 2018, 07:41:15 am by tomitomy »

tomitomy

  • Sr. Member
  • ****
  • Posts: 251
Re: A simpler undo / redo class for TMemo
« Reply #7 on: April 17, 2018, 10:19:26 am »
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][+][-]
  1. unit uhistory;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, StdCtrls, lazUTF8, Clipbrd;
  9.  
  10. type
  11.  
  12.   PStep = ^TStep;
  13.  
  14.   TStep = record
  15.     BytePos  : SizeInt;
  16.     SelStart : SizeInt;
  17.     InsStr   : string;
  18.     DelStr   : string;
  19.   end;
  20.  
  21.   { THistory }
  22.  
  23.   THistory = class
  24.   private
  25.     FMemo        : TMemo;
  26.     FSteps       : TList;         // History Records
  27.     FIndex       : Integer;       // Based 0
  28.     FOldOnChange : TNotifyEvent;
  29.     FInEdit      : Boolean;
  30.     FPrevContent : string;
  31.  
  32.     function    GetStep(AIndex: Integer): PStep;
  33.     function    CurStep: PStep;
  34.  
  35.     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  36.     procedure   DelStep(Index: Integer);
  37.  
  38.     procedure   MemoOnChange(Sender: TObject);
  39.  
  40.     function    StrDiff(const ACurContent: string;
  41.                         out ABytePos, ASelStart: SizeInt;
  42.                         out AInsStr, ADelStr: string): Boolean;
  43.   public
  44.     constructor Create(AMemo: TMemo);
  45.     destructor  Destroy; override;
  46.  
  47.     function    CanUndo: Boolean;
  48.     function    CanRedo: Boolean;
  49.     procedure   Undo;
  50.     procedure   Redo;
  51.     procedure   Paste;
  52.   end;
  53.  
  54. implementation
  55.  
  56. { THistory }
  57.  
  58. function THistory.GetStep(AIndex: Integer): PStep;
  59. begin
  60.   Result := PStep(FSteps[AIndex]);
  61. end;
  62.  
  63. function THistory.CurStep: PStep;
  64. begin
  65.   Result := GetStep(FIndex);
  66. end;
  67.  
  68. procedure THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  69. begin
  70.   DelStep(FIndex + 1);
  71.  
  72.   FSteps.Add(new(PStep));
  73.   Inc(FIndex);
  74.   with CurStep^ do begin
  75.     BytePos  := ABytePos;
  76.     SelStart := ASelStart;
  77.     InsStr   := AInsStr;
  78.     DelStr   := ADelStr;
  79.   end;
  80. end;
  81.  
  82. procedure THistory.DelStep(Index: Integer);
  83. var
  84.   i: Integer;
  85. begin
  86.   for i := FSteps.Count - 1 downto Index do begin
  87.     GetStep(i)^.InsStr := '';
  88.     GetStep(i)^.DelStr := '';
  89.     dispose(GetStep(i));
  90.     FSteps.Delete(i);
  91.   end;
  92.   FIndex := Index - 1;
  93. end;
  94.  
  95. procedure THistory.MemoOnChange(Sender: TObject);
  96. var
  97.   CurContent, InsStr, DelStr: string;
  98.   BytePos, SelStart: SizeInt;
  99.   // TickCount: Int64;
  100. begin
  101.   // TickCount := GetTickCount64;
  102.   CurContent := FMemo.Text; // Only get FMemo.Text one times.
  103.   if FInEdit and StrDiff(CurContent, BytePos, SelStart, InsStr, DelStr) then
  104.     AddStep(BytePos, SelStart, InsStr, DelStr);
  105.   FPrevContent := CurContent;
  106.   // writeln(GetTickCount64 - TickCount);
  107.  
  108.   if Assigned(FOldOnChange) then
  109.     FOldOnChange(Sender);
  110. end;
  111.  
  112. function THistory.StrDiff(const ACurContent: string;
  113.   out ABytePos, ASelStart: SizeInt;
  114.   out AInsStr, ADelStr: string): Boolean;
  115. var
  116.   CurStart, CurPos, CurEnd, PrevPos: PChar;
  117.   CurLen, PrevLen, DiffLen: SizeInt;
  118.   CharLen: Integer;
  119. begin
  120.   CurStart := PChar(ACurContent);
  121.   CurPos := CurStart;
  122.   PrevPos := PChar(FPrevContent);
  123.  
  124.   CurLen := Length(ACurContent);   // Use Length(string) DO NOT use Length(PChar)
  125.   PrevLen := Length(FPrevContent);
  126.   DiffLen := CurLen - PrevLen;
  127.  
  128.   if DiffLen < 0 then
  129.     CurEnd := CurPos + CurLen - 1
  130.   else if DiffLen > 0 then
  131.     CurEnd := CurPos + PrevLen - 1
  132.   else begin
  133.     Result := False;
  134.     Exit;
  135.   end;
  136.  
  137.   while (CurPos <= CurEnd) do begin
  138.     if CurPos^ <> PrevPos^ then Break;
  139.     Inc(CurPos);
  140.     Inc(PrevPos);
  141.   end;
  142.  
  143.   Utf8TryFindCodepointStart(CurStart, CurPos, CharLen);
  144.   ABytePos := CurPos - CurStart + 1;
  145.  
  146.   if DiffLen > 0 then begin
  147.     AInsStr := Copy(ACurContent, ABytePos, DiffLen);
  148.     ADelStr := '';
  149.   end else begin
  150.     AInsStr := '';
  151.     ADelStr := Copy(FPrevContent, ABytePos, -DiffLen);
  152.   end;
  153.   ASelStart := FMemo.SelStart;
  154.  
  155.   Result := True;
  156. end;
  157.  
  158. constructor THistory.Create(AMemo: TMemo);
  159. begin
  160.   inherited Create;
  161.   FSteps := TList.Create;
  162.   FMemo := AMemo;
  163.   FOldOnChange := FMemo.OnChange;
  164.   FMemo.OnChange := @MemoOnChange;
  165.   FPrevContent := FMemo.Text;
  166.   FIndex := -1;
  167.   FInEdit := True;
  168. end;
  169.  
  170. destructor THistory.Destroy;
  171. begin
  172.   FInEdit := False;
  173.   FMemo.OnChange := FOldOnChange;
  174.   FMemo := nil;
  175.   FPrevContent := '';
  176.   DelStep(0);
  177.   FSteps.Free;
  178.   inherited Destroy;
  179. end;
  180.  
  181. function THistory.CanUndo: Boolean;
  182. begin
  183.   Result := FIndex >= 0;
  184. end;
  185.  
  186. function THistory.CanRedo: Boolean;
  187. begin
  188.   Result := FIndex < FSteps.Count - 1;
  189. end;
  190.  
  191. procedure THistory.Undo;
  192. var
  193.   NewSelStart: SizeInt;
  194. begin
  195.   if FIndex < 0 then Exit;
  196.   FInEdit := False;
  197.  
  198.   // FPrevContent == FMemo.Text
  199.   with CurStep^ do begin
  200.     if InsStr <> '' then begin
  201.       Delete(FPrevContent, BytePos, Length(InsStr));
  202.       NewSelStart := SelStart - UTF8LengthFast(InsStr);
  203.     end;
  204.     if DelStr <>'' then begin
  205.       Insert(DelStr, FPrevContent, BytePos);
  206.       NewSelStart := SelStart + UTF8LengthFast(DelStr);
  207.     end;
  208.   end;
  209.   FMemo.Text := FPrevContent;
  210.   FMemo.SelStart := NewSelStart;
  211.   Dec(FIndex);
  212.  
  213.   FInEdit := True;
  214. end;
  215.  
  216. procedure THistory.Redo;
  217. var
  218.   NewSelStart: SizeInt;
  219. begin
  220.   if FIndex >= FSteps.Count - 1 then Exit;
  221.   FInEdit := False;
  222.  
  223.   Inc(FIndex);
  224.   // FPrevContent == FMemo.Text
  225.   with CurStep^ do begin
  226.     if DelStr <> '' then begin
  227.       Delete(FPrevContent, BytePos, Length(DelStr));
  228.       NewSelStart := SelStart;
  229.     end;
  230.     if InsStr <> '' then begin
  231.       Insert(InsStr, FPrevContent, BytePos);
  232.       NewSelStart := SelStart;
  233.     end;
  234.   end;
  235.   FMemo.Text := FPrevContent;
  236.   FMemo.SelStart := NewSelStart;
  237.  
  238.   FInEdit := True;
  239. end;
  240.  
  241. function UTF8PosToBytePos(const AStr: string; const ASize: SizeInt; APos: SizeInt): SizeInt;
  242. begin
  243.   if APos < 1 then Result := -1 else Result := 0;
  244.  
  245.   while (APos > 1) and (Result < ASize) do begin
  246.     case AStr[Result] of
  247.       // #0..#127: Inc(Result);
  248.       #192..#223: Inc(Result, 2);
  249.       #224..#239: Inc(Result, 3);
  250.       #240..#247: Inc(Result, 4);
  251.       else Inc(Result);
  252.     end;
  253.     Dec(APos);
  254.   end;
  255.  
  256.   Inc(Result)
  257. end;
  258.  
  259. procedure THistory.Paste;
  260. var
  261.   BytePos: SizeInt;
  262.   ClipBoardText: string;
  263. begin
  264.   FInEdit := False;
  265.  
  266.   ClipBoardText := ClipBoard.AsText;
  267.   if ClipBoardText <> '' then begin
  268.     // FPrevContent == FMemo.Text
  269.     BytePos := UTF8PosToBytePos(FPrevContent, Length(FPrevContent), FMemo.SelStart + 1);
  270.     AddStep(BytePos, FMemo.SelStart, ClipBoardText, FMemo.SelText);
  271.     FMemo.SelText := ClipBoardText;
  272.   end;
  273.  
  274.   FInEdit := True;
  275. end;
  276.  
  277. end.

tomitomy

  • Sr. Member
  • ****
  • Posts: 251
Re: A simpler undo / redo class for TMemo
« Reply #8 on: April 23, 2018, 03:32:16 am »
Fix the OnChange bug (https://bugs.freepascal.org/view.php?id=32669).

uhistory.pas:
Code: Pascal  [Select][+][-]
  1. unit uhistory;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, StdCtrls, lazUTF8, Clipbrd;
  9.  
  10. type
  11.  
  12.   PStep = ^TStep;
  13.  
  14.   // 单步历史记录数据
  15.   // one step of history data
  16.   TStep = record
  17.     BytePos  : SizeInt;
  18.     SelStart : SizeInt; // used to restore the cursor position(用于恢复光标位置)
  19.     InsStr   : string;
  20.     DelStr   : string;
  21.   end;
  22.  
  23.   { THistory }
  24.  
  25.   THistory = class
  26.   private
  27.     FMemo        : TMemo;
  28.     FSteps       : TList;         // history records data(历史记录数据)
  29.     FIndex       : Integer;       // history index, based 0(历史记录索引,从 0 开始)
  30.     FOldOnChange : TNotifyEvent;
  31.     FInEdit      : Boolean;
  32.  
  33.     // OnChange 事件之前的 FMemo 内容
  34.     // the content of FMemo before OnChange event
  35.     FPrevContent : string;
  36.     FSize        : SizeInt;       // all steps size(所有历史步骤的总大小)
  37.  
  38.     FixOnChangeBug : Boolean;
  39.  
  40.     function    GetStep(AIndex: Integer): PStep; inline;
  41.     function    CurStep: PStep; inline;
  42.  
  43.     procedure   AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  44.     procedure   DelStep(AIndex: Integer);
  45.  
  46.     procedure   MemoOnChange(Sender: TObject);
  47.  
  48.     function    StrDiff(const ACurContent: string;
  49.                         out ABytePos, ASelStart: SizeInt;
  50.                         out AInsStr, ADelStr: string): Boolean;
  51.   public
  52.     constructor Create(AMemo: TMemo);
  53.     destructor  Destroy; override;
  54.  
  55.     function    CanUndo: Boolean; inline;
  56.     function    CanRedo: Boolean; inline;
  57.     procedure   Undo;
  58.     procedure   Redo;
  59.  
  60.     // 你应该使用 Paste 函数粘贴文本,而不是 FMemo.PasteFromClipboard 函数,
  61.     // 否则你的粘贴操作可能需要撤销两次才能恢复到粘贴之前的状态。
  62.     // you should use Paste function to paste text instead of FMemo.PasteFromClipboard function,
  63.     // otherwise your paste operation may need to perform twice Undo to restore to the state before paste.
  64.     procedure   PasteText;
  65.  
  66.     // 你应该使用 DeleteText 函数删除文本,而不是 FMemo.Text := '' 方法,
  67.     // 否则你的删除操作可能不会触发 OnChange 事件。
  68.     // you should use the DeleteText function to delete text instead of the FMemo.Text := '' method,
  69.     // otherwise your delete operation may not trigger the OnChange event.
  70.     procedure   DeleteText;
  71.                            
  72.     procedure   Reset; inline;
  73.     property    Size: SizeInt read FSize;
  74.   end;
  75.  
  76. implementation
  77.  
  78. { THistory }
  79.  
  80. function THistory.GetStep(AIndex: Integer): PStep; inline;
  81. begin
  82.   Result := PStep(FSteps[AIndex]);
  83. end;
  84.  
  85. function THistory.CurStep: PStep; inline;
  86. begin
  87.   Result := GetStep(FIndex);
  88. end;
  89.  
  90. procedure THistory.AddStep(ABytePos, ASelStart: SizeInt; AInsStr, ADelStr: string);
  91. begin
  92.   DelStep(FIndex + 1);
  93.  
  94.   FSteps.Add(new(PStep));
  95.   Inc(FIndex);
  96.   Inc(FSize, Sizeof(TStep) + Length(AInsStr) + Length(ADelStr));
  97.   with CurStep^ do begin
  98.     BytePos  := ABytePos;
  99.     SelStart := ASelStart;
  100.     InsStr   := AInsStr;
  101.     DelStr   := ADelStr;
  102.   end;
  103. end;
  104.  
  105. procedure THistory.DelStep(AIndex: Integer);
  106. var
  107.   i: Integer;
  108.   Step: PStep;
  109. begin
  110.   for i := FSteps.Count - 1 downto AIndex do begin
  111.     Step := GetStep(i);
  112.     Dec(FSize, Sizeof(TStep) + Length(Step^.InsStr) + Length(Step^.DelStr));
  113.     Step^.InsStr := '';
  114.     Step^.DelStr := '';
  115.     dispose(Step);
  116.     FSteps.Delete(i);
  117.   end;
  118.   FIndex := AIndex - 1;
  119. end;
  120.  
  121. constructor THistory.Create(AMemo: TMemo);
  122. begin
  123.   inherited Create;
  124.   FSteps := TList.Create;
  125.  
  126.   FMemo := AMemo;
  127.   FOldOnChange := FMemo.OnChange;
  128.   FMemo.OnChange := @MemoOnChange;
  129.  
  130.   FPrevContent := FMemo.Text;
  131.   FIndex := -1;
  132.  
  133.   FInEdit := True;
  134. end;
  135.  
  136. destructor THistory.Destroy;
  137. begin
  138.   FMemo.OnChange := FOldOnChange;
  139.   FMemo := nil;
  140.  
  141.   DelStep(0);
  142.   FSteps.Free;
  143.   inherited Destroy;
  144. end;
  145.  
  146. procedure THistory.MemoOnChange(Sender: TObject);
  147. var
  148.   CurContent, InsStr, DelStr: string;
  149.   BytePos, SelStart: SizeInt;
  150. begin
  151.   if FInEdit then begin
  152.     CurContent := FMemo.Text;
  153.     if StrDiff(CurContent, BytePos, SelStart, InsStr, DelStr) then
  154.       AddStep(BytePos, SelStart, InsStr, DelStr);
  155.     FPrevContent := CurContent;
  156.   end;
  157.  
  158.   FixOnChangeBug := False;
  159.  
  160.   if Assigned(FOldOnChange) then
  161.     FOldOnChange(Sender);
  162. end;
  163.  
  164. function THistory.StrDiff(const ACurContent: string;
  165.   out ABytePos, ASelStart: SizeInt;
  166.   out AInsStr, ADelStr: string): Boolean;
  167. var
  168.   CurStart, CurPos, CurEnd, PrevPos: PChar;
  169.   CurLen, PrevLen, DiffLen: SizeInt;
  170.   CharLen: Integer;
  171. begin
  172.   CurStart := PChar(ACurContent);
  173.   CurPos := CurStart;
  174.   PrevPos := PChar(FPrevContent);
  175.  
  176.   CurLen := Length(ACurContent);   // Use Length(string) DO NOT use Length(PChar)
  177.   PrevLen := Length(FPrevContent);
  178.   DiffLen := CurLen - PrevLen;
  179.  
  180.   if DiffLen < 0 then
  181.     CurEnd := CurPos + CurLen - 1
  182.   else if DiffLen > 0 then
  183.     CurEnd := CurPos + PrevLen - 1
  184.   else begin
  185.     Result := False;
  186.     Exit;
  187.   end;
  188.  
  189.   while (CurPos <= CurEnd) do begin
  190.     if CurPos^ <> PrevPos^ then Break;
  191.     Inc(CurPos);
  192.     Inc(PrevPos);
  193.   end;
  194.  
  195.   Utf8TryFindCodepointStart(CurStart, CurPos, CharLen);
  196.   ABytePos := CurPos - CurStart + 1;
  197.  
  198.   if DiffLen > 0 then begin
  199.     AInsStr := Copy(ACurContent, ABytePos, DiffLen);
  200.     ADelStr := '';
  201.   end else begin
  202.     AInsStr := '';
  203.     ADelStr := Copy(FPrevContent, ABytePos, -DiffLen);
  204.   end;
  205.   ASelStart := FMemo.SelStart;
  206.  
  207.   Result := True;
  208. end;
  209.  
  210. function THistory.CanUndo: Boolean; inline;
  211. begin
  212.   Result := FIndex >= 0;
  213. end;
  214.  
  215. function THistory.CanRedo: Boolean; inline;
  216. begin
  217.   Result := FIndex < FSteps.Count - 1;
  218. end;
  219.  
  220. procedure THistory.Undo;
  221. var
  222.   NewSelStart: SizeInt;
  223. begin
  224.   if FIndex < 0 then Exit;
  225.   FInEdit := False;
  226.  
  227.   FixOnChangeBug := True;
  228.  
  229.   // FPrevContent == FMemo.Text
  230.   with CurStep^ do begin
  231.     if InsStr <> '' then begin
  232.       Delete(FPrevContent, BytePos, Length(InsStr));
  233.       NewSelStart := SelStart - UTF8LengthFast(InsStr);
  234.     end;
  235.     if DelStr <>'' then begin
  236.       Insert(DelStr, FPrevContent, BytePos);
  237.       NewSelStart := SelStart + UTF8LengthFast(DelStr);
  238.     end;
  239.   end;
  240.   FMemo.Lines.Text := FPrevContent;
  241.   FMemo.SelStart := NewSelStart;
  242.   Dec(FIndex);
  243.  
  244.   if FixOnChangeBug then MemoOnChange(FMemo);
  245.  
  246.   FInEdit := True;
  247. end;
  248.  
  249. procedure THistory.Redo;
  250. var
  251.   NewSelStart: SizeInt;
  252. begin
  253.   if FIndex >= FSteps.Count - 1 then Exit;
  254.   FInEdit := False;
  255.  
  256.   FixOnChangeBug := True;
  257.  
  258.   Inc(FIndex);
  259.   // FPrevContent == FMemo.Text
  260.   with CurStep^ do begin
  261.     if DelStr <> '' then begin
  262.       Delete(FPrevContent, BytePos, Length(DelStr));
  263.       NewSelStart := SelStart;
  264.     end;
  265.     if InsStr <> '' then begin
  266.       Insert(InsStr, FPrevContent, BytePos);
  267.       NewSelStart := SelStart;
  268.     end;
  269.   end;
  270.   FMemo.Lines.Text := FPrevContent;
  271.   FMemo.SelStart := NewSelStart;
  272.  
  273.   if FixOnChangeBug then MemoOnChange(FMemo);
  274.  
  275.   FInEdit := True;
  276. end;
  277.  
  278. function UTF8PosToBytePos(const AStr: string; const ASize: SizeInt; APos: SizeInt): SizeInt;
  279. begin
  280.   if APos < 1 then Result := -1 else Result := 0;
  281.  
  282.   while (APos > 1) and (Result < ASize) do begin
  283.     case AStr[Result] of
  284.       // #0..#127: Inc(Result);
  285.       #192..#223: Inc(Result, 2);
  286.       #224..#239: Inc(Result, 3);
  287.       #240..#247: Inc(Result, 4);
  288.       else Inc(Result);
  289.     end;
  290.     Dec(APos);
  291.   end;
  292.  
  293.   Inc(Result)
  294. end;
  295.  
  296. procedure THistory.PasteText;
  297. var
  298.   BytePos: SizeInt;
  299.   ClipBoardText: string;
  300. begin
  301.   FInEdit := False;
  302.  
  303.   ClipBoardText := ClipBoard.AsText;
  304.   if ClipBoardText <> '' then begin
  305.     FixOnChangeBug := True;
  306.  
  307.     // FPrevContent == FMemo.Text
  308.     BytePos := UTF8PosToBytePos(FPrevContent, Length(FPrevContent), FMemo.SelStart + 1);
  309.     AddStep(BytePos, FMemo.SelStart, ClipBoardText, FMemo.SelText);
  310.     FMemo.SelText := ClipBoardText;
  311.     FPrevContent := FMemo.Text;
  312.  
  313.     if FixOnChangeBug then MemoOnChange(FMemo);
  314.   end;
  315.  
  316.   FInEdit := True;
  317. end;
  318.  
  319. procedure THistory.DeleteText;
  320. var
  321.   BytePos: SizeInt;
  322. begin
  323.   FInEdit := False;
  324.  
  325.   if FMemo.SelLength > 0 then begin
  326.     FixOnChangeBug := True;
  327.  
  328.     // FPrevContent == FMemo.Text
  329.     BytePos := UTF8PosToBytePos(FPrevContent, Length(FPrevContent), FMemo.SelStart + 1);
  330.     AddStep(BytePos, FMemo.SelStart, '', FMemo.SelText);
  331.     FMemo.SelText := '';
  332.     FPrevContent := FMemo.Text;
  333.  
  334.     if FixOnChangeBug then MemoOnChange(FMemo);
  335.   end;
  336.  
  337.   FInEdit := True;
  338. end;
  339.  
  340. procedure THistory.Reset; inline;
  341. begin
  342.   DelStep(0);
  343.   FPrevContent := FMemo.Text;
  344. end;
  345.  
  346. end.

 

TinyPortal © 2005-2018