Undo.pas

   1 unit Undo;
   2
   3 interface
   4
   5 uses System.Contnrs, System.Classes, Vcl.StdCtrls;
   6
   7 type
   8   TUndoBase = class
   9   private
  10     FPos: integer;
  11     FMemo: TCustomMemo;
  12   public
  13     procedure Execute; virtual; abstract;
  14     procedure ReDo; virtual; abstract;
  15   end;
  16
  17   TUnInput = class(TUndoBase)
  18   private
  19     FData: Char;
  20   public
  21     procedure Execute; override;
  22     procedure ReDo; override;
  23   end;
  24
  25   TUnDelete = class(TUndoBase)
  26   private
  27     FStr: string;
  28     FTop: Boolean;
  29   public
  30     procedure Execute; override;
  31     procedure ReDo; override;
  32   end;
  33
  34   TUnPaste = class(TUndoBase)
  35   private
  36     FLen: integer;
  37     FStr: string;
  38   public
  39     procedure Execute; override;
  40     procedure ReDo; override;
  41   end;
  42
  43   TUnRETURN = class(TUndoBase)
  44   public
  45     procedure Execute; override;
  46     procedure ReDo; override;
  47   end;
  48
  49   TUndoClass = class(TComponent)
  50   private
  51     FStack: TObjectStack;
  52     FReStack: TObjectStack;
  53     FMemo: TCustomMemo;
  54     FCnt: integer;
  55     FBack: integer;
  56     FDel: integer;
  57     function GetCanUndo: Boolean;
  58     procedure Clear;
  59     procedure DelRedoStack;
  60     procedure SetMemo(const Value: TCustomMemo);
  61     function GetCanRedo: Boolean;
  62   public
  63     constructor Create(AOwner: TComponent); override;
  64     procedure Deleted(const str: string; pos: integer; top: Boolean);
  65     procedure Inputted(c: Char; pos: integer);
  66     procedure Returned(pos: integer);
  67     procedure Pasted(const str: string; pos: integer);
  68     procedure Execute;
  69     procedure ReDo;
  70     destructor Destroy; override;
  71     procedure UpCount;
  72     procedure UpDelCnt;
  73     procedure UpBackCnt;
  74     procedure ResetCnt;
  75     procedure ResetDel;
  76     procedure ResetBack;
  77   published
  78     property Memo: TCustomMemo read FMemo write SetMemo;
  79     property CanUndo: Boolean read GetCanUndo;
  80     property CanRedo: Boolean read GetCanRedo;
  81   end;
  82
  83 implementation
  84
  85 { TUndoClass }
  86
  87 procedure TUndoClass.Clear;
  88 var
  89   i: integer;
  90 begin
  91   for i := 0 to FStack.Count - 1 do
  92     FStack.Pop.Free;
  93   for i := 0 to FReStack.Count - 1 do
  94     FReStack.Pop.Free;
  95 end;
  96
  97 constructor TUndoClass.Create(AOwner: TComponent);
  98 begin
  99   inherited;
 100   FStack := TObjectStack.Create;
 101   FReStack := TObjectStack.Create;
 102 end;
 103
 104 procedure TUndoClass.Deleted(const str: string; pos: integer; top: Boolean);
 105 var
 106   obj: TUnDelete;
 107 begin
 108   if str = '' then
 109     Exit;
 110   DelRedoStack;
 111   if ((FBack > 0) or (FDel > 0)) and (FStack.Peek is TUnDelete) and
 112     (Length(str) = 1) then
 113   begin
 114     obj := FStack.Peek as TUnDelete;
 115     if top = obj.FTop then
 116     begin
 117       if top = true then
 118       begin
 119         obj.FStr := obj.FStr + str;
 120         obj.FPos := obj.FPos;
 121       end
 122       else
 123       begin
 124         obj.FStr := str + obj.FStr;
 125         obj.FPos := obj.FPos-1;
 126       end;
 127     end
 128     else
 129     begin
 130       FBack := 0;
 131       FDel := 0;
 132       Deleted(str, pos, top);
 133     end;
 134   end
 135   else
 136   begin
 137     FBack := 0;
 138     FDel := 0;
 139     obj := TUnDelete.Create;
 140     obj.FStr := str;
 141     obj.FPos := pos;
 142     obj.FTop := top;
 143     obj.FMemo := FMemo;
 144     FStack.Push(obj);
 145   end;
 146 end;
 147
 148 procedure TUndoClass.DelRedoStack;
 149 var
 150   i: integer;
 151 begin
 152   if FReStack.Count > 0 then
 153     for i := 1 to FReStack.Count do
 154       FReStack.Pop.Free;
 155 end;
 156
 157 destructor TUndoClass.Destroy;
 158 begin
 159   Clear;
 160   FStack.Free;
 161   FReStack.Free;
 162   inherited;
 163 end;
 164
 165 procedure TUndoClass.Execute;
 166 var
 167   obj: TUndoBase;
 168 begin
 169   if FStack.Count > 0 then
 170   begin
 171     obj := FStack.Pop as TUndoBase;
 172     obj.Execute;
 173     FReStack.Push(obj);
 174   end;
 175 end;
 176
 177 function TUndoClass.GetCanRedo: Boolean;
 178 begin
 179   result := FReStack.Count > 0;
 180 end;
 181
 182 function TUndoClass.GetCanUndo: Boolean;
 183 begin
 184   result := FStack.Count > 0;
 185 end;
 186
 187 procedure TUndoClass.Inputted(c: Char; pos: integer);
 188 var
 189   data: TUnPaste;
 190 begin
 191   DelRedoStack;
 192   if (FCnt > 0) and (FStack.Count > 0) and (FStack.Peek is TUnPaste) then
 193   begin
 194     data := FStack.Peek as TUnPaste;
 195     data.FLen := data.FLen + 1;
 196     data.FStr := data.FStr + c;
 197   end
 198   else
 199   begin
 200     data := TUnPaste.Create;
 201     data.FPos := pos;
 202     data.FLen := 1;
 203     data.FStr := c;
 204     data.FMemo := FMemo;
 205     FStack.Push(data);
 206   end;
 207 end;
 208
 209 procedure TUndoClass.Pasted(const str: string; pos: integer);
 210 var
 211   obj: TUnPaste;
 212 begin
 213   DelRedoStack;
 214   obj := TUnPaste.Create;
 215   obj.FPos := pos;
 216   obj.FLen := Length(str);
 217   obj.FStr := str;
 218   obj.FMemo := FMemo;
 219   FStack.Push(obj);
 220 end;
 221
 222 procedure TUndoClass.ReDo;
 223 var
 224   obj: TUndoBase;
 225 begin
 226   if FReStack.Count > 0 then
 227   begin
 228     obj := FReStack.Pop as TUndoBase;
 229     obj.ReDo;
 230     FStack.Push(obj);
 231   end;
 232 end;
 233
 234 procedure TUndoClass.ResetBack;
 235 begin
 236   FBack := 0;
 237 end;
 238
 239 procedure TUndoClass.ResetCnt;
 240 begin
 241   FCnt := 0;
 242 end;
 243
 244 procedure TUndoClass.ResetDel;
 245 begin
 246   FDel := 0;
 247 end;
 248
 249 procedure TUndoClass.Returned(pos: integer);
 250 var
 251   obj: TUnRETURN;
 252 begin
 253   DelRedoStack;
 254   obj := TUnRETURN.Create;
 255   obj.FPos := pos;
 256   obj.FMemo := FMemo;
 257   FStack.Push(obj);
 258 end;
 259
 260 procedure TUndoClass.SetMemo(const Value: TCustomMemo);
 261 var
 262   obj: TUndoBase;
 263   i: integer;
 264   List: TList;
 265 begin
 266   FMemo := Value;
 267   List := TList.Create;
 268   for i := 1 to FStack.Count do
 269   begin
 270     obj := FStack.Pop as TUndoBase;
 271     obj.FMemo := Value;
 272     List.Add(obj);
 273   end;
 274   for i := List.Count - 1 downto 0 do
 275     FStack.Push(List[i]);
 276   List.Free;
 277 end;
 278
 279 procedure TUndoClass.UpBackCnt;
 280 begin
 281   inc(FBack);
 282   if FBack > 5 then
 283     FBack := 0;
 284 end;
 285
 286 procedure TUndoClass.UpCount;
 287 begin
 288   inc(FCnt);
 289   if FCnt > 5 then
 290     FCnt := 0;
 291 end;
 292
 293 procedure TUndoClass.UpDelCnt;
 294 begin
 295   inc(FDel);
 296   if FDel > 5 then
 297     FDel := 0;
 298 end;
 299
 300 { TUnDelete }
 301
 302 procedure TUnDelete.Execute;
 303 begin
 304   FMemo.SelStart := FPos;
 305   FMemo.SelText := FStr;
 306   FMemo.SelStart := FPos;
 307   if Length(FStr) > 1 then
 308     FMemo.SelLength := Length(FStr);
 309   if FTop = true then
 310   begin
 311     FMemo.SelLength := Length(FStr);
 312     FMemo.SelStart := FPos;
 313   end
 314   else
 315   begin
 316     FMemo.SelLength := Length(FStr);
 317     FMemo.SelStart := FPos + Length(FStr);
 318   end;
 319 end;
 320
 321 procedure TUnDelete.ReDo;
 322 begin
 323   if FMemo <> nil then
 324   begin
 325     FMemo.SelStart := FPos;
 326     FMemo.SelLength := Length(FStr);
 327     FMemo.SelText := '';
 328   end;
 329 end;
 330
 331 { TUnPaste }
 332
 333 procedure TUnPaste.Execute;
 334 begin
 335   if FMemo <> nil then
 336   begin
 337     FMemo.SelStart := FPos;
 338     FMemo.SelLength := FLen;
 339     FMemo.SelText := '';
 340   end;
 341 end;
 342
 343 procedure TUnPaste.ReDo;
 344 begin
 345   if FMemo <> nil then
 346   begin
 347     FMemo.SelStart := FPos;
 348     FMemo.SelText := FStr;
 349     FMemo.SelLength := FLen;
 350     FMemo.SelStart := FPos + FLen;
 351   end;
 352 end;
 353
 354 { TUnInput }
 355
 356 procedure TUnInput.Execute;
 357 begin
 358   if FMemo <> nil then
 359   begin
 360     FMemo.SelStart := FPos;
 361     FMemo.SelText := '';
 362   end;
 363 end;
 364
 365 procedure TUnInput.ReDo;
 366 begin
 367
 368 end;
 369
 370 { TUnRETURN }
 371
 372 procedure TUnRETURN.Execute;
 373 var
 374   i: integer;
 375 begin
 376   if FMemo <> nil then
 377   begin
 378     FMemo.SelStart := FPos;
 379     i := FMemo.CaretPos.Y;
 380     FMemo.Lines[i] := FMemo.Lines[i] + FMemo.Lines[i + 1];
 381     FMemo.Lines.Delete(i + 1);
 382     FMemo.SelStart := FPos;
 383   end;
 384 end;
 385
 386 procedure TUnRETURN.ReDo;
 387 begin
 388   if FMemo <> nil then
 389   begin
 390     FMemo.SelStart := FPos;
 391     FMemo.SelText := #13#10;
 392   end;
 393 end;
 394
 395 end.