/[mcclim]/mcclim/Drei/undo.lisp
ViewVC logotype

Contents of /mcclim/Drei/undo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Dec 4 10:17:21 2006 UTC (7 years, 4 months ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, mcclim-0-9-4, HEAD
Changes since 1.2: +4 -0 lines
Explicitly define the generic functions of some accessor methods.
1 ;;; -*- Mode: Lisp; Package: DREI-UNDO -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; General-purpose undo module
22
23 (in-package :drei-undo)
24
25 (defgeneric add-undo (undo-record undo-tree)
26 (:documentation "Add an undo record to the undo tree below the
27 current state, and set the current state to be below the transition
28 represented by the undo record."))
29
30 (defgeneric flip-undo-record (undo-record)
31 (:documentation "This function is called by the undo module whenever
32 the current state is changed from its current value to that of the
33 parent state (presumably as a result of a call to undo) or to that of
34 one of its child states.
35
36 Client code is required to supply methods for this function on
37 client-specific subclasses of `undo-record'."))
38
39 (defgeneric undo (undo-tree &optional n)
40 (:documentation "Move the current state `n' steps up the undo
41 tree and call `flip-undo-record' on each step. If the current
42 state is at a level less than `n', a `no-more-undo' condition is
43 signaled and the current state is not moved (and no calls to
44 `flip-undo-record' are made).
45
46 As long as no new record are added to the tree, the undo module
47 remembers which branch it was in before a sequence of calls to undo."))
48
49 (defgeneric redo (undo-tree &optional n)
50 (:documentation "Move the current state `n' steps down the
51 remembered branch of the undo tree and call `flip-undo-record' on
52 each step. If the remembered branch is shorter than `n', a
53 `no-more-undo' condition is signaled and the current state is not
54 moved (and no calls to `flip-undo-record' are made)."))
55
56 (define-condition no-more-undo (simple-error)
57 ()
58 (:report (lambda (condition stream)
59 (declare (ignore condition))
60 (format stream "No more undo")))
61 (:documentation "A condition of this type is signaled whenever
62 an attempt is made to call undo when the application is in its
63 initial state."))
64
65 (defclass undo-tree () ()
66 (:documentation "The base class for all undo trees."))
67
68 (defclass standard-undo-tree (undo-tree)
69 ((current-record :accessor current-record)
70 (leaf-record :accessor leaf-record)
71 (redo-path :initform '() :accessor redo-path)
72 (children :initform '() :accessor children)
73 (depth :initform 0 :reader depth))
74 (:documentation "The base class for all undo records.
75
76 Client code typically derives subclasses of this class that are
77 specific to the application."))
78
79 (defmethod initialize-instance :after ((tree standard-undo-tree) &rest args)
80 (declare (ignore args))
81 (setf (current-record tree) tree
82 (leaf-record tree) tree))
83
84 (defclass undo-record () ()
85 (:documentation "The base class for all undo records."))
86
87 (defgeneric undo-tree (record)
88 (:documentation "The undo tree to which the undo record
89 `record' belongs."))
90
91 (defclass standard-undo-record (undo-record)
92 ((parent :initform nil :accessor parent)
93 (tree :initform nil
94 :accessor undo-tree
95 :documentation "The undo tree to which the undo record
96 belongs.")
97 (children :initform '() :accessor children)
98 (depth :initform nil :accessor depth))
99 (:documentation "Standard instantiable class for undo records."))
100
101 (defmethod add-undo ((record standard-undo-record) (tree standard-undo-tree))
102 (push record (children (current-record tree)))
103 (setf (undo-tree record) tree
104 (parent record) (current-record tree)
105 (depth record) (1+ (depth (current-record tree)))
106 (current-record tree) record
107 (leaf-record tree) record
108 (redo-path tree) '()))
109
110 (defmethod undo ((tree standard-undo-tree) &optional (n 1))
111 (assert (<= n (depth (current-record tree)))
112 ()
113 (make-condition 'no-more-undo))
114 (loop repeat n
115 do (flip-undo-record (current-record tree))
116 (push (current-record tree) (redo-path tree))
117 (setf (current-record tree) (parent (current-record tree)))))
118
119 (defmethod redo ((tree standard-undo-tree) &optional (n 1))
120 (assert (<= n (- (depth (leaf-record tree))
121 (depth (current-record tree))))
122 ()
123 (make-condition 'no-more-undo))
124 (loop repeat n
125 do (setf (current-record tree) (pop (redo-path tree)))
126 (flip-undo-record (current-record tree))))

  ViewVC Help
Powered by ViewVC 1.1.5