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