undo.lisp

   1 ;;; This file contains undo functionality for GSharp based on code
   2 ;;; contained in mcclim's Drei editor substrate. Drei code keeps track
   3 ;;; of the `undo tree', but several changes were needed in GSharp to
   4 ;;; support this:
   5 ;;;    *  BUFFER is now a DREI::UNDO-MIXIN
   6 ;;;    *  EXECUTE-FRAME-COMMAND has an around method calling WITH-UNDO
   7 ;;;
   8 ;;; And in this file, each `atomic' operation in GSHARP is given:
   9 ;;;    *  a subclass of DREI-UNDO-RECORD
  10 ;;;    *  a meaningful PRINT-OBJECT method
  11 ;;;    *  an inverse method FLIP-UNDO-RECORD
  12 ;;;
  13 ;;; Each operation's function or method is also altered to accomodate
  14 ;;; undo recording.
  15
  16 (in-package :gsharp)
  17
  18 ;; General utils first
  19 (defgeneric element-children (element)
  20   (:method ((c cluster)) (notes c))
  21   (:documentation  "Return the notes of a cluster or the elements of a ligature"))
  22 (defmethod (setf element-children) (children (cluster cluster))
  23   (setf (notes cluster) children))
  24 (defun insert-element-sequence (bar pos sequence)
  25   "Inserts elements of SEQUENCE in order into the given BAR at POS"
  26   (let ((cursor (make-cursor bar pos)))
  27     (dolist (object sequence)
  28       (cond
  29         ((typep object 'bar)
  30          (insert-bar-after
  31           (make-instance (class-of object))
  32           cursor))
  33         (t (insert-element object cursor)
  34            (forward-element cursor))))))
  35 (defun element-sequence (bar pos length)
  36   "Equivalent of SUBSEQ for elements in a layer."
  37   (let ((cursor (make-cursor bar pos)))
  38     (loop for i from 0 below length
  39        collect (if (end-of-bar-p cursor)
  40                    (bar cursor)
  41                    (progn
  42                      (forward-element cursor)
  43                      (current-element cursor))))))
  44 (defun delete-element-range (bar pos length)
  45   "Deletes LENGTH elements at BAR/POS"
  46   (let ((cursor (make-cursor bar pos)))
  47     (dotimes (i length)
  48       (delete-element cursor))))
  49 (defun insert-subobject-sequence (objects sequence offset)
  50   "Inserts OBJECTS into SEQUENCE at OFFSET.
  51 e.g. (INSERT-SUBOBJECT-SEQUENCE '(A B) '(1 2 3 4 5) 2) => (1 2 A B 3 4 5)"
  52   (let ((tail (nthcdr offset sequence))
  53         (objects (copy-seq objects)))
  54     (setf (cdr (nthcdr (1- offset) sequence)) objects
  55           (cdr (last objects)) tail)))
  56 (defun delete-child-sequence (sequence offset length)
  57   "Deletes LENGTH elements from SEQUENCE starting at OFFSET."
  58   (let ((tail (nthcdr (+ offset length) sequence)))
  59     (setf (cdr (nthcdr (1- offset) sequence)) tail)
  60     sequence))
  61
  62 ;; A key difference between undo in the text and score worlds is that
  63 ;; offset is not enough in the latter case, since we no longer have
  64 ;; linear data. There are several obvious ways to try it:
  65 ;;
  66 ;; * A GSHARP-CURSOR is an obvious alternative, but information is
  67 ;; lost when cursors bunch up after a series of deletes and cannot be
  68 ;; recovered. e.g.
  69 ;;  step 1: Insert C (elements: C)
  70 ;;  step 2: Insert D (elements: C-D)
  71 ;;  step 3: Delete D (elements: C)
  72 ;;  step 4: Delete C (elements: -)
  73 ;;  step 5: Undo (elements C)
  74 ;;  step 6: Undo (elements D-C) <--- Cursor for D undo is at 0 pos
  75 ;;
  76 ;; * Keeping track of BAR and POSITION without the cursor structure is
  77 ;; fine until a barline is deleted, at which point, BAR may no longer
  78 ;; exist, and POSITION may point to the wrong place
  79 ;;
  80 ;; * We know that if actions are properly controlled, the state
  81 ;; immediately before and after undo is known at the time of
  82 ;; UNDO-RECORD creation, so we can get the position by BAR-NO/POSITION
  83 ;; co-ordinates.
  84 ;;
  85 ;; * Neighbouring elements should be predictable. Perhaps we could store
  86 ;; these.
  87 ;;
  88 ;; Having tried the first two and found the problems quite quickly,
  89 ;; I'm now trying the third.
  90 ;;
  91 ;; Notes within elements are easy, since we just use the element.
  92
  93 (defclass gsharp-undo-record (drei::drei-undo-record)
  94   ())
  95 (defclass gsharp-element-undo-record (gsharp-undo-record)
  96   ((slice :initarg :slice :reader slice)
  97    (bar-number :initarg :bar :reader undo-bar)
  98    (pos :initarg :pos :reader undo-pos))
  99   (:documentation "Generated by an action that adds or removes
 100   ELEMENTs. Identifying the location of changes is not always
 101   easy. Here it is achieved by a combination of SLICE, BAR-NUMBER,
 102   POS. Note that BAR cannot be used, since its identity may
 103   change. SLICE is assumed not to do so. Otherwise, that too will need
 104   to be indicated numerically."))
 105 (defclass gsharp-child-undo-record (gsharp-undo-record)
 106   ((element :initarg :element :reader undo-element)
 107    (offset :initarg :offset :reader undo-offset))
 108   (:documentation "Generated by an action that adds or removes
 109   NOTEs. The parent ELEMENT is stored directly, whilst an OFFSET
 110   indicates where the change occured."))
 111 (defclass gsharp-specific-thing-undo-record (gsharp-undo-record)
 112   ((thing :initarg :thing :reader undo-thing))
 113   (:documentation "Generated by an action that changes an object, but
 114   doesn't change its identity. This makes life easier, since undo
 115   operations can be can be carried out directly on the object."))
 116
 117 (defclass gsharp-bar-record (gsharp-undo-record)
 118   ((bar-number :initarg :bar :reader undo-bar)
 119    (slice :initarg :slice :reader slice)))
 120 (defclass gsharp-bar-insert-record (gsharp-bar-record)
 121   ((class :initarg :class :reader undo-bar-class)
 122    (barline :initarg :barline :reader undo-barline)))
 123 (defclass gsharp-bar-delete-record (gsharp-bar-record)
 124   ())
 125
 126 (defclass insert-mixin ()
 127   ((objects :initarg :objects :reader undo-objects)))
 128 (defclass gsharp-element-insert-record (insert-mixin gsharp-element-undo-record)
 129   ())
 130 (defclass gsharp-child-insert-record (insert-mixin gsharp-child-undo-record)
 131   ())
 132 (defclass delete-mixin ()
 133   ((length :initarg :length :reader undo-length)))
 134 (defclass gsharp-element-delete-record (delete-mixin gsharp-element-undo-record)
 135   ())
 136 (defclass gsharp-child-delete-record (delete-mixin gsharp-child-undo-record)
 137   ())
 138 (defclass change-mixin ()
 139   ((objects :initarg :objects :reader undo-objects)))
 140 (defclass gsharp-element-change-record (change-mixin gsharp-element-undo-record)
 141   ())
 142 (defclass gsharp-child-change-record (change-mixin gsharp-child-undo-record)
 143   ())
 144 (defclass gsharp-slot-change-record (gsharp-specific-thing-undo-record)
 145   ((slot-changes :initarg :changes :accessor undo-slot-changes)))
 146
 147 (defmethod drei-undo::flip-undo-record ((record gsharp-element-insert-record))
 148   (with-slots (slice bar-number pos) record
 149     (let ((bar (barno slice bar-number))
 150           (objects (slot-value record 'objects)))
 151       (change-class record 'gsharp-element-delete-record
 152                     :length (length objects))
 153       (insert-element-sequence bar pos objects))))
 154 (defmethod drei-undo::flip-undo-record ((record gsharp-element-delete-record))
 155   (with-slots (slice bar-number pos) record
 156     (let ((bar (barno slice bar-number))
 157           (length (undo-length record)))
 158       (change-class record 'gsharp-element-insert-record
 159                     :objects (element-sequence bar pos length))
 160       (delete-element-range bar pos length))))
 161 ;; FIXME::I'll add this when I make an op that needs it
 162 #+nil
 163 (defmethod drei-undo::flip-undo-record ((record gsharp-element-change-record)))
 164 (defmethod drei-undo::flip-undo-record ((record gsharp-child-insert-record))
 165   (with-slots (element offset) record
 166     (let ((objects (slot-value record 'objects)))
 167       (change-class record 'gsharp-child-delete-record
 168                     :length (length objects))
 169       (if (= offset 0)
 170           (setf (element-children element) objects)
 171           (insert-subobject-sequence objects (element-children element) offset)))))
 172 (defmethod drei-undo::flip-undo-record ((record gsharp-child-delete-record))
 173   (with-slots (element offset) record
 174     (let ((length (slot-value record 'length)))
 175       (change-class record 'gsharp-child-insert-record
 176                     :objects (subseq (element-children element)
 177                                      offset (+ length offset)))
 178       (if (= offset 0)
 179           (setf (element-children element) (subseq (element-children element) length))
 180           (delete-child-sequence (element-children element) offset length)))))
 181 ;; FIXME::I'll add this when I make an op that needs it
 182 #+nil
 183 (defmethod drei-undo::flip-undo-record ((record gsharp-child-change-record)))
 184 (defmethod drei-undo::flip-undo-record ((record gsharp-slot-change-record))
 185   (with-slots (thing slot-changes) record
 186     (loop for change in slot-changes
 187        do (rotatef (cdr change) (slot-value thing (car change))))))
 188
 189 (defmethod drei-undo::flip-undo-record ((record gsharp-bar-insert-record))
 190   (let* ((type (undo-bar-class record))
 191          (pos (undo-bar record))
 192          (slice (slice record))
 193          (bar (barno slice pos)))
 194     (change-class record 'gsharp-bar-delete-record)
 195     (insert-bar-after (make-instance type)
 196                       (make-cursor bar (length (elements bar))))))
 197 (defmethod drei-undo::flip-undo-record ((record gsharp-bar-delete-record))
 198   (let* ((slice (slice record))
 199          (pos (undo-bar record))
 200          (bar1 (barno slice pos))
 201          (bar2 (barno slice (1+ pos)))
 202          (cursor (make-cursor bar1 (length (elements bar1)))))
 203     (change-class record 'gsharp-bar-insert-record
 204                   :class (class-of bar2))
 205     (fuse-bar-with-next cursor)))
 206
 207 (defmethod add-element :before (element bar position)
 208   (let* ((slice (slice bar))
 209          (buffer (buffer (segment (layer slice)))))
 210     (unless (drei:performing-undo buffer)
 211       (push (make-instance 'gsharp-element-delete-record
 212                            :length 1
 213                            :bar (number bar) :pos position
 214                            :slice slice :buffer buffer)
 215             (drei:undo-accumulate buffer)))))
 216
 217 (defmethod add-note :before (cluster note)
 218   (let* ((buffer (buffer (segment (layer (slice (bar cluster)))))))
 219     (unless (drei:performing-undo buffer)
 220       (push (make-instance 'gsharp-child-delete-record
 221                            :length 1 :element cluster
 222                            :offset (length (notes cluster))
 223                            :buffer buffer)
 224             (drei:undo-accumulate buffer)))))
 225
 226 (defmethod delete-element :before (cursor)
 227   (with-slots (bar (pos gsharp-cursor::pos)) cursor
 228     (let ((slice (slice (bar cursor)))
 229           (buffer (buffer cursor))
 230           (bar-num (number bar)))
 231       (unless (drei:performing-undo buffer)
 232         (push (if (end-of-bar-p cursor)
 233                   (let ((bar-to-delete (barno slice (1+ bar-num))))
 234                     (make-instance 'gsharp-bar-insert-record
 235                                    :class (class-of bar-to-delete)
 236                                    :slice slice :buffer buffer
 237                                    :bar bar-num))
 238                   (make-instance 'gsharp-element-insert-record
 239                                  :objects (list (elementno bar pos))
 240                                  :bar bar-num :pos pos
 241                                  :slice slice :buffer buffer))
 242               (drei:undo-accumulate buffer))))))
 243
 244 (defmethod insert-bar-after :before (bar cursor)
 245   (let ((buffer (buffer cursor)))
 246     (unless (drei:performing-undo buffer)
 247       (push (make-instance 'gsharp-bar-delete-record
 248                            :slice (slice cursor)
 249                            :bar (number (bar cursor))
 250                            :buffer buffer)
 251             (drei:undo-accumulate buffer)))))
 252
 253 (defmethod buffer ((cluster cluster))
 254   (buffer (segment (layer (slice (bar cluster))))))
 255 (defmethod buffer ((note note))
 256   (buffer (segment (layer (slice (bar (cluster note)))))))
 257
 258 (macrolet ((slot-setf-undo (method-name &key element-specializer value
 259                                         buffer-method slot)
 260              (let ((accessor (if value
 261                                  `(funcall ,value 'object)
 262                                  `(slot-value object ',method-name)))
 263                    (l-list (if element-specializer
 264                                `(object ,element-specializer)
 265                                'object))
 266                    (buf (if buffer-method
 267                             `(funcall ,buffer-method object)
 268                             `(buffer object))))
 269                (unless slot
 270                  (setf slot method-name))
 271                `(defmethod (setf ,method-name) :before (val ,l-list)
 272                   (let ((buffer ,buf))
 273                     (unless (drei:performing-undo buffer)
 274                       (push (make-instance 'gsharp-slot-change-record
 275                                            :changes (list (cons ',slot
 276                                                                 ,accessor))
 277                                            :thing object
 278                                            :buffer buffer)
 279                             (drei:undo-accumulate buffer))))))))
 280   (slot-setf-undo gsharp-buffer::staff-pos)
 281   (slot-setf-undo gsharp-buffer::notehead :element-specializer element)
 282   (slot-setf-undo gsharp-buffer::rbeams :element-specializer element)
 283   (slot-setf-undo gsharp-buffer::lbeams :element-specializer element)
 284
 285   (slot-setf-undo stem-direction
 286                   :element-specializer cluster
 287                   :value 'stem-direction)
 288
 289   (slot-setf-undo gsharp-buffer::dots)
 290
 291   (slot-setf-undo gsharp-buffer::set-contents :element-specializer cluster
 292                   :value #'(lambda (x) (copy-seq (notes x))) :slot notes))