Commit ee24caa7 authored by David Lewis's avatar David Lewis Committed by David Lewis
Browse files

Basic undo implemented for simple operations.

parent 84b7ea00

buffer.lisp

+1 −1
Changes for buffer.lisp: 1 added line, 1 removed line.
Original line number Diff line number Diff line
@@ -540,7 +540,7 @@ 
(defvar *default-left-offset* 30)

(defvar *default-left-margin* 20)



(defclass buffer (gsharp-object esa-buffer-mixin)

(defclass buffer (gsharp-object esa-buffer-mixin drei:undo-mixin)

  ((segments :initform '() :initarg :segments :accessor segments)

   (staves :initform (list (make-fiveline-staff))

           :initarg :staves :accessor staves)

gsharp.asd

+1 −0
Changes for gsharp.asd: 1 added line, 0 removed lines.
Original line number Diff line number Diff line
@@ -41,6 +41,7 @@ 
   "play"

   "clim-utils"

   "gui"

   "undo"

   "fontview"

   #+sbcl "Mxml/mxml"

   #+sbcl "Mxml/commands")

gui.lisp

+12 −1
Changes for gui.lisp: 12 added lines, 1 removed line.
Original line number Diff line number Diff line
@@ -210,7 +210,11 @@ 
  (cursor (view (car (windows *application-frame*)))))



(defmethod execute-frame-command :around ((frame gsharp) command)

  (handler-case (call-next-method)

  (handler-case 

      (let ((buffer (if (views frame)

                        (list (buffer (car (views frame)))))))

        (drei::with-undo (buffer)

          (call-next-method)))

    (gsharp-condition (condition) (beep) (display-message "~a" condition))))



(defmethod display-state ((frame gsharp) pane)
@@ -1813,3 +1817,10 @@ Prints the results in the minibuffer." 
    ()

  (unless (<= (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)

    (decf (gsharp-buffer::zoom-level (buffer (current-cursor))) 1/4)))



(define-command (com-undo :name t :command-table gsharp) ()

  (handler-case (drei::undo (drei::undo-tree (current-buffer)))

    (drei-undo:no-more-undo () (beep) (display-message "No more undo"))))

(define-command (com-redo :name t :command-table gsharp) ()

  (handler-case (drei::redo (drei::undo-tree (current-buffer)))

    (drei-undo:no-more-undo () (beep) (display-message "No more redo"))))

melody.lisp

+11 −5
Changes for melody.lisp: 11 added lines, 5 removed lines.
Original line number Diff line number Diff line
@@ -111,6 +111,11 @@ 
  #'read-fiveline-staff-v3

  *gsharp-readtable-v3*)



(defgeneric set-contents (element contents)

  (:documentation "Sets note in an element"))







;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;

;;; Note
@@ -446,13 +451,16 @@ flatter by removing some sharps and/or adding some flats")) 
     (declare (ignore condition))

     (format stream "Attempt to add a note already in a cluster"))))



(defmethod set-contents ((cluster cluster) contents)

  (setf (notes cluster) contents))



(defmethod add-note ((cluster cluster) (note note))

  (with-slots (notes) cluster

    (assert (not (find note notes :test #'note-equal))

            ()

            'note-already-in-cluster)

    (setf notes (merge 'list notes (list note) #'note-less)

          (cluster note) cluster)))

    (set-contents cluster (merge 'list notes (list note) #'note-less))

    (setf (cluster note) cluster)))



(defmethod find-note ((cluster cluster) (note note))

  (with-slots (notes) cluster
@@ -467,9 +475,7 @@ flatter by removing some sharps and/or adding some flats")) 
(defmethod remove-note ((note note))

  (with-slots (cluster) note

    (assert cluster () 'note-not-in-cluster)

    (with-slots (notes) cluster

      (setf notes (delete note notes :test #'eq)))

    (setf cluster nil)))

    (set-contents cluster (delete note (notes cluster) :test #'eq))))



(defun lower-bound (bound list &key (test #'<))

  "Return the `largest' element in the sorted list LIST such that

undo.lisp

0 → 100644
+292 −0
Changes for undo.lisp: 292 added lines, 0 removed lines.
Original line number Diff line number Diff line 
;;; This file contains undo functionality for GSharp based on code

;;; contained in mcclim's Drei editor substrate. Drei code keeps track

;;; of the `undo tree', but several changes were needed in GSharp to

;;; support this:

;;;    *  BUFFER is now a DREI::UNDO-MIXIN

;;;    *  EXECUTE-FRAME-COMMAND has an around method calling WITH-UNDO

;;;

;;; And in this file, each `atomic' operation in GSHARP is given:

;;;    *  a subclass of DREI-UNDO-RECORD

;;;    *  a meaningful PRINT-OBJECT method

;;;    *  an inverse method FLIP-UNDO-RECORD

;;;

;;; Each operation's function or method is also altered to accomodate

;;; undo recording.



(in-package :gsharp)



;; General utils first

(defgeneric element-children (element)

  (:method ((c cluster)) (notes c))

  (:documentation  "Return the notes of a cluster or the elements of a ligature"))

(defmethod (setf element-children) (children (cluster cluster))

  (setf (notes cluster) children))

(defun insert-element-sequence (bar pos sequence)

  "Inserts elements of SEQUENCE in order into the given BAR at POS"

  (let ((cursor (make-cursor bar pos)))

    (dolist (object sequence)

      (cond

        ((typep object 'bar)

         (insert-bar-after 

          (make-instance (class-of object))

          cursor))

        (t (insert-element object cursor)

           (forward-element cursor))))))

(defun element-sequence (bar pos length)

  "Equivalent of SUBSEQ for elements in a layer."

  (let ((cursor (make-cursor bar pos)))

    (loop for i from 0 below length

       collect (if (end-of-bar-p cursor)

                   (bar cursor)

                   (progn 

                     (forward-element cursor)

                     (current-element cursor))))))

(defun delete-element-range (bar pos length)

  "Deletes LENGTH elements at BAR/POS"

  (let ((cursor (make-cursor bar pos)))

    (dotimes (i length)

      (delete-element cursor))))

(defun insert-subobject-sequence (objects sequence offset)

  "Inserts OBJECTS into SEQUENCE at OFFSET.

e.g. (INSERT-SUBOBJECT-SEQUENCE '(A B) '(1 2 3 4 5) 2) => (1 2 A B 3 4 5)"

  (let ((tail (nthcdr offset sequence))

        (objects (copy-seq objects)))

    (setf (cdr (nthcdr (1- offset) sequence)) objects

          (cdr (last objects)) tail)))

(defun delete-child-sequence (sequence offset length)

  "Deletes LENGTH elements from SEQUENCE starting at OFFSET."

  (let ((tail (nthcdr (+ offset length) sequence)))

    (setf (cdr (nthcdr (1- offset) sequence)) tail)

    sequence))



;; A key difference between undo in the text and score worlds is that

;; offset is not enough in the latter case, since we no longer have

;; linear data. There are several obvious ways to try it:

;;

;; * A GSHARP-CURSOR is an obvious alternative, but information is

;; lost when cursors bunch up after a series of deletes and cannot be

;; recovered. e.g.

;;  step 1: Insert C (elements: C) 

;;  step 2: Insert D (elements: C-D)

;;  step 3: Delete D (elements: C)

;;  step 4: Delete C (elements: -)

;;  step 5: Undo (elements C)

;;  step 6: Undo (elements D-C) <--- Cursor for D undo is at 0 pos

;;

;; * Keeping track of BAR and POSITION without the cursor structure is

;; fine until a barline is deleted, at which point, BAR may no longer

;; exist, and POSITION may point to the wrong place

;;

;; * We know that if actions are properly controlled, the state

;; immediately before and after undo is known at the time of

;; UNDO-RECORD creation, so we can get the position by BAR-NO/POSITION

;; co-ordinates.

;; 

;; * Neighbouring elements should be predictable. Perhaps we could store

;; these.

;;

;; Having tried the first two and found the problems quite quickly,

;; I'm now trying the third.

;;

;; Notes within elements are easy, since we just use the element.



(defclass gsharp-undo-record (drei::drei-undo-record)

  ())

(defclass gsharp-element-undo-record (gsharp-undo-record)

  ((slice :initarg :slice :reader slice)

   (bar-number :initarg :bar :reader undo-bar)

   (pos :initarg :pos :reader undo-pos))

  (:documentation "Generated by an action that adds or removes

  ELEMENTs. Identifying the location of changes is not always

  easy. Here it is achieved by a combination of SLICE, BAR-NUMBER,

  POS. Note that BAR cannot be used, since its identity may

  change. SLICE is assumed not to do so. Otherwise, that too will need

  to be indicated numerically."))

(defclass gsharp-child-undo-record (gsharp-undo-record)

  ((element :initarg :element :reader undo-element)

   (offset :initarg :offset :reader undo-offset))

  (:documentation "Generated by an action that adds or removes

  NOTEs. The parent ELEMENT is stored directly, whilst an OFFSET

  indicates where the change occured."))

(defclass gsharp-specific-thing-undo-record (gsharp-undo-record)

  ((thing :initarg :thing :reader undo-thing))

  (:documentation "Generated by an action that changes an object, but

  doesn't change its identity. This makes life easier, since undo

  operations can be can be carried out directly on the object."))



(defclass gsharp-bar-record (gsharp-undo-record)

  ((bar-number :initarg :bar :reader undo-bar)

   (slice :initarg :slice :reader slice)))

(defclass gsharp-bar-insert-record (gsharp-bar-record)

  ((class :initarg :class :reader undo-bar-class)

   (barline :initarg :barline :reader undo-barline)))

(defclass gsharp-bar-delete-record (gsharp-bar-record)

  ())



(defclass insert-mixin ()

  ((objects :initarg :objects :reader undo-objects)))

(defclass gsharp-element-insert-record (insert-mixin gsharp-element-undo-record)

  ())

(defclass gsharp-child-insert-record (insert-mixin gsharp-child-undo-record)

  ())

(defclass delete-mixin ()

  ((length :initarg :length :reader undo-length)))

(defclass gsharp-element-delete-record (delete-mixin gsharp-element-undo-record)

  ())

(defclass gsharp-child-delete-record (delete-mixin gsharp-child-undo-record)

  ())

(defclass change-mixin ()

  ((objects :initarg :objects :reader undo-objects)))

(defclass gsharp-element-change-record (change-mixin gsharp-element-undo-record)

  ())

(defclass gsharp-child-change-record (change-mixin gsharp-child-undo-record)

  ())

(defclass gsharp-slot-change-record (gsharp-specific-thing-undo-record)

  ((slot-changes :initarg :changes :accessor undo-slot-changes)))



(defmethod drei-undo::flip-undo-record ((record gsharp-element-insert-record))

  (with-slots (slice bar-number pos) record

    (let ((bar (barno slice bar-number))

          (objects (slot-value record 'objects)))

      (change-class record 'gsharp-element-delete-record

                    :length (length objects))

      (insert-element-sequence bar pos objects))))

(defmethod drei-undo::flip-undo-record ((record gsharp-element-delete-record))

  (with-slots (slice bar-number pos) record

    (let ((bar (barno slice bar-number))

          (length (undo-length record)))

      (change-class record 'gsharp-element-insert-record

                    :objects (element-sequence bar pos length))

      (delete-element-range bar pos length))))

;; FIXME::I'll add this when I make an op that needs it

#+nil

(defmethod drei-undo::flip-undo-record ((record gsharp-element-change-record)))

(defmethod drei-undo::flip-undo-record ((record gsharp-child-insert-record))

  (with-slots (element offset) record

    (let ((objects (slot-value record 'objects)))

      (change-class record 'gsharp-child-delete-record

                    :length (length objects))

      (if (= offset 0)

          (setf (element-children element) objects)

          (insert-subobject-sequence objects (element-children element) offset)))))

(defmethod drei-undo::flip-undo-record ((record gsharp-child-delete-record))

  (with-slots (element offset) record

    (let ((length (slot-value record 'length)))

      (change-class record 'gsharp-child-insert-record

                    :objects (subseq (element-children element) 

                                     offset (+ length offset)))

      (if (= offset 0)

          (setf (element-children element) (subseq (element-children element) length))

          (delete-child-sequence (element-children element) offset length)))))

;; FIXME::I'll add this when I make an op that needs it

#+nil

(defmethod drei-undo::flip-undo-record ((record gsharp-child-change-record)))

(defmethod drei-undo::flip-undo-record ((record gsharp-slot-change-record))

  (with-slots (thing slot-changes) record

    (loop for change in slot-changes

       do (rotatef (cdr change) (slot-value thing (car change))))))



(defmethod drei-undo::flip-undo-record ((record gsharp-bar-insert-record))

  (let* ((type (undo-bar-class record))

         (pos (undo-bar record))

         (slice (slice record))

         (bar (barno slice pos)))

    (change-class record 'gsharp-bar-delete-record)

    (insert-bar-after (make-instance type)

                      (make-cursor bar (length (elements bar))))))

(defmethod drei-undo::flip-undo-record ((record gsharp-bar-delete-record))

  (let* ((slice (slice record))

         (pos (undo-bar record))

         (bar1 (barno slice pos))

         (bar2 (barno slice (1+ pos)))

         (cursor (make-cursor bar1 (length (elements bar1)))))

    (change-class record 'gsharp-bar-insert-record

                  :class (class-of bar2))

    (fuse-bar-with-next cursor)))



(defmethod add-element :before (element bar position)

  (let* ((slice (slice bar))

         (buffer (buffer (segment (layer slice)))))

    (unless (drei:performing-undo buffer)

      (push (make-instance 'gsharp-element-delete-record

                           :length 1

                           :bar (number bar) :pos position

                           :slice slice :buffer buffer)

            (drei:undo-accumulate buffer)))))



(defmethod add-note :before (cluster note)

  (let* ((buffer (buffer (segment (layer (slice (bar cluster)))))))

    (unless (drei:performing-undo buffer)

      (push (make-instance 'gsharp-child-delete-record

                           :length 1 :element cluster

                           :offset (length (notes cluster))

                           :buffer buffer)

            (drei:undo-accumulate buffer)))))



(defmethod delete-element :before (cursor)

  (with-slots (bar (pos gsharp-cursor::pos)) cursor

    (let ((slice (slice (bar cursor)))

          (buffer (buffer cursor))

          (bar-num (number bar)))

      (unless (drei:performing-undo buffer)

        (push (if (end-of-bar-p cursor)

                  (let ((bar-to-delete (barno slice (1+ bar-num))))

                    (make-instance 'gsharp-bar-insert-record

                                   :class (class-of bar-to-delete)

                                   :slice slice :buffer buffer

                                   :bar bar-num))

                  (make-instance 'gsharp-element-insert-record

                                 :objects (list (elementno bar pos))

                                 :bar bar-num :pos pos

                                 :slice slice :buffer buffer))

              (drei:undo-accumulate buffer))))))



(defmethod insert-bar-after :before (bar cursor)

  (let ((buffer (buffer cursor)))

    (unless (drei:performing-undo buffer)

      (push (make-instance 'gsharp-bar-delete-record 

                           :slice (slice cursor)

                           :bar (number (bar cursor))

                           :buffer buffer)

            (drei:undo-accumulate buffer)))))



(defmethod buffer ((cluster cluster))

  (buffer (segment (layer (slice (bar cluster))))))

(defmethod buffer ((note note))

  (buffer (segment (layer (slice (bar (cluster note)))))))



(macrolet ((slot-setf-undo (method-name &key element-specializer value

                                        buffer-method slot)

             (let ((accessor (if value

                                 `(funcall ,value 'object)

                                 `(slot-value object ',method-name)))

                   (l-list (if element-specializer

                               `(object ,element-specializer)

                               'object))

                   (buf (if buffer-method 

                            `(funcall ,buffer-method object)

                            `(buffer object))))

               (unless slot

                 (setf slot method-name))

               `(defmethod (setf ,method-name) :before (val ,l-list)

                  (let ((buffer ,buf))

                    (unless (drei:performing-undo buffer)

                      (push (make-instance 'gsharp-slot-change-record

                                           :changes (list (cons ',slot

                                                                ,accessor))

                                           :thing object

                                           :buffer buffer)

                            (drei:undo-accumulate buffer))))))))

  (slot-setf-undo gsharp-buffer::staff-pos)

  (slot-setf-undo gsharp-buffer::notehead :element-specializer element)

  (slot-setf-undo gsharp-buffer::rbeams :element-specializer element)

  (slot-setf-undo gsharp-buffer::lbeams :element-specializer element)

  

  (slot-setf-undo stem-direction

                  :element-specializer cluster

                  :value 'stem-direction)

  

  (slot-setf-undo gsharp-buffer::dots)

  

  (slot-setf-undo gsharp-buffer::set-contents :element-specializer cluster

                  :value #'(lambda (x) (copy-seq (notes x))) :slot notes))
 
 No newline at end of file