piecetable.lisp

(in-package :cl)
(defpackage piecetable
  (:use :cl)
  (:shadow :cl :delete))
(in-package :piecetable)

(defstruct span
  in-add-buffer
  start
  end)

(defstruct text
  file-buffer
  add-buffer
  spans)

(defun span-length (span)
  (- (span-end span) (span-start span)))

(defun span-empty-p (span)
  (zerop (span-length span)))

(defun load-string (string)
  (make-text :file-buffer (copy-seq string)
             :add-buffer (make-array 512
                                     :adjustable t
                                     :fill-pointer 0)
             :spans (list (make-span :in-add-buffer nil
                                     :start 0
                                     :end (length string)))))

(defun load-file (filename)
  (let (buf)
    (with-open-file (in filename)
      (let* ((len (file-length in)))
        (setf buf (make-string len))
        (read-sequence buf in)))
    (make-text :file-buffer buf
               :add-buffer (make-array 512
                                       :adjustable t
                                       :fill-pointer 0)
               :spans (list (make-span :in-add-buffer nil
                                       :start 0
                                       :end (length buf))))))

(defun show (text)
  (flet ((cut (span)
           (subseq (if (span-in-add-buffer span)
                       (text-add-buffer text)
                       (text-file-buffer text))
                   (span-start span)
                   (span-end span))))
    (apply #'concatenate 'string (mapcar #'cut (text-spans text)))))

(defun find-span (text index)
  (loop with in-span-offset = index
     with offset = 0
     for span in (text-spans text)
     for i from 0
     do (progn
          (when (and (<= offset index)
                     (< index (+ offset (span-length span))))
            (return-from find-span (values span in-span-offset i)))
          (decf in-span-offset (span-length span))
          (incf offset (span-length span)))
     finally (return (values nil 0 -1))))

(defun cleanup (text)
  (setf (text-spans text)
        (remove-if #'span-empty-p (text-spans text)))
  text)

(defun insert (text string index)
  (let* ((start (length (text-add-buffer text)))
         (end (+ start (length string)))
         (new-span (make-span :in-add-buffer t :start start :end end)))
    (cond ((zerop index)
           (push new-span (text-spans text)))

          (t
           (multiple-value-bind (span offset span-index) (find-span text index)
             (cond ((null span)
                    (nconc (text-spans text) (list new-span)))

                   (t
                    (let ((prev (make-span :in-add-buffer (span-in-add-buffer span)
                                           :start (span-start span)
                                           :end (+ (span-start span) offset)))
                          (next (make-span :in-add-buffer (span-in-add-buffer span)
                                           :start (+ (span-start span) offset)
                                           :end (span-end span))))
                      (setf (text-spans text)
                            (append (subseq (text-spans text) 0 span-index)
                                    (list prev new-span next)
                                    (subseq (text-spans text) (1+ span-index))))))))))
    (loop for c across string
       do (vector-push-extend c (text-add-buffer text)))

    (cleanup text)))

(defun delete (text index length)
  (multiple-value-bind (span offset span-index) (find-span text index)
    (multiple-value-bind (span2 offset2 span2-index) (find-span text (+ index length))
      (let ((prev (and span
                       (make-span :in-add-buffer (span-in-add-buffer span)
                                  :start (span-start span)
                                  :end (+ (span-start span) offset))))
            (next (and span2
                       (make-span :in-add-buffer (span-in-add-buffer span2)
                                  :start (+ (span-start span2) offset2)
                                  :end (span-end span2)))))
        (cond ((and prev next)
               (setf (text-spans text)
                     (append (subseq (text-spans text) 0 span-index)
                             (list prev next)
                             (subseq (text-spans text) (1+ span2-index)))))
              (prev
               (setf (elt (text-spans text) span-index) prev))
              (next
               (setf (elt (text-spans text) span2-index) next))))))
  (cleanup text))

(defun test ()
  (let (ng)
    (macrolet ((assert-equal (expr expected)
                 (let ((actual (gensym)))
                   `(let ((,actual ,expr))
                      (unless (equal ,actual ,expected)
                        (format *error-output* "~&expected ~A but was ~A" ,expected ,actual)
                        (setf ng t))))))
      ;; insert
      (let ((txt (load-string "abcdef")))
        (assert-equal (show (insert txt "ABC" 0)) "ABCabcdef")
        (assert-equal (show (insert txt "DEF" 1)) "ADEFBCabcdef")
        (assert-equal (show (insert txt "G" 12)) "ADEFBCabcdefG"))

      ;; delete
      (let ((txt (load-string "abcdef")))
        (assert-equal (show (delete txt 0 1)) "bcdef")
        (assert-equal (show (delete txt 1 2)) "bef")
        (assert-equal (show (delete txt 2 1)) "be"))

      ;; insert/delete
      (let ((txt (load-string "abcdef")))
        (assert-equal (show (insert txt "ABC" 3)) "abcABCdef")
        (assert-equal (show (delete txt 5 2)) "abcABef"))

      (unless ng
        (format t "OK")))))