cl-flexichain-1.5.1.dfsg.1.orig/0000750000175000017500000000000011031403376014357 5ustar pdmpdmcl-flexichain-1.5.1.dfsg.1.orig/flexichain.asd0000640000175000017500000000321410765140200017160 0ustar pdmpdm;;; Flexichain ;;; ASDF system 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 ;; The tester is not included, for it depends on clim. The stupid ;; implementation has also been left out, since it seems mostly useful ;; for testing. (asdf:defsystem :flexichain :name "flexichain" :version #.(with-open-file (vers (merge-pathnames "version.lisp-expr" *load-truename*)) (read vers)) :components ((:static-file "version" :pathname #p"version.lisp-expr") (:file "flexichain-package") (:file "utilities" :depends-on ("flexichain-package")) (:file "flexichain" :depends-on ("utilities" "flexichain-package")) (:file "flexicursor" :depends-on ("flexichain")) (:file "flexirank" :depends-on ("flexichain")))) cl-flexichain-1.5.1.dfsg.1.orig/flexichain-doc.asd0000640000175000017500000000337710765006305017744 0ustar pdmpdm;;; flexichain-doc ;;; ASDF system definition ;;; ;;; Copyright (C) 2003-2004 Robert Strandh (strandh@labri.fr) ;;; Copyright (C) 2003-2004 Matthieu Villeneuve (matthieu.villeneuve@free.fr) ;;; Copyright (C) 2008 Cyrus Harmon (ch-lisp@bobobeach.com) ;;; ;;; 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 (asdf:defsystem :flexichain-doc :name "flexichain-doc" :version #.(with-open-file (vers (merge-pathnames "version.lisp-expr" *load-truename*)) (read vers)) :components ((:module "Doc" :components ((:static-file "Makefile") (:static-file flexichain-tex :pathname #p"flexichain.tex") (:static-file spec-macros-tex :pathname #p"spec-macros.tex") (:static-file circular-fig :pathname #p"circular.fig") (:static-file gap1-fig :pathname #p"gap1.fig") (:static-file gap2-fig :pathname #p"gap2.fig") (:static-file gap3-fig :pathname #p"gap3.fig") (:static-file "tex-dependencies") (:static-file "strip-dependence"))))) cl-flexichain-1.5.1.dfsg.1.orig/version.lisp-expr0000640000175000017500000000001010765145327017715 0ustar pdmpdm"1.5.1" cl-flexichain-1.5.1.dfsg.1.orig/flexichain-package.lisp0000640000175000017500000000355010747017271020767 0ustar pdmpdm;;; Flexichain ;;; Package 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 (defpackage :flexichain (:use :common-lisp) (:export #:flexichain #:standard-flexichain #:flexi-error #:flexi-initialization-error #:flexi-position-error #:flexi-incompatible-type-error #:nb-elements #:flexi-empty-p #:insert* #:insert-vector* #:element* #:delete* #:delete-elements* #:push-start #:pop-start #:push-end #:pop-end #:rotate #:cursorchain #:standard-cursorchain #:flexicursor #:standard-flexicursor #:left-sticky-flexicursor #:right-sticky-flexicursor #:chain #:clone-cursor #:cursor-pos #:at-beginning-error #:at-end-error #:at-beginning-p #:at-end-p #:move> #:move< #:insert #:insert-sequence #:element< #:element> #:delete< #:delete> #:flexirank-mixin #:element-rank-mixin #:rank #:flexi-first-p #:flexi-last-p #:flexi-next #:flexi-prev)) cl-flexichain-1.5.1.dfsg.1.orig/utilities.lisp0000640000175000017500000000611710515177172017301 0ustar pdmpdm;;; Flexichain ;;; Utility functions ;;; ;;; 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 :flexichain) (defun square (x) "Returns the square of the number X." (* x x)) (defun find-if-2 (predicate sequence) "Searches the sequence for an element that satisfies PREDICATE. Returns the element found or NIL of none was found, and a boolean indicating whether an element was found or not." (let ((position (position-if predicate sequence))) (if (null position) (values nil nil) (values (elt sequence position) t)))) ;;;; Weak pointers #+:openmcl (defvar *weak-pointers* (make-hash-table :test 'eq :weak :value) "Weak value hash-table mapping between pseudo weak pointers and its values.") #+:openmcl (defstruct (weak-pointer (:constructor %make-weak-pointer))) (defun make-weak-pointer (object) "Creates a new weak pointer which points to OBJECT. For portability reasons, OBJECT most not be NIL." (assert (not (null object))) #+:sbcl (sb-ext:make-weak-pointer object) #+:cmu (ext:make-weak-pointer object) #+:clisp (ext:make-weak-pointer object) #+:allegro (let ((wv (excl:weak-vector 1))) (setf (svref wv 0) object) wv) #+:openmcl (let ((wp (%make-weak-pointer))) (setf (gethash wp *weak-pointers*) object) wp) #+:corman (ccl:make-weak-pointer object) #+:lispworks (let ((array (make-array 1))) (hcl:set-array-weak array t) (setf (svref array 0) object) array) #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks) object) (defun weak-pointer-value (weak-pointer) "If WEAK-POINTER is valid, returns its value. Otherwise, returns NIL." #+:sbcl (prog1 (sb-ext:weak-pointer-value weak-pointer)) #+:cmu (prog1 (ext:weak-pointer-value weak-pointer)) #+:clisp (prog1 (ext:weak-pointer-value weak-pointer)) #+:allegro (svref weak-pointer 0) #+:openmcl (prog1 (gethash weak-pointer *weak-pointers*)) #+:corman (ccl:weak-pointer-obj weak-pointer) #+:lispworks (svref weak-pointer 0) #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks) weak-pointer) #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks) (eval-when (:compile-toplevel :load-toplevel :execute) (warn "No support for weak pointers in this implementation. ~ Things may get big and slow.")) cl-flexichain-1.5.1.dfsg.1.orig/flexichain.lisp0000640000175000017500000005775210750377216017415 0ustar pdmpdm;;; Flexichain ;;; Flexichain 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 :flexichain) (defclass flexichain () ((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 flexichains.")) (defmethod initialize-instance :after ((chain flexichain) &rest initargs &key initial-contents) (declare (ignore initargs initial-contents)) (with-slots (expand-factor min-size) chain (assert (> expand-factor 1) () 'flexichain-initialization-error :cause "EXPAND-FACTOR should be greater than 1.") (assert (> min-size 0) () 'flexichain-initialization-error :cause "MIN-SIZE should be greater than 0.")) (if (slot-boundp chain 'fill-element) (with-slots (element-type fill-element) chain (assert (typep fill-element element-type) () 'flexichain-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 chain 'element-type))) '(nil 0 #\a)) (if foundp (setf (slot-value chain 'fill-element) element) (error 'flexichain-initialization-error :cause "FILL-ELEMENT not provided, no default applicable."))))) (define-condition flexi-error (simple-error) ()) (define-condition flexi-initialization-error (flexi-error) ((cause :reader flexi-initialization-error-cause :initarg :cause :initform "")) (:report (lambda (condition stream) (format stream "Error initializing FLEXICHAIN (~S)" (flexi-initialization-error-cause condition))))) (define-condition flexi-position-error (flexi-error) ((chain :reader flexi-position-error-chain :initarg :chain :initform nil) (position :reader flexi-position-error-position :initarg :position :initform nil)) (:report (lambda (condition stream) (format stream "Position ~D out of bounds in ~A" (flexi-position-error-position condition) (flexi-position-error-chain condition))))) (define-condition flexi-incompatible-type-error (flexi-error) ((chain :reader flexi-incompatible-type-error-chain :initarg :chain :initform nil) (element :reader flexi-incompatible-type-error-element :initarg :element :initform nil)) (:report (lambda (condition stream) (let ((element (flexi-incompatible-type-error-element condition))) (format stream "Element ~A of type ~A cannot be inserted in ~A" element (type-of element) (flexi-incompatible-type-error-chain condition)))))) (defgeneric nb-elements (chain) (:documentation "Returns the number of elements in the flexichain.")) (defgeneric flexi-empty-p (chain) (:documentation "Checks whether CHAIN is empty or not.")) (defgeneric insert* (chain position object) (:documentation "Inserts an object before the element at POSITION in the chain. If POSITION is out of range (less than 0 or greater than the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled.")) (defgeneric insert-vector* (chain position vector) (:documentation "Inserts the elements of VECTOR before the element at POSITION in the chain. If POSITION is out of range (less than 0 or greater than the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled.")) (defgeneric delete* (chain position) (:documentation "Deletes an element at POSITION of the chain. If POSITION is out of range (less than 0 or greater than or equal to the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled.")) (defgeneric delete-elements* (chain position n) (:documentation "Delete N elements at POSITION of the chain. If POSITION+N is out of range (less than 0 or greater than or equal to the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled. N can be negative, in which case elements will be deleted before POSITION.")) (defgeneric element* (chain position) (:documentation "Returns the element at POSITION of the chain. If POSITION is out of range (less than 0 or greater than or equal to the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled.")) (defgeneric (setf element*) (object chain position) (:documentation "Replaces the element at POSITION of CHAIN by OBJECT. If POSITION if out of range (less than 0 or greater than or equal to the length of CHAIN, the FLEXI-POSITION-ERROR condition will be signaled.")) (defgeneric push-start (chain object) (:documentation "Inserts an object at the beginning of CHAIN.")) (defgeneric push-end (chain object) (:documentation "Inserts an object at the end of CHAIN.")) (defgeneric pop-start (chain) (:documentation "Pops and returns the element at the beginning of CHAIN.")) (defgeneric pop-end (chain) (:documentation "Pops and returns the element at the end of CHAIN.")) (defgeneric rotate (chain &optional n) (:documentation "Rotates the elements of CHAIN so that the element that used to be at position N is now at position 0. With a negative value of N, rotates the elements so that the element that used to be at position 0 is now at position N.")) (defclass standard-flexichain (flexichain) ((buffer) (gap-start) (gap-end) (data-start)) (:documentation "The standard instantiable subclass of FLEXICHAIN.")) (defun required-space (chain nb-elements) (with-slots (min-size expand-factor) chain (+ 2 (max (ceiling (* nb-elements expand-factor)) min-size)))) (defmethod initialize-instance :after ((chain standard-flexichain) &rest initargs &key initial-contents (initial-nb-elements 0) (initial-element nil)) (declare (ignore initargs)) ;; Check initial-contents if provided (unless (null initial-contents) (with-slots (element-type) chain (multiple-value-bind (offending-element foundp) (find-if-2 (lambda (x) (not (typep x element-type))) initial-contents) (assert (not foundp) () 'flexi-initialization-error :cause (format nil "Initial element ~A not of type ~S." offending-element element-type))))) ;; Initialize slots (with-slots (element-type fill-element buffer) chain (let* ((data-length (if (> (length initial-contents) initial-nb-elements) (length initial-contents) initial-nb-elements)) (size (required-space chain data-length)) (fill-size (- size data-length 2)) (sentinel-list (make-list 2 :initial-element fill-element)) (fill-list (make-list fill-size :initial-element fill-element))) (setf buffer (if initial-contents (make-array size :element-type element-type :initial-contents (concatenate 'list sentinel-list initial-contents fill-list)) (let ((arr (make-array size :element-type element-type :initial-element initial-element))) (fill arr fill-element :end (length sentinel-list)) (fill arr fill-element :start (+ (length sentinel-list) initial-nb-elements) :end size)))) (with-slots (gap-start gap-end data-start) chain (setf gap-start (+ 2 data-length) gap-end 0 data-start 1))))) (defmacro with-virtual-gap ((bl ds gs ge) chain &body body) (let ((c (gensym))) `(let* ((,c ,chain) (,bl (length (slot-value ,c 'buffer))) (,ds (slot-value ,c 'data-start)) (,gs (slot-value ,c 'gap-start)) (,ge (slot-value ,c 'gap-end))) (declare (ignorable ,bl ,ds ,gs ,ge)) (when (< ,gs ,ds) (incf ,gs ,bl)) (when (< ,ge ,ds) (incf ,ge ,bl)) ,@body))) (defmethod nb-elements ((chain standard-flexichain)) (with-virtual-gap (bl ds gs ge) chain (- bl (- ge gs) 2))) (defmethod flexi-empty-p ((chain standard-flexichain)) (zerop (nb-elements chain))) (defun position-index (chain position) "Returns the (0 indexed) index of the POSITION-th element of the CHAIN in the buffer." (with-virtual-gap (bl ds gs ge) chain (let ((index (+ ds position 1))) (when (>= index gs) (incf index (- ge gs))) (when (>= index bl) (decf index bl)) index))) (defun index-position (chain index) "Returns the position corresponding to the INDEX in the CHAIN. Note: the result is undefined if INDEX is not the index of a valid element of the CHAIN." (with-virtual-gap (bl ds gs ge) chain (when (< index ds) (incf index bl)) (when (>= index ge) (decf index (- ge gs))) (- index ds 1))) (defun ensure-gap-position (chain position) (move-gap chain (position-index chain position))) (defun ensure-room (chain nb-elements) (with-slots (buffer) chain (when (> nb-elements (- (length buffer) 2)) (increase-buffer-size chain nb-elements)))) (defmethod insert* ((chain standard-flexichain) position object) (with-slots (element-type buffer gap-start) chain (assert (<= 0 position (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (assert (typep object element-type) () 'flexi-incompatible-type-error :element object :chain chain) (ensure-gap-position chain position) (ensure-room chain (1+ (nb-elements chain))) (setf (aref buffer gap-start) object) (incf gap-start) (when (= gap-start (length buffer)) (setf gap-start 0)))) (defmethod insert-vector* ((chain standard-flexichain) position vector) (with-slots (element-type buffer gap-start) chain (assert (<= 0 position (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (assert (subtypep (array-element-type vector) element-type) () 'flexi-incompatible-type-error :element vector :chain chain) (ensure-gap-position chain position) (ensure-room chain (+ (nb-elements chain) (length vector))) (loop for elem across vector do (setf (aref buffer gap-start) elem) (incf gap-start) (when (= gap-start (length buffer)) (setf gap-start 0))))) (defmethod delete* ((chain standard-flexichain) position) (with-slots (buffer expand-factor min-size fill-element gap-end) chain (assert (< -1 position (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (ensure-gap-position chain position) (setf (aref buffer gap-end) fill-element) (incf gap-end) (when (= gap-end (length buffer)) (setf gap-end 0)) (when (and (> (length buffer) (+ min-size 2)) (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor)))) (decrease-buffer-size chain)))) (defmethod delete-elements* ((chain standard-flexichain) position n) (unless (zerop n) (with-slots (buffer expand-factor min-size gap-end data-start) chain (when (minusp n) (incf position n) (setf n (* -1 n))) (assert (<= 0 (+ position n) (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (ensure-gap-position chain position) ;; Two cases to consider - one where position+n is wholly on ;; this side of the gap in buffer, and one where part of it is ;; "wrapped around" to the beginning of buffer. (cond ((>= (length buffer) (+ gap-end n)) (fill-gap chain gap-end (+ gap-end n)) (incf gap-end n)) (t (let ((surplus-elements (- n (- (length buffer) gap-end)))) (fill-gap chain gap-end (length buffer)) (fill-gap chain 0 surplus-elements) (setf gap-end surplus-elements)))) (when (= gap-end (length buffer)) (setf gap-end 0)) (when (and (> (length buffer) (+ min-size 2)) (< (+ (nb-elements chain) 2) (/ (length buffer) (square expand-factor)))) (decrease-buffer-size chain))))) (defmethod element* ((chain standard-flexichain) position) (with-slots (buffer) chain (assert (< -1 position (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (aref buffer (position-index chain position)))) (defmethod (setf element*) (object (chain standard-flexichain) position) (with-slots (buffer element-type) chain (assert (< -1 position (nb-elements chain)) () 'flexi-position-error :chain chain :position position) (assert (typep object element-type) () 'flexi-incompatible-type-error :chain chain :element object) (setf (aref buffer (position-index chain position)) object))) (defmethod push-start ((chain standard-flexichain) object) (insert* chain 0 object)) (defmethod push-end ((chain standard-flexichain) object) (insert* chain (nb-elements chain) object)) (defmethod pop-start ((chain standard-flexichain)) (prog1 (element* chain 0) (delete* chain 0))) (defmethod pop-end ((chain standard-flexichain)) (let ((position (1- (nb-elements chain)))) (prog1 (element* chain position) (delete* chain position)))) (defmethod rotate ((chain standard-flexichain) &optional (n 1)) (when (> (nb-elements chain) 1) (cond ((plusp n) (loop repeat n do (push-start chain (pop-end chain)))) ((minusp n) (loop repeat (- n) do (push-end chain (pop-start chain)))) (t nil)))) (defun move-gap (chain hot-spot) "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." (with-slots (gap-start gap-end) chain (unless (= hot-spot gap-end) (case (gap-location chain) (:gap-empty (move-empty-gap chain hot-spot)) (:gap-left (move-left-gap chain hot-spot)) (:gap-right (move-right-gap chain hot-spot)) (:gap-middle (move-middle-gap chain hot-spot)) (:gap-non-contiguous (move-non-contiguous-gap chain hot-spot)))) (values gap-start gap-end))) (defun move-empty-gap (chain hot-spot) "Moves the gap. Handles the case where the gap is empty." (with-slots (gap-start gap-end) chain (setf gap-start hot-spot gap-end hot-spot))) (defun move-left-gap (chain 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) chain (let ((buffer-size (length buffer))) (cond ((< (- hot-spot gap-end) (- buffer-size hot-spot)) (push-elements-left chain (- hot-spot gap-end))) ((<= (- buffer-size hot-spot) gap-end) (hop-elements-left chain (- buffer-size hot-spot))) (t (hop-elements-left chain (- gap-end gap-start)) (push-elements-right chain (- gap-start hot-spot))))))) (defun move-right-gap (chain 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) chain (let ((buffer-size (length buffer))) (cond ((< (- gap-start hot-spot) hot-spot) (push-elements-right chain (- gap-start hot-spot))) ((<= hot-spot (- buffer-size gap-start)) (hop-elements-right chain hot-spot)) (t (hop-elements-right chain (- buffer-size gap-start)) (push-elements-left chain (- hot-spot gap-end))))))) (defun move-middle-gap (chain 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) chain (let ((buffer-size (length buffer))) (cond ((< hot-spot gap-start) (cond ((<= (- gap-start hot-spot) (+ (- buffer-size gap-end) hot-spot)) (push-elements-right chain (- gap-start hot-spot))) (t (push-elements-left chain (- buffer-size gap-end)) (move-right-gap chain hot-spot)))) (t (cond ((< (- hot-spot gap-end) (+ (- buffer-size hot-spot) gap-start)) (push-elements-left chain (- hot-spot gap-end))) (t (push-elements-right chain gap-start) (move-left-gap chain hot-spot)))))))) (defun move-non-contiguous-gap (chain 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) chain (let ((buffer-size (length buffer))) (cond ((< (- hot-spot gap-end) (- gap-start hot-spot)) (hop-elements-right chain (min (- buffer-size gap-start) (- hot-spot gap-end))) (let ((nb-left (- hot-spot gap-end))) (unless (zerop nb-left) (push-elements-left chain nb-left)))) (t (hop-elements-left chain (min gap-end (- gap-start hot-spot))) (let ((nb-right (- gap-start hot-spot))) (unless (zerop nb-right) (push-elements-right chain nb-right)))))))) (defgeneric move-elements (standard-flexichain to from start1 start2 end2) (:documentation "move elements of a flexichain and adjust data-start")) (defmethod move-elements ((fc standard-flexichain) to from start1 start2 end2) (replace to from :start1 start1 :start2 start2 :end2 end2) (with-slots (data-start) fc (when (and (<= start2 data-start) (< data-start end2)) (incf data-start (- start1 start2))))) (defgeneric fill-gap (standard-flexichain start end) (:documentation "fill part of gap with the fill element")) (defmethod fill-gap ((fc standard-flexichain) start end) (with-slots (buffer fill-element) fc (fill buffer fill-element :start start :end end))) (defun push-elements-left (chain count) "Pushes the COUNT elements of CHAIN 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) chain (move-elements chain buffer buffer gap-start gap-end (+ gap-end count)) (fill-gap chain (max gap-end (+ gap-start count)) (+ gap-end count)) (incf gap-start count) (incf gap-end count) (normalize-indices chain))) (defun push-elements-right (chain count) "Pushes the COUNT elements of CHAIN 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) chain (let* ((buffer-size (length buffer)) (rotated-gap-end (if (zerop gap-end) buffer-size gap-end))) (move-elements chain buffer buffer (- rotated-gap-end count) (- gap-start count) gap-start) (fill-gap chain (- gap-start count) (min gap-start (- rotated-gap-end count))) (decf gap-start count) (setf gap-end (- rotated-gap-end count)) (normalize-indices chain)))) (defun hop-elements-left (chain 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) chain (let* ((buffer-size (length buffer)) (rotated-gap-start (if (zerop gap-start) buffer-size gap-start))) (move-elements chain buffer buffer (- gap-end count) (- rotated-gap-start count) rotated-gap-start) (fill-gap chain (- rotated-gap-start count) rotated-gap-start) (setf gap-start (- rotated-gap-start count)) (decf gap-end count) (normalize-indices chain)))) (defun hop-elements-right (chain 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) chain (move-elements chain buffer buffer gap-start gap-end (+ gap-end count)) (fill-gap chain gap-end (+ gap-end count)) (incf gap-start count) (incf gap-end count) (normalize-indices chain))) (defun increase-buffer-size (chain nb-elements) (resize-buffer chain (required-space chain nb-elements))) (defun decrease-buffer-size (chain) (resize-buffer chain (required-space chain (nb-elements chain)))) (defgeneric resize-buffer (standard-flexichain new-buffer-size) (:documentation "allocate a new buffer with the size indicated")) (defmethod resize-buffer ((fc standard-flexichain) new-buffer-size) (with-slots (buffer gap-start gap-end fill-element element-type expand-factor) fc (let ((buffer-size (length buffer)) (buffer-after (make-array new-buffer-size :element-type element-type :initial-element fill-element))) (case (gap-location fc) ((:gap-empty :gap-middle) (move-elements fc buffer-after buffer 0 0 gap-start) (let ((gap-end-after (- new-buffer-size (- buffer-size gap-end)))) (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size) (setf gap-end gap-end-after))) (:gap-right (move-elements fc buffer-after buffer 0 0 gap-start)) (:gap-left (let ((gap-end-after (- new-buffer-size (+ 2 (nb-elements fc))))) (move-elements fc buffer-after buffer gap-end-after gap-end buffer-size) (setf gap-end gap-end-after))) (:gap-non-contiguous (move-elements fc buffer-after buffer 0 gap-end gap-start) (decf gap-start gap-end) (setf gap-end 0))) (setf buffer buffer-after))) (normalize-indices fc)) (defun normalize-indices (chain) "Sets gap limits to 0 if they are at the end of the buffer." (with-slots (buffer gap-start gap-end data-start) chain (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 (chain) "Returns a keyword indicating the general location of the gap." (with-slots (buffer gap-start gap-end) chain (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)))) cl-flexichain-1.5.1.dfsg.1.orig/flexicursor.lisp0000640000175000017500000002313110747017204017622 0ustar pdmpdm;;; Flexichain ;;; Flexicursor 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 :flexichain) (defclass cursorchain (flexichain) () (:documentation "The protocol class for cursor chains.")) (defclass flexicursor () () (:documentation "The protocol class for flexicursors.")) (define-condition at-beginning-error (flexi-error) ((cursor :reader at-beginning-error-cursor :initarg :cursor :initform nil)) (:report (lambda (condition stream) (let ((cursor (at-beginning-error-cursor condition))) (format stream "Cursor ~A already at the beginning of ~A" cursor (chain cursor)))))) (define-condition at-end-error (flexi-error) ((cursor :reader at-end-error-cursor :initarg :cursor :initform nil)) (:report (lambda (condition stream) (let ((cursor (at-end-error-cursor condition))) (format stream "Cursor ~A already at the end of ~A" cursor (chain cursor)))))) (defgeneric clone-cursor (cursor) (:documentation "Creates a cursor that is initially at the same location as the one given as argument.")) (defgeneric cursor-pos (cursor) (:documentation "Returns the position of the cursor.")) (defgeneric (setf cursor-pos) (posistion cursor) (:documentation "Set the position of the cursor.")) (defgeneric at-beginning-p (cursor) (:documentation "Returns true if the cursor is at the beginning of the chain.")) (defgeneric at-end-p (cursor) (:documentation "Returns true if the cursor is at the beginning of the chain.")) (defgeneric move> (cursor &optional n) (:documentation "Moves the cursor forward N positions.")) (defgeneric move< (cursor &optional n) (:documentation "Moves the cursor backward N positions.")) (defgeneric insert (cursor object) (:documentation "Inserts an object at the cursor.")) (defgeneric insert-sequence (cursor sequence) (:documentation "The effect is the same as if each element of the sequence was inserted using INSERT.")) (defgeneric delete< (cursor &optional n) (:documentation "Deletes N objects before the cursor.")) (defgeneric delete> (cursor &optional n) (:documentation "Deletes N objects after the cursor.")) (defgeneric element< (cursor) (:documentation "Returns the element immediately before the cursor.")) (defgeneric (setf element<) (object cursor) (:documentation "Replaces the element immediately before the cursor.")) (defgeneric element> (cursor) (:documentation "Returns the element immediately after the cursor.")) (defgeneric (setf element>) (object cursor) (:documentation "Replaces the element immediately after the cursor.")) (defclass standard-cursorchain (cursorchain standard-flexichain) ((cursors :initform '())) (:documentation "The standard instantiable subclass of CURSORCHAIN")) (defclass standard-flexicursor (flexicursor) ((chain :reader chain :initarg :chain) (index :accessor flexicursor-index)) (:documentation "The standard instantiable subclass of FLEXICURSOR")) (defclass left-sticky-flexicursor (standard-flexicursor) ()) (defclass right-sticky-flexicursor (standard-flexicursor) ()) (defmethod initialize-instance :after ((cursor left-sticky-flexicursor) &rest initargs &key (position 0)) (declare (ignore initargs)) (with-slots (index chain) cursor (setf index (position-index chain (1- position))) (with-slots (cursors) chain (push (make-weak-pointer cursor) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-flexicursor) &rest initargs &key (position 0)) (declare (ignore initargs)) (with-slots (index chain) cursor (setf index (position-index chain position)) (with-slots (cursors) chain (push (make-weak-pointer cursor) cursors)))) (defun adjust-cursors (cursors start end increment) (let ((acc '())) (loop for cursor = (and cursors (weak-pointer-value (car cursors))) while cursors do (cond ((null cursor) (pop cursors)) ((<= start (flexicursor-index cursor) end) (incf (flexicursor-index cursor) increment) (let ((rest (cdr cursors))) (setf (cdr cursors) acc acc cursors cursors rest))) (t (let ((rest (cdr cursors))) (setf (cdr cursors) acc acc cursors cursors rest))))) acc)) (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) (declare (ignore to from)) (with-slots (cursors) cc (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2))))) (defmethod clone-cursor ((cursor standard-flexicursor)) (make-instance (class-of cursor) :chain (chain cursor) :position (cursor-pos cursor))) (defmethod cursor-pos ((cursor left-sticky-flexicursor)) (1+ (index-position (chain cursor) (slot-value cursor 'index)))) (defmethod (setf cursor-pos) (position (cursor left-sticky-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () 'flexi-position-error :chain (chain cursor) :position position) (with-slots (chain) cursor (setf (flexicursor-index cursor) (position-index chain (1- position))))) (defmethod cursor-pos ((cursor right-sticky-flexicursor)) (index-position (chain cursor) (slot-value cursor 'index))) (defmethod (setf cursor-pos) (position (cursor right-sticky-flexicursor)) (assert (<= 0 position (nb-elements (chain cursor))) () 'flexi-position-error :chain (chain cursor) :position position) (with-slots (chain) cursor (setf (flexicursor-index cursor) (position-index chain position)))) (defmethod at-beginning-p ((cursor standard-flexicursor)) (zerop (cursor-pos cursor))) (defmethod at-end-p ((cursor standard-flexicursor)) (= (cursor-pos cursor) (nb-elements (chain cursor)))) (defmethod insert ((cursor standard-flexicursor) object) (insert* (chain cursor) (cursor-pos cursor) object)) (defmethod insert-sequence ((cursor standard-flexicursor) sequence) (map nil (lambda (object) (insert cursor object)) sequence)) (defmethod delete* :before ((chain standard-cursorchain) position) (with-slots (cursors) chain (let* ((old-index (position-index chain position))) (loop for cursor-wp in cursors as cursor = (weak-pointer-value cursor-wp) when (and cursor (= old-index (flexicursor-index cursor))) do (typecase cursor (right-sticky-flexicursor (incf (cursor-pos cursor))) (left-sticky-flexicursor (decf (cursor-pos cursor)))))))) (defmethod delete-elements* :before ((chain standard-cursorchain) position n) (with-slots (cursors) chain (when (minusp n) (incf position n) (setf n (* -1 n))) (unless (zerop n) (loop for cursor-wp in cursors as cursor = (weak-pointer-value cursor-wp) when (and cursor (<= position (cursor-pos cursor) (+ position n))) do (typecase cursor (right-sticky-flexicursor (setf (cursor-pos cursor) (+ position n))) (left-sticky-flexicursor (setf (cursor-pos cursor) position))))))) (defmethod delete> ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) (position (cursor-pos cursor))) (assert (plusp n) () 'flexi-position-error :chain chain :position n) (loop repeat n do (delete* chain position)))) (defmethod delete< ((cursor standard-flexicursor) &optional (n 1)) (let ((chain (chain cursor)) (position (cursor-pos cursor))) (assert (plusp n) () 'flexi-position-error :chain chain :position n) (loop repeat n do (delete* chain (- position n))))) (defmethod element> ((cursor standard-flexicursor)) (assert (not (at-end-p cursor)) () 'at-end-error :cursor cursor) (element* (chain cursor) (cursor-pos cursor))) (defmethod (setf element>) (object (cursor standard-flexicursor)) (assert (not (at-end-p cursor)) () 'at-end-error :cursor cursor) (setf (element* (chain cursor) (cursor-pos cursor)) object)) (defmethod element< ((cursor standard-flexicursor)) (assert (not (at-beginning-p cursor)) () 'at-beginning-error :cursor cursor) (element* (chain cursor) (1- (cursor-pos cursor)))) (defmethod (setf element<) (object (cursor standard-flexicursor)) (assert (not (at-beginning-p cursor)) () 'at-beginning-error :cursor cursor) (setf (element* (chain cursor) (1- (cursor-pos cursor))) object)) cl-flexichain-1.5.1.dfsg.1.orig/flexirank.lisp0000640000175000017500000000610210747017215017241 0ustar pdmpdm;;; Ranked flexichain ;;; ;;; Copyright (C) 2005 Robert Strandh (strandh@labri.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 :flexichain) ;;; A ranked flexichain is a flexichain (or a cursorchain) in which ;;; the elements know their position. To make that work, client code ;;; must use mix in the flexirank-mixin class into whatever flexichain ;;; class they are using, and mix in the element-rank-mixin class into ;;; elements of that chain. ;;; The element-rank-mixin supplies a method on the client-visible ;;; generic function rank. (defgeneric rank (element)) (defgeneric flexi-first-p (element)) (defgeneric flexi-last-p (element)) (defgeneric flexi-next (element)) (defgeneric flexi-prev (element)) (defclass element-rank-mixin () ((index :accessor index) (chain :accessor chain))) (defmethod rank ((element element-rank-mixin)) (index-position (chain element) (index element))) (defmethod flexi-first-p ((element element-rank-mixin)) (zerop (rank element))) (defmethod flexi-last-p ((element element-rank-mixin)) (= (rank element) (1- (nb-elements (chain element))))) (defmethod flexi-next ((element element-rank-mixin)) (assert (not (flexi-last-p element))) (element* (chain element) (1+ (rank element)))) (defmethod flexi-prev ((element element-rank-mixin)) (assert (not (flexi-first-p element))) (element* (chain element) (1- (rank element)))) ;;; this class must be mixed into a flexichain that contains ranked elements (defclass flexirank-mixin () ()) (defmethod move-elements :before ((chain flexirank-mixin) to from start1 start2 end2) (declare (ignore to)) (loop for old from start2 below end2 for new from start1 do (let ((element (aref from old))) (when (typep element 'element-rank-mixin) (setf (index element) new))))) (defmethod insert* :after ((chain flexirank-mixin) position (object element-rank-mixin)) (setf (index object) (position-index chain position) (chain object) chain)) (defmethod (setf element*) :after ((object element-rank-mixin) (chain flexirank-mixin) position) (setf (index object) (position-index chain position) (chain object) chain)) (defmethod insert-vector* :after ((chain flexirank-mixin) position vector) (loop for elem across vector for pos from position do (setf (index elem) (position-index chain pos) (chain elem) chain)))