;;; Common Lisp Generic Sequence ;;; LSEQ (Locator Sequence) data structure definition ;;; ;;; Copyright (C) 2003 Robert Strandh (strandh@labri.fr) ;;; Copyright (C) 2003 Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation; either ;;; version 2.1 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public ;;; License along with this library; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (in-package :gseq) (defclass lseq (gseq) () (:documentation "The protocol class for locator sequences.")) (defclass locator () () (:documentation "The protocol class for locators.")) (define-condition at-beginning-error (gseq-error) ((locator :reader at-beginning-error-locator :initarg :locator :initform nil)) (:report (lambda (condition stream) (let ((locator (at-end-error-locator condition))) (format stream "Locator ~A already at the beginning of ~A" locator (locator-lseq locator)))))) (define-condition at-end-error (gseq-error) ((locator :reader at-end-error-locator :initarg :locator :initform nil)) (:report (lambda (condition stream) (let ((locator (at-end-error-locator condition))) (format stream "Locator ~A already at the end of ~A" locator (locator-lseq locator)))))) (defgeneric clone-locator (locator) (:documentation "Create a locator that is initially at the same location as the one given as argument.")) (defgeneric locator-position (locator) (:documentation "Return the position of the locator.")) (defgeneric at-beginning-p (locator) (:documentation "Return true if the locator is at the beginning of the LSEQ.")) (defgeneric at-end-p (locator) (:documentation "Return true if the locator is at the beginning of the LSEQ.")) (defgeneric forward (locator &optional n) (:documentation "Move the locator forward N positions.")) (defgeneric backward (locator &optional n) (:documentation "Move the locator backward N positions.")) (defgeneric insert-element (object locator) (:documentation "Insert an object after the locator then advance the locator by one position.")) (defgeneric insert-sequence (sequence locator) (:documentation "The effect is the same as if each element of the sequence was inserted using INSERT-ELEMENT.")) (defgeneric delete-element (locator &optional n) (:documentation "Delete N objects after the locator.")) (defgeneric erase-element (locator &optional n) (:documentation "Delete N objects before the locator.")) (defgeneric element-at (locator) (:documentation "Return the element immediately after the locator.")) (defgeneric (setf element-at) (element locator) (:documentation "Replace the element immediately after the locator.")) (defclass standard-lseq (lseq standard-gseq) ((locators :accessor lseq-locators :initform '())) (:documentation "The standard instantiable subclass of LSEQ")) (defclass standard-locator (locator) ((lseq :reader locator-lseq :initarg :lseq) (index :accessor locator-index :initarg :index)) (:documentation "The standard instantiable subclass of LOCATOR")) (defmethod initialize-instance :after ((locator standard-locator) &rest initargs) (declare (ignore initargs)) (with-slots (lseq) locator (push (make-weak-pointer locator) (lseq-locators lseq))) locator) (defmethod clone-locator ((locator standard-locator)) (make-instance 'standard-locator :lseq (locator-lseq locator) :index (locator-index locator))) (defmethod locator-position ((locator standard-locator)) (index-position (locator-lseq locator) (locator-index locator))) (defmethod at-beginning-p ((locator standard-locator)) (zerop (locator-position locator))) (defmethod at-end-p ((locator standard-locator)) (= (locator-position locator) (gseq-length (locator-lseq locator)))) (defmethod forward ((locator standard-locator) &optional (n 1)) (assert (<= (locator-position locator) (- (gseq-length (locator-lseq locator)) n)) () 'at-end-error :locator locator) (format t "forwarding ~A~%" locator) (with-slots (lseq index) locator (setf index (position-index lseq (+ (index-position lseq index) n))))) (defmethod backward ((locator standard-locator) &optional (n 1)) (assert (>= (locator-position locator) n) () 'at-beginning-error :locator locator) (with-slots (lseq index) locator (setf index (position-index lseq (- (index-position lseq index) n))))) (defmethod insert-element (object (locator standard-locator)) (with-slots (lseq) locator (let ((position (locator-position locator))) (loop for locator2-wp in (lseq-locators lseq) as locator2 = (weak-pointer-value locator2-wp) do (when (> (locator-position locator2) position) (forward locator2))) (gseq-insert lseq object position) (forward locator)))) (defmethod insert-sequence (sequence (locator standard-locator)) ;; Could be optimized to call FORWARD only once per locator (map nil (lambda (object) (insert-element object locator)) sequence)) (defmethod delete-element ((locator standard-locator) &optional (n 1)) (with-slots (lseq) locator (let ((position (if (at-end-p locator) (gseq-length lseq) (1+ (locator-position locator))))) (loop for locator2-wp in (lseq-locators lseq) as locator2 = (weak-pointer-value locator2-wp) do (let ((distance (- (locator-position locator2) position))) (when (plusp distance) (backward locator2 (min distance n))))) (loop repeat n do (gseq-delete lseq position))))) (defmethod erase-element ((locator standard-locator) &optional (n 1)) (loop repeat n do (progn (backward locator) (delete-element locator)))) (defmethod element-at ((locator standard-locator)) (assert (not (at-end-p locator)) () 'at-end-error :locator locator) (gseq-element (locator-lseq locator) (1+ (locator-position locator)))) (defmethod (setf element-at) (element (locator standard-locator)) (assert (not (at-end-p locator)) () 'at-end-error :locator locator) (setf (gseq-element (locator-lseq locator) (1+ (locator-position locator))) element))