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     function GetCanUndo: Boolean;
  56     procedure Clear;
  57     procedure DelRedoStack;
  58     procedure SetMemo(const Value: TCustomMemo);
  59     function GetCanRedo: Boolean;
  60   public
  61     constructor Create(AOwner: TComponent); override;
  62     procedure Deleted(const str: string; pos: integer; top: Boolean);
  63     procedure Inputted(c: Char; pos: integer);
  64     procedure Returned(pos: integer);
  65     procedure Pasted(const str: string; pos: integer);
  66     procedure Execute;
  67     procedure ReDo;
  68     destructor Destroy; override;
  69     procedure UpCount;
  70     procedure ResetCnt;
  71   published
  72     property Memo: TCustomMemo read FMemo write SetMemo;
  73     property CanUndo: Boolean read GetCanUndo;
  74     property CanRedo: Boolean read GetCanRedo;
  75   end;
  76
  77 implementation
  78
  79 { TUndoClass }
  80
  81 procedure TUndoClass.Clear;
  82 var
  83   i: integer;
  84 begin
  85   for i := 0 to FStack.Count - 1 do
  86     FStack.Pop.Free;
  87   for i := 0 to FReStack.Count - 1 do
  88     FReStack.Pop.Free;
  89 end;
  90
  91 constructor TUndoClass.Create(AOwner: TComponent);
  92 begin
  93   inherited;
  94   FStack := TObjectStack.Create;
  95   FReStack := TObjectStack.Create;
  96 end;
  97
  98 procedure TUndoClass.Deleted(const str: string; pos: integer; top: Boolean);
  99 var
 100   obj: TUnDelete;
 101 begin
 102   DelRedoStack;
 103   obj := TUnDelete.Create;
 104   obj.FStr := str;
 105   obj.FPos := pos;
 106   obj.FTop := top;
 107   obj.FMemo := FMemo;
 108   FStack.Push(obj);
 109 end;
 110
 111 procedure TUndoClass.DelRedoStack;
 112 var
 113   i: integer;
 114 begin
 115   if FReStack.Count > 0 then
 116     for i := 1 to FReStack.Count do
 117       FReStack.Pop.Free;
 118 end;
 119
 120 destructor TUndoClass.Destroy;
 121 begin
 122   Clear;
 123   FStack.Free;
 124   FReStack.Free;
 125   inherited;
 126 end;
 127
 128 procedure TUndoClass.Execute;
 129 var
 130   obj: TUndoBase;
 131 begin
 132   if FStack.Count > 0 then
 133   begin
 134     obj := FStack.Pop as TUndoBase;
 135     obj.Execute;
 136     FReStack.Push(obj);
 137   end;
 138 end;
 139
 140 function TUndoClass.GetCanRedo: Boolean;
 141 begin
 142   result:=FReStack.Count > 0;
 143 end;
 144
 145 function TUndoClass.GetCanUndo: Boolean;
 146 begin
 147   result := FStack.Count > 0;
 148 end;
 149
 150 procedure TUndoClass.Inputted(c: Char; pos: integer);
 151 var
 152   data: TUnPaste;
 153 begin
 154   DelRedoStack;
 155   if (FCnt > 0) and (FStack.Count > 0) and (FStack.Peek is TUnPaste) then
 156   begin
 157     data := FStack.Peek as TUnPaste;
 158     data.FLen := data.FLen + 1;
 159     data.FStr := data.FStr + c;
 160   end
 161   else
 162   begin
 163     data := TUnPaste.Create;
 164     data.FPos := pos;
 165     data.FLen := 1;
 166     data.FStr := c;
 167     data.FMemo := FMemo;
 168     FStack.Push(data);
 169   end;
 170 end;
 171
 172 procedure TUndoClass.Pasted(const str: string; pos: integer);
 173 var
 174   obj: TUnPaste;
 175 begin
 176   DelRedoStack;
 177   obj := TUnPaste.Create;
 178   obj.FPos := pos;
 179   obj.FLen := Length(str);
 180   obj.FMemo := FMemo;
 181   FStack.Push(obj);
 182 end;
 183
 184 procedure TUndoClass.ReDo;
 185 var
 186   obj: TUndoBase;
 187 begin
 188   if FReStack.Count > 0 then
 189   begin
 190     obj := FReStack.Pop as TUndoBase;
 191     obj.ReDo;
 192     FStack.Push(obj);
 193   end;
 194 end;
 195
 196 procedure TUndoClass.ResetCnt;
 197 begin
 198   FCnt := 0;
 199 end;
 200
 201 procedure TUndoClass.Returned(pos: integer);
 202 var
 203   obj: TUnRETURN;
 204 begin
 205   DelRedoStack;
 206   obj := TUnRETURN.Create;
 207   obj.FPos := pos;
 208   obj.FMemo := FMemo;
 209   FStack.Push(obj);
 210 end;
 211
 212 procedure TUndoClass.SetMemo(const Value: TCustomMemo);
 213 var
 214   obj: TUndoBase;
 215   i: integer;
 216   List: TList;
 217 begin
 218   FMemo := Value;
 219   List := TList.Create;
 220   for i := 1 to FStack.Count do
 221   begin
 222     obj := FStack.Pop as TUndoBase;
 223     obj.FMemo := Value;
 224     List.Add(obj);
 225   end;
 226   for i := List.Count - 1 downto 0 do
 227     FStack.Push(List[i]);
 228   List.Free;
 229 end;
 230
 231 procedure TUndoClass.UpCount;
 232 begin
 233   inc(FCnt);
 234   if FCnt > 5 then
 235     FCnt := 0;
 236 end;
 237
 238 { TUnDelete }
 239
 240 procedure TUnDelete.Execute;
 241 begin
 242   FMemo.SelStart := FPos;
 243   FMemo.SelText := FStr;
 244   FMemo.SelStart := FPos;
 245   if Length(FStr) > 1 then
 246     FMemo.SelLength := Length(FStr);
 247   if FTop = true then
 248   begin
 249     FMemo.SelLength := Length(FStr);
 250     FMemo.SelStart := FPos;
 251   end
 252   else
 253   begin
 254     FMemo.SelLength := Length(FStr);
 255     FMemo.SelStart := FPos + 1;
 256   end;
 257 end;
 258
 259 procedure TUnDelete.ReDo;
 260 begin
 261   if FMemo <> nil then
 262   begin
 263     FMemo.SelStart := FPos;
 264     FMemo.SelLength := Length(FStr);
 265     FMemo.SelText := '';
 266   end;
 267 end;
 268
 269 { TUnPaste }
 270
 271 procedure TUnPaste.Execute;
 272 begin
 273   if FMemo <> nil then
 274   begin
 275     FMemo.SelStart := FPos;
 276     FMemo.SelLength := FLen;
 277     FMemo.SelText := '';
 278   end;
 279 end;
 280
 281 procedure TUnPaste.ReDo;
 282 begin
 283   if FMemo <> nil then
 284   begin
 285     FMemo.SelStart := FPos;
 286     FMemo.SelText := FStr;
 287     FMemo.SelLength := FLen;
 288     FMemo.SelStart := FPos + FLen;
 289   end;
 290 end;
 291
 292 { TUnInput }
 293
 294 procedure TUnInput.Execute;
 295 begin
 296   if FMemo <> nil then
 297   begin
 298     FMemo.SelStart := FPos;
 299     FMemo.SelText := '';
 300   end;
 301 end;
 302
 303 procedure TUnInput.ReDo;
 304 begin
 305
 306 end;
 307
 308 { TUnRETURN }
 309
 310 procedure TUnRETURN.Execute;
 311 var
 312   i: integer;
 313 begin
 314   if FMemo <> nil then
 315   begin
 316     FMemo.SelStart := FPos;
 317     i := FMemo.CaretPos.Y;
 318     FMemo.Lines[i] := FMemo.Lines[i] + FMemo.Lines[i + 1];
 319     FMemo.Lines.Delete(i + 1);
 320     FMemo.SelStart := FPos;
 321   end;
 322 end;
 323
 324 procedure TUnRETURN.ReDo;
 325 begin
 326   if FMemo <> nil then
 327   begin
 328     FMemo.SelStart := FPos;
 329     FMemo.SelText := #13#10;
 330   end;
 331 end;
 332
 333 end.