;;; Common Lisp Generic Sequence ;;; GSEQ (Generic Sequence) data structure definition ;;; ;;; Copyright (C) 2003-2004 Robert Strandh (strandh@labri.fr) ;;; Copyright (C) 2003-2004 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 gseq () ((element-type :initarg :element-type :initform t) (fill-element :initarg :fill-element) (expand-factor :initarg :expand-factor :initform 1.5) (min-size :initarg :min-size :initform 5)) (:documentation "The protocol class for generalized sequences.")) (defmethod initialize-instance :after ((gseq gseq) &rest initargs &key initial-contents) (declare (ignore initargs)) (with-slots (expand-factor min-size) gseq (assert (> expand-factor 1) () 'gseq-initialization-error :cause "EXPAND-FACTOR should be greater than 1.") (assert (> min-size 0) () 'gseq-initialization-error :cause "MIN-SIZE should be greater than 0.")) (if (slot-boundp gseq 'fill-element) (with-slots (element-type fill-element) gseq (assert (typep fill-element element-type) () 'gseq-initialization-error :cause (format nil "FILL-ELEMENT ~A not of type ~S." fill-element element-type))) (multiple-value-bind (element foundp) (find-if-2 (lambda (x) (typep x (slot-value gseq 'element-type))) '(nil 0 #\a)) (if foundp (setf (slot-value gseq 'fill-element) element) (error 'gseq-initialization-error :cause "FILL-ELEMENT not provided, no default applicable."))))) (define-condition gseq-error (simple-error) ()) (define-condition gseq-initialization-error (gseq-error) ((cause :reader gseq-initialization-error-cause :initarg :cause :initform "")) (:report (lambda (condition stream) (format stream "Error initializing GSEQ (~S)" (gseq-initialization-error-cause condition))))) (define-condition gseq-position-error (gseq-error) ((gseq :reader gseq-position-error-gseq :initarg :gseq :initform nil) (position :reader gseq-position-error-position :initarg :position :initform nil)) (:report (lambda (condition stream) (format stream "Position ~D out of bounds in ~A" (gseq-position-error-position condition) (gseq-position-error-gseq condition))))) (define-condition gseq-incompatible-type-error (gseq-error) ((gseq :reader gseq-incompatible-type-error-gseq :initarg :gseq :initform nil) (locator :reader gseq-incompatible-type-error-element :initarg :element :initform nil)) (:report (lambda (condition stream) (let ((element (gseq-incompatible-type-error-element condition))) (format stream "Element ~A of type ~A cannot be inserted in ~A" element (type-of element) (gseq-incompatible-type-error-gseq condition)))))) (defgeneric gseq-length (gseq) (:documentation "Returns the number of elements in the generalized sequence GSEQ.")) (defgeneric gseq-empty-p (gseq) (:documentation "Checks whether GSEQ is empty or not.")) (defgeneric gseq-insert (gseq element position) (:documentation "Inserts an element at POSITION of the generalized sequence. If POSITION is out of range (less than 0 or greater than the length of GSEQ, the GSEQ-POSITION condition will be signaled.")) (defgeneric gseq-delete (gseq position) (:documentation "Deletes an element at POSITION of the generalized sequence. If POSITION is out of range (less than 0 or greater than the length of GSEQ, the GSEQ-POSITION condition will be signaled.")) (defgeneric gseq-element (gseq position) (:documentation "Returns the element at POSITION of the generalized sequence. If POSITION is out of range (less than 0 or greater than the length of GSEQ, the GSEQ-POSITION condition will be signaled.")) (defgeneric (setf gseq-element) (element gseq position) (:documentation "Replaces the element at POSITION of GSEQ by ELEMENT. If POSITION if out of range (less than 0 or greater than the length of GSEQ, the GSEQ-POSITION condition will be signaled.")) (defclass standard-gseq (gseq) ((buffer) (gap-start) (gap-end) (nb-elements) (data-start)) (:documentation "The standard instantiable subclass of GSEQ.")) (defmethod initialize-instance :after ((gseq standard-gseq) &rest initargs &key initial-contents) (declare (ignore initargs)) ;; Check initial-contents if provided (unless (null initial-contents) (with-slots (element-type) gseq (multiple-value-bind (offending-element foundp) (find-if-2 (lambda (x) (not (typep x element-type))) initial-contents) (assert (not foundp) () 'gseq-initialization-error :cause (format nil "Initial element ~A not of type ~S." offending-element element-type))))) ;; Initialize slots (with-slots (element-type fill-element expand-factor min-size) gseq (setf (slot-value gseq 'buffer) (if (null initial-contents) (make-array min-size :element-type element-type :initial-element fill-element) (let ((size (length initial-contents))) (make-array size :element-type element-type :initial-contents initial-contents)))) (setf (slot-value gseq 'nb-elements) (length initial-contents) (slot-value gseq 'gap-start) 0 (slot-value gseq 'gap-end) 0 (slot-value gseq 'data-start) 0))) (defmethod gseq-length ((gseq standard-gseq)) (slot-value gseq 'nb-elements)) (defmethod gseq-empty-p ((gseq standard-gseq)) (zerop (gseq-length gseq))) (defmethod gseq-insert ((gseq standard-gseq) element position) (with-slots (buffer gap-start gap-end data-start nb-elements element-type) gseq (assert (typep element element-type) () 'gseq-incompatible-type-error :gseq gseq :element element) (gseq-move-gap gseq (position-index gseq position)) (let ((insert-index gap-start)) (when (= nb-elements (length buffer)) (increase-buffer-size gseq)) (setf (aref buffer insert-index) element)) (when (and (= position 0) (= data-start gap-end)) (setf data-start gap-start)) (incf gap-start) (incf nb-elements) (normalize-indices gseq))) (defmethod gseq-delete ((gseq standard-gseq) position) (with-slots (buffer fill-element nb-elements expand-factor gap-end data-start) gseq (assert (< position nb-elements) () 'gseq-position-error :gseq gseq :position position) (gseq-move-gap gseq (position-index gseq position)) (setf (aref buffer gap-end) fill-element) (when (= data-start gap-end) (incf data-start)) (incf gap-end) (decf nb-elements) (normalize-indices gseq) (when (< nb-elements (/ (length buffer) (square expand-factor))) (decrease-buffer-size gseq)))) (defmethod gseq-element ((gseq standard-gseq) position) (with-slots (nb-elements buffer) gseq (assert (<= 0 position (1- nb-elements)) () 'gseq-position-error :gseq gseq :position position) (let ((index (position-index gseq position))) (aref buffer index)))) (defmethod (setf gseq-element) (element (gseq standard-gseq) position) (with-slots (nb-elements buffer element-type) gseq (assert (<= 0 position (1- nb-elements)) () 'gseq-position-error :gseq gseq :position position) (assert (typep element element-type) 'gseq-incompatible-type-error :gseq gseq :element element) (let ((index (position-index gseq position))) (setf (aref buffer index) element)))) (defgeneric gseq-move-gap (gseq hot-spot) (:documentation "Moves the elements and gap inside the buffer so that the element currently at HOT-SPOT becomes the first element following the gap, or does nothing if there are no elements. Returns two values: the new limits of the gap.")) (defmethod gseq-move-gap ((gseq standard-gseq) hot-spot) (with-slots (gap-start gap-end) gseq (unless (= hot-spot gap-end) (case (gap-location gseq) (:gap-empty (move-empty-gap gseq hot-spot)) (:gap-left (move-left-gap gseq hot-spot)) (:gap-right (move-right-gap gseq hot-spot)) (:gap-middle (move-middle-gap gseq hot-spot)) (:gap-non-contiguous (move-non-contiguous-gap gseq hot-spot)))) (values gap-start gap-end))) (defun move-empty-gap (gseq hot-spot) "Moves the gap. Handles the case where the gap is empty." (with-slots (gap-start gap-end) gseq (setf gap-start hot-spot gap-end hot-spot))) (defun move-left-gap (gseq hot-spot) "Moves the gap. Handles the case where the gap is on the left of the buffer." (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (let ((buffer-size (length buffer))) (cond ((< (- hot-spot gap-end) (- buffer-size hot-spot)) (push-elements-left gseq (- hot-spot gap-end))) ((<= (- buffer-size hot-spot) gap-end) (hop-elements-left gseq (- buffer-size hot-spot))) (t (hop-elements-left gseq (- gap-end gap-start)) (push-elements-right gseq (- gap-start hot-spot))))))) (defun move-right-gap (gseq hot-spot) "Moves the gap. Handles the case where the gap is on the right of the buffer." (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (let ((buffer-size (length buffer))) (cond ((< (- gap-start hot-spot) (- buffer-size gap-start)) (push-elements-right gseq (- gap-start hot-spot))) ((<= hot-spot (- buffer-size gap-start)) (hop-elements-right gseq hot-spot)) (t (hop-elements-right gseq (- buffer-size gap-start)) (push-elements-left gseq (- hot-spot gap-end))))))) (defun move-middle-gap (gseq hot-spot) "Moves the gap. Handles the case where the gap is in the middle of the buffer." (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (let ((buffer-size (length buffer))) (cond ((< hot-spot gap-start) (cond ((<= (- gap-start hot-spot) (+ (- buffer-size gap-end) hot-spot)) (push-elements-right gseq (- gap-start hot-spot))) (t (push-elements-left gseq (- buffer-size gap-end)) (move-right-gap gseq hot-spot)))) (t (cond ((< (- hot-spot gap-end) (+ (- buffer-size hot-spot) gap-start)) (push-elements-left gseq (- hot-spot gap-end))) (t (push-elements-right gseq gap-start) (move-left-gap gseq hot-spot)))))))) (defun move-non-contiguous-gap (gseq hot-spot) "Moves the gap. Handles the case where the gap is in 2 parts, on both ends of the buffer." (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (let ((buffer-size (length buffer))) (cond ((< (- hot-spot gap-end) (- gap-start hot-spot)) (hop-elements-right gseq (min (- buffer-size gap-start) (- hot-spot gap-end))) (let ((nb-left (- hot-spot gap-end))) (unless (zerop nb-left) (push-elements-left gseq nb-left)))) (t (hop-elements-left gseq (min gap-end (- gap-start hot-spot))) (let ((nb-right (- gap-start hot-spot))) (unless (zerop nb-right) (push-elements-right gseq nb-right)))))))) (defun push-elements-left (gseq count) "Pushes the COUNT elements of GSEQ at the right of the gap, to the beginning of the gap. The gap must be continuous. Example: PUSH-ELEMENTS-LEFT abcd-----efghijklm 2 => abcdef-----ghijklm" (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (replace buffer buffer :start1 gap-start :start2 gap-end :end2 (+ gap-end count)) (fill buffer fill-element :start (max gap-end (+ gap-start count)) :end (+ gap-end count)) (when (<= gap-end data-start (1- (+ gap-end count))) (decf data-start (- gap-end gap-start))) (incf gap-start count) (incf gap-end count) (normalize-indices gseq))) (defun push-elements-right (gseq count) "Pushes the COUNT elements of GSEQ at the left of the gap, to the end of the gap. The gap must be continuous. Example: PUSH-ELEMENTS-RIGHT abcd-----efghijklm 2 => ab-----cdefghijklm" (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (let* ((buffer-size (length buffer)) (rotated-gap-end (if (zerop gap-end) buffer-size gap-end))) (replace buffer buffer :start1 (- rotated-gap-end count) :start2 (- gap-start count) :end2 gap-start) (fill buffer fill-element :start (- gap-start count) :end (min gap-start (- rotated-gap-end count))) (when (<= (- gap-start count) data-start gap-start) (incf data-start (- rotated-gap-end gap-start))) (decf gap-start count) (setf gap-end (- rotated-gap-end count)) (normalize-indices gseq)))) (defun hop-elements-left (gseq count) "Moves the COUNT rightmost elements to the end of the gap, on the left of the data. Example: HOP-ELEMENTS-LEFT ---abcdefghijklm--- 2 => -lmabcdefghijk-----" (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (let* ((buffer-size (length buffer)) (rotated-gap-start (if (zerop gap-start) buffer-size gap-start))) (replace buffer buffer :start1 (- gap-end count) :start2 (- rotated-gap-start count) :end2 rotated-gap-start) (fill buffer fill-element :start (- rotated-gap-start count) :end rotated-gap-start) (when (>= data-start (- rotated-gap-start count)) (decf data-start nb-elements)) (setf gap-start (- rotated-gap-start count)) (decf gap-end count) (normalize-indices gseq)))) (defun hop-elements-right (gseq count) "Moves the COUNT leftmost elements to the beginning of the gap, on the right of the data. Example: HOP-ELEMENTS-RIGHT ---abcdefghijklm--- 2 => -----cdefghijklmab-" (with-slots (buffer gap-start gap-end data-start nb-elements fill-element) gseq (replace buffer buffer :start1 gap-start :start2 gap-end :end2 (+ gap-end count)) (fill buffer fill-element :start gap-end :end (+ gap-end count)) (when (< data-start (+ gap-end count)) (incf data-start nb-elements)) (incf gap-start count) (incf gap-end count) (normalize-indices gseq))) (defun increase-buffer-size (gseq) (with-slots (buffer expand-factor) gseq (resize-buffer gseq (ceiling (* (length buffer) expand-factor))))) (defun decrease-buffer-size (gseq) (with-slots (buffer expand-factor) gseq (resize-buffer gseq (ceiling (/ (length buffer) expand-factor))))) (defun resize-buffer (gseq new-buffer-size) (with-slots (buffer gap-start gap-end data-start nb-elements fill-element element-type expand-factor) gseq (let ((buffer-size (length buffer)) (buffer-after (make-array new-buffer-size :element-type element-type :initial-element fill-element))) (case (gap-location gseq) ((:gap-empty :gap-middle) (replace buffer-after buffer :start1 0 :start2 0 :end2 gap-start) (let ((gap-end-after (- new-buffer-size (- buffer-size gap-end)))) (replace buffer-after buffer :start1 gap-end-after :start2 gap-end :end2 buffer-size) (when (>= data-start gap-end) (incf data-start (- gap-end-after gap-end))) (setf gap-end gap-end-after))) (:gap-right (replace buffer-after buffer :start1 0 :start2 0 :end2 gap-start)) (:gap-left (let ((gap-end-after (- new-buffer-size nb-elements))) (replace buffer-after buffer :start1 gap-end-after :start2 gap-end :end2 buffer-size) (incf data-start (- gap-end-after gap-end)) (setf gap-end gap-end-after))) (:gap-non-contiguous (replace buffer-after buffer :start1 0 :start2 gap-end :end2 gap-start) (decf data-start gap-end) (decf gap-start gap-end) (setf gap-end 0))) (setf buffer buffer-after))) (normalize-indices gseq)) (defun normalize-indices (gseq) "Sets gap limits to 0 if they are at the end of the buffer." (with-slots (buffer gap-start gap-end data-start) gseq (let ((buffer-size (length buffer))) (when (>= data-start buffer-size) (setf data-start 0)) (when (>= gap-start buffer-size) (setf gap-start 0)) (when (>= gap-end buffer-size) (setf gap-end 0))))) (defun gap-location (gseq) "Returns a keyword indicating the general location of the gap." (with-slots (buffer gap-start gap-end) gseq (cond ((= gap-start gap-end) :gap-empty) ((and (zerop gap-start) (>= gap-end 0)) :gap-left) ((and (zerop gap-end) (> gap-start 0)) :gap-right) ((> gap-end gap-start) :gap-middle) (t :gap-non-contiguous)))) (defun position-index (gseq position) "Returns the (0 indexed) index of the POSITION-th element of the GSEQ in the buffer." (with-slots (buffer data-start gap-start gap-end nb-elements) gseq (assert (<= 0 position nb-elements) () 'gseq-position-error :position position :gseq gseq) (if (= position nb-elements) data-start (let* ((index (+ position data-start)) (buffer-size (length buffer)) (s (if (>= gap-start data-start) gap-start (+ gap-start buffer-size)))) (when (>= index s) (let ((gap-size (- buffer-size nb-elements))) (incf index gap-size))) (when (>= index buffer-size) (decf index buffer-size)) index)))) (defun index-position (gseq index) "Returns the position corresponding to the INDEX in the GSEQ. Note: the result is undefined if INDEX is not the index of a valid element of the GSEQ." (with-slots (buffer data-start gap-start gap-end nb-elements) gseq (let ((position (- index data-start))) (when (and (< 0 gap-start gap-end) (or (<= data-start gap-start gap-end index) (<= index gap-start gap-end data-start))) (decf position (- gap-end gap-start))) (when (minusp position) (incf position nb-elements)) position)))