<commit_before>(defpackage :mezzanine.editor
  (:use :cl)
  (:export #:spawn))

(in-package :mezzanine.editor)

;;; Lines.

(defclass line ()
  ((%next :initarg :next :accessor next-line)
   (%prev :initarg :prev :accessor previous-line)
   (%data :initarg :data :accessor data)
   (%version :initarg :version :accessor line-version)
   (%number :initarg :number :accessor line-number)
   (%mark-list :initarg :mark-list :accessor line-mark-list)
   (%buffer :initarg :buffer :accessor line-buffer))
  (:default-initargs :next nil
                     :prev nil
                     :data (make-array 50 :element-type 'character :adjustable t :fill-pointer 0)
                     :version 0
                     :number 0
                     :mark-list '()
                     :buffer nil))

(defgeneric line-character (line charpos))
(defgeneric (setf line-character) (value line charpos))
(defgeneric line-length (line))

(defmethod line-character ((line line) charpos)
  (aref (data line) charpos))

(defmethod (setf line-character) (value (line line) charpos)
  (setf (aref (data line) charpos) value))

(defmethod line-length ((line line))
  (length (data line)))

(defmethod print-object ((object line) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "N:~D V:~D" (line-number object) (line-version object))))

;;; Marks.

(defclass mark ()
  ((%line :initarg :line :reader mark-line)
   (%charpos :initarg :charpos :reader mark-charpos)
   ;; :left, :right or :temporary.
   (%kind :initarg :kind :reader mark-kind)))

(defgeneric (setf mark-line) (value mark))
(defgeneric (setf mark-charpos) (value mark))
(defgeneric (setf mark-kind) (value mark))

(defmethod print-object ((object mark) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~S:~D ~S" (mark-line object) (mark-charpos object) (mark-kind object))))

;;; Buffers.

(defclass buffer ()
  ((%first-line :accessor first-line)
   (%last-line :accessor last-line)
   (%point :reader buffer-point)
   (%mark :reader buffer-mark)
   (%mark-active :initarg :mark-active :accessor buffer-mark-active)
   (%properties))
  (:default-initargs :mark-active nil))

(defgeneric buffer-property (buffer property-name &optional default))
(defgeneric (setf buffer-property) (value buffer property-name &optional default))

(defmethod buffer-property ((buffer buffer) property-name &optional default)
  (gethash property-name (slot-value buffer '%properties) default))

(defmethod (setf buffer-property) (value (buffer buffer) property-name &optional default)
  (setf (gethash property-name (slot-value buffer '%properties) default) value))

(defmethod initialize-instance :after ((instance buffer) &key &allow-other-keys)
  (let ((line (make-instance 'line :buffer instance)))
    (setf (first-line instance) line
          (last-line instance) line
          (slot-value instance '%properties) (make-hash-table)
          (slot-value instance '%point) (make-mark line 0 :right)
          (slot-value instance '%mark) (make-mark line 0 :left))))

;;; The editor itself.

(defclass editor ()
  ((%fifo :initarg :fifo :reader fifo)
   (%pending-event :initarg :pending-event :accessor pending-event)
   (%pending-redisplay :initarg :pending-redisplay :accessor pending-redisplay)
   (%window :initarg :window :accessor window)
   (%frame :initarg :frame :accessor frame)
   (%buffer-list :initarg :buffer-list :accessor buffer-list)
   (%buffer :initarg :buffer :accessor current-buffer)
   (%last-buffer :initarg :last-buffer :accessor last-buffer)
   (%font :initarg :font :reader font)
   (%foreground-colour :initarg :foreground-colour :accessor foreground-colour)
   (%background-colour :initarg :background-colour :accessor background-colour)
   (%killed-region :initarg :killed-region :accessor killed-region)
   (%global-key-map :initarg :global-key-map :accessor global-key-map)
   (%post-command-hooks :initarg :post-command-hooks :accessor post-command-hooks)
   ;; Redisplay state.
   (%current-screen :initarg :screen :accessor editor-current-screen)
   (%line-cache :initarg :display-line-cache :accessor display-line-cache))
  (:default-initargs :pending-event nil
                     :pending-redisplay t
                     :foreground-colour mezzanine.gui:*default-foreground-colour*
                     :background-colour mezzanine.gui:*default-background-colour*
                     :buffer-list '()
                     :last-buffer '()
                     :killed-region nil
                     :global-key-map (make-hash-table)
                     :post-command-hooks '()
                     :screen nil
                     :display-line-cache '()))

(defvar *last-command*)
(defvar *this-command*)
(defvar *last-character*)
(defvar *this-character*)
(defvar *last-chord*)
(defvar *this-chord*)
(defvar *minibuffer*)
(defvar *minibuffer-key-map*)

(defvar *editor*)

(defgeneric dispatch-event (editor event)
  (:method (editor event)))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:window-activation-event))
  (setf (mezzanine.gui.widgets:activep (frame editor)) (mezzanine.gui.compositor:state event))
  (mezzanine.gui.widgets:draw-frame (frame editor)))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:mouse-event))
  (handler-case
      (mezzanine.gui.widgets:frame-mouse-event (frame editor) event)
    (mezzanine.gui.widgets:close-button-clicked ()
      (throw 'quit nil))))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:window-close-event))
  (declare (ignore editor event))
  (throw 'quit nil))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:key-event))
  (when (not (mezzanine.gui.compositor:key-releasep event))
    (throw 'next-character
      (if (mezzanine.gui.compositor:key-modifier-state event)
          ;; Force character to uppercase when a modifier key is active, gets
          ;; around weirdness in how character names are processed.
          ;; #\C-a and #\C-A both parse as the same character (C-LATIN_CAPITAL_LETTER_A).
          (sys.int::make-character (char-code (char-upcase (mezzanine.gui.compositor:key-key event)))
                                   :control (find :control (mezzanine.gui.compositor:key-modifier-state event))
                                   :meta (find :meta (mezzanine.gui.compositor:key-modifier-state event))
                                   :super (find :super (mezzanine.gui.compositor:key-modifier-state event))
                                   :hyper (find :hyper (mezzanine.gui.compositor:key-modifier-state event)))
          (mezzanine.gui.compositor:key-key event)))))

(defun editor-read-char-1 ()
  (catch 'next-character
    (when (pending-event *editor*)
      (let ((event (pending-event *editor*)))
        (setf (pending-event *editor*) nil)
      (dispatch-event *editor* event)))
    (when (pending-redisplay *editor*)
      (throw 'next-character nil))
    (loop
       (dispatch-event *editor* (mezzanine.supervisor:fifo-pop (fifo *editor*))))))

(defun editor-read-char ()
  (loop
     (let ((ch (editor-read-char-1)))
       (when ch
         (return ch)))
     (setf (pending-redisplay *editor*) (not (redisplay)))))

(define-condition pending-input () ())

(defun check-pending-input ()
  (cond ((pending-event *editor*)
         (signal 'pending-input))
        (t (let ((event (mezzanine.supervisor:fifo-pop (fifo *editor*) nil)))
             (when event
               (setf (pending-event *editor*) event)
               (signal 'pending-input))))))

(defun refresh-title ()
  (let ((buffer (current-buffer *editor*)))
    (setf (mezzanine.gui.widgets:frame-title (frame *editor*))
          (format nil "Editor - ~A~A"
                  (or (buffer-property buffer 'name) "Untitled")
                  (cond ((buffer-property buffer 'new-file)
                         " (New file)")
                        ((buffer-modified buffer)
                         " (Modified)")
                        (t ""))))
    (mezzanine.gui.widgets:draw-frame (frame *editor*))))

(defun switch-to-buffer (buffer)
  (setf (current-buffer *editor*) buffer
        (pending-redisplay *editor*) t)
  (refresh-title))

;;; Mark management.

(defun make-mark (line charpos &optional kind)
  (setf kind (or kind :temporary))
  (check-type kind (member :left :right :temporary))
  (let ((mark (make-instance 'mark
                             :line line
                             :charpos charpos
                             :kind kind)))
    (unless (eql kind :temporary)
      (push mark (line-mark-list line)))
    mark))

(defmethod (setf mark-line) (value (mark mark))
  (unless (eql (mark-kind mark) :temporary)
    (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark))))
    (push mark (line-mark-list value)))
  (setf (slot-value mark '%charpos) (min (line-length value) (mark-charpos mark))
        (slot-value mark '%line) value))

(defmethod (setf mark-charpos) (value (mark mark))
  (check-type value (integer 0))
  (assert (<= value (line-length (mark-line mark))) (value) "Tried to move mark past end of line.")
  (setf (slot-value mark '%charpos) value))

(defmethod (setf mark-kind) (value (mark mark))
  (check-type value (member :temporary :left :right))
  (unless (eql (mark-kind mark) :temporary)
    ;; Remove from existing mark list.
    (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark)))))
  (unless (eql value :temporary)
    ;; Add to mark list.
    (push mark (line-mark-list (mark-line mark))))
  (setf (slot-value mark '%kind) value))

(defun copy-mark (mark &optional kind)
  (make-mark (mark-line mark) (mark-charpos mark) kind))

(defun delete-mark (mark)
  (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark)))))

(defmacro with-mark ((name where &optional kind) &body body)
  `(let ((,name nil))
     (unwind-protect
          (progn
            (setf ,name (copy-mark ,where ,kind))
            ,@body)
       (when ,name
         (delete-mark ,name)))))

(defun move-mark-to-mark (move-this-one here)
  (setf (mark-line move-this-one) (mark-line here)
        (mark-charpos move-this-one) (mark-charpos here)))

(defun mark= (a b)
  (and (eql (mark-line a) (mark-line b))
       (eql (mark-charpos a) (mark-charpos b))))

(defun mark< (a b)
  (or (< (line-number (mark-line a)) (line-number (mark-line b)))
      (and (eql (line-number (mark-line a)) (line-number (mark-line b)))
           (< (mark-charpos a) (mark-charpos b)))))

(defun mark> (a b)
  (mark< b a))

(defun mark<= (a b)
  (not (mark> a b)))

(defun mark>= (a b)
  (not (mark< a b)))

(defun point-to-mark (buffer mark)
  (move-mark-to-mark (buffer-point buffer) mark))

(defun mark-to-point (buffer mark)
  (move-mark-to-mark mark (buffer-point buffer)))

(defun mark-at-point-p (buffer mark)
  (mark= mark (buffer-point buffer)))

(defun start-of-line-p (mark)
  (eql (mark-charpos mark) 0))

(defun end-of-line-p (mark)
  (eql (mark-charpos mark) (line-length (mark-line mark))))

;;; Sub-editor. Buffer manipulation.

(defun buffer-modified (buffer)
  (buffer-property buffer 'modified))

(defun (setf buffer-modified) (value buffer)
  (when (not (eql (buffer-property buffer 'modified) value))
    (setf (buffer-property buffer 'modified) value)
    (refresh-title))
  value)

(defconstant +line-number-increment+ 10000)

(defun fully-renumber-lines-from (line)
  (do ((l line (next l)))
      ((null l))
    (setf (line-number line) (+ (line-number (prev line)) +line-number-increment+))))

(defun insert-line (point)
  "Insert a new line at POINT, splitting the current line if needed.
Don't use this, use INSERT instead."
  (let* ((current-line (mark-line point))
         (current-charpos (mark-charpos point))
         (new-line (make-instance 'line
                                  :buffer (line-buffer current-line)
                                  :next (next-line current-line)
                                  :prev current-line
                                  :data (make-array (- (line-length current-line)
                                                       current-charpos)
                                                    :element-type 'character
                                                    :adjustable t
                                                    :fill-pointer t))))
    ;; Update line contents.
    (replace (data new-line) (data current-line)
             :start2 current-charpos)
    (setf (fill-pointer (data current-line)) current-charpos)
    (incf (line-version current-line))
    ;; Link into the line list.
    (cond ((next-line current-line)
           (setf (previous-line (next-line current-line)) new-line))
          ((line-buffer current-line)
           (setf (last-line (line-buffer current-line)) new-line)))
    (setf (next-line current-line) new-line)
    ;; Ensure coherent numbering.
    (cond ((and (next-line new-line)
                (eql (1+ (line-number current-line)) (line-number (next-line new-line))))
           ;; No numbers between. Give up and renumber everything from the new line forward.
           ;; Could be smarter.
           (fully-renumber-lines-from new-line))
          ((next-line new-line)
           ;; Midway between the previous (current) and the next line.
           (setf (line-number new-line) (+ (line-number current-line)
                                           (truncate (- (line-number (next-line new-line)) (line-number current-line)) 2))))
          (t (setf (line-number new-line) (+ (line-number current-line) +line-number-increment+))))
    ;; Update marks.
    (dolist (mark (line-mark-list current-line))
      (when (or (and (eql (mark-kind mark) :right)
                     (eql (mark-charpos mark) current-charpos))
                (> (mark-charpos mark) current-charpos))
        (let ((real-pos (- (line-length current-line) (mark-charpos mark))))
          (setf (mark-line mark) new-line
                (mark-charpos mark) real-pos))))
    ;; Mark buffer modified (if any).
    (when (line-buffer current-line)
      (setf (buffer-modified (line-buffer current-line)) t)))
  (values))

(defun insert-char (point character)
  "Insert CHARACTER at POINT.
Don't use this directly, use INSERT instead."
  (let* ((current-line (mark-line point))
         (current-charpos (mark-charpos point)))
    (cond ((eql (line-length current-line) current-charpos)
           ;; Inserting at end.
           (vector-push-extend character (data current-line)))
          (t ;; Inserting in the middle or at the start.
           ;; Make sure the vector is long enough.
           (vector-push-extend character (data current-line))
           (replace (data current-line) (data current-line)
                    :start1 (1+ current-charpos)
                    :start2 current-charpos)
           (setf (aref (data current-line) current-charpos) character)))
    (incf (line-version current-line))
    ;; Update marks.
    (dolist (mark (line-mark-list current-line))
      (when (or (and (eql (mark-kind mark) :right)
                     (eql (mark-charpos mark) current-charpos))
                (> (mark-charpos mark) current-charpos))
        (incf (mark-charpos mark))))
    ;; Mark buffer modified (if any).
    (when (line-buffer current-line)
      (setf (buffer-modified (line-buffer current-line)) t)))
  (values))

(defun insert (buffer string)
  "Insert STRING into BUFFER at point. STRING is a string-designator, so can be a character."
  (loop for ch across (string string)
     if (char= ch #\Newline)
     do (insert-line (buffer-point buffer))
     else do (insert-char (buffer-point buffer) ch)))

(defun order-marks (mark-1 mark-2)
  (let ((line-1 (mark-line mark-1))
        (line-2 (mark-line mark-2)))
    (cond ((eql line-1 line-2)
           (if (> (mark-charpos mark-1) (mark-charpos mark-2))
               (values mark-2 mark-1)
               (values mark-1 mark-2)))
          ((> (line-number line-1)
              (line-number line-2))
           (values mark-2 mark-1))
          (t (values mark-1 mark-2)))))

(defun insert-region-at-mark (point mark-1 mark-2)
  (setf (values mark-1 mark-2) (order-marks mark-1 mark-2))
  (let ((line-1 (mark-line mark-1))
        (chpos-1 (mark-charpos mark-1))
        (line-2 (mark-line mark-2))
        (chpos-2 (mark-charpos mark-2))
        (insert-line (mark-line point))
        (insert-chpos (mark-charpos point)))
    (cond ((eql line-1 line-2)
           ;; Not inserting any newlines, just make the line bigger.
           (when (not (eql chpos-1 chpos-2))
             (adjust-array (data insert-line)
                           (+ insert-chpos (- chpos-2 chpos-1))
                           :fill-pointer t)
             (when (not (eql (line-length insert-line) insert-chpos))
               ;; Inserting in the middle, need to shuffle data up.
               (replace (data insert-line) (data insert-line)
                        :start1 (+ insert-chpos (- chpos-2 chpos-1))
                        :start2 insert-chpos))
             ;; Insert new data into the hole.
             (replace (data insert-line) (data line-1)
                      :start1 insert-chpos
                      :start2 chpos-1
                      :end2 chpos-2)
             (incf (line-version insert-line))
             ;; Update marks.
             (dolist (mark (line-mark-list insert-line))
               (when (or (and (eql (mark-kind mark) :right)
                              (eql (mark-charpos mark) insert-chpos))
                         (> (mark-charpos mark) insert-chpos))
                 (incf (mark-charpos mark) (- chpos-2 chpos-1))))
             ;; Mark buffer modified (if any).
             (when (line-buffer line-1)
               (setf (buffer-modified (line-buffer line-1)) t))))
          (t ;; Inserting multiple lines.
           ;; todo properly...
           (do ((m1 (copy-mark mark-1))
                (m2 (copy-mark mark-2)))
               ((mark= m1 m2))
             (if (end-of-line-p m1)
                 (insert-line point)
                 (insert-char point (line-character (mark-line m1) (mark-charpos m1))))
             (move-mark m1))))))

(defun insert-region (buffer mark-1 mark-2)
  (insert-region-at-mark (buffer-point buffer)
                         mark-1 mark-2))

(defun yank-region (buffer)
  (when (killed-region *editor*)
    (insert-region buffer (car (killed-region *editor*)) (cdr (killed-region *editor*)))))

(defun delete-region (buffer mark-1 mark-2)
  "Delete region designated by MARK-1 and MARK-2 from buffer.
Returns the deleted region as a pair of marks into a disembodied line."
  (setf (values mark-1 mark-2) (order-marks mark-1 mark-2))
  (cond ((eql (mark-line mark-1) (mark-line mark-2))
         ;; Same line.
         (let* ((line (mark-line mark-1))
                (start (mark-charpos mark-1))
                (end (mark-charpos mark-2))
                (data (make-array (- end start)
                                  :element-type 'character
                                  :adjustable t
                                  :fill-pointer t)))
           ;; Extract deleted data.
           (replace data (data line)
                    :start2 start
                    :end2 end)
           ;; Delete data.
           (replace (data line) (data line)
                    :start1 start
                    :start2 end)
           (decf (fill-pointer (data line)) (- end start))
           ;; Update version.
           (incf (line-version line))
           ;; Update marks.
           (dolist (mark (line-mark-list line))
             (when (> (mark-charpos mark) start)
               (decf (mark-charpos mark) (- end start))))
           ;; Mark buffer modified (if any).
           (when (line-buffer line)
             (setf (buffer-modified (line-buffer line)) t))
           ;; Done.
           (let ((new-line (make-instance 'line :data data)))
             (values (make-mark new-line 0 :left)
                     (make-mark new-line (length data) :right)))))
        (t ;; Different lines.
         (let* ((first-line (mark-line mark-1))
                (first-chpos (mark-charpos mark-1))
                (next-line (next-line first-line))
                (last-line (mark-line mark-2))
                (last-chpos (mark-charpos mark-2))
                (data (make-array (- (line-length first-line) first-chpos)
                                  :element-type 'character
                                  :adjustable t
                                  :fill-pointer t)))
           (replace data (data first-line) :start2 first-chpos)
           ;; Join lines together.
           (adjust-array (data first-line)
                         (+ first-chpos
                            (- (line-length last-line) last-chpos))
                         :fill-pointer t)
           (replace (data first-line) (data last-line)
                    :start1 first-chpos
                    :start2 last-chpos)
           (incf (line-version first-line))
           (incf (line-version last-line))
           ;; Unlink intermediate lines & the last line from the line list.
           (cond ((next-line last-line)
                  (setf (previous-line (next-line last-line)) first-line))
                 (t (setf (last-line buffer) first-line)))
           (setf (next-line first-line) (next-line last-line))
           (setf (next-line last-line) nil
                 (line-buffer last-line) nil
                 (fill-pointer (data last-line)) last-chpos)
           ;; Adjust first-line marks.
           (dolist (mark (line-mark-list first-line))
             (when (> (mark-charpos mark) first-chpos)
               (setf (mark-charpos mark) first-chpos)))
           ;; Adjust last-line marks.
           (dolist (mark (line-mark-list last-line))
             (let ((new-pos (+ first-chpos (max 0 (- (mark-charpos mark) last-chpos)))))
               (setf (mark-line mark) first-line
                     (mark-charpos mark) new-pos)))
           ;; Adjust middle marks and fix lines.
           (do ((line next-line (next-line line)))
               ((eql line last-line))
             (incf (line-version line))
             (setf (line-buffer line) nil)
             (dolist (mark (line-mark-list line))
               (setf (mark-line mark) first-line
                     (mark-charpos mark) first-chpos)))
           ;; Mark buffer modified (if any).
           (when (line-buffer first-line)
             (setf (buffer-modified (line-buffer first-line)) t))
           ;; Done.
           (let ((new-line (make-instance 'line
                                          :data data
                                          :next next-line)))
             (setf (previous-line next-line) new-line)
             (values (make-mark new-line 0 :left)
                     (make-mark last-line last-chpos :right)))))))

(defun kill-region (buffer mark-1 mark-2)
  (multiple-value-bind (first-mark last-mark)
      (delete-region buffer mark-1 mark-2)
    (when (or (not (mark= first-mark last-mark))
              (eql *last-command* 'kill-region))
      (setf *this-command* 'kill-region))
    (cond ((and (killed-region *editor*)
                (eql *last-command* 'kill-region))
           ;; Append to killed region.
           (insert-region-at-mark (cdr (killed-region *editor*))
                                  first-mark last-mark))
          (t ;; New killed region.
           (setf (killed-region *editor*) (cons first-mark last-mark))))))

(defun kill-line (buffer)
  "Kill from point to the end of the line. If the point is at the end of the line,
then merge the current line and next line."
  (let ((point (buffer-point buffer)))
    (with-mark (here point :left)
      (if (end-of-line-p point)
          (move-mark point)
          (move-end-of-line buffer))
      (unwind-protect
           (kill-region buffer here point)
        (point-to-mark buffer here))))
  (values))

(defun delete-char (buffer &optional (n 1))
  "Delete the following N characters (previous if N is negative)."
  (let ((point (buffer-point buffer)))
    (with-mark (here point :left)
      (move-mark point n)
      (unwind-protect
           (delete-region buffer here point)
        (point-to-mark buffer here))))
  (values))

(defun buffer-string (buffer mark-1 mark-2)
  (setf (values mark-1 mark-2) (order-marks mark-1 mark-2))
  (with-output-to-string (str)
    (do ((m1 (copy-mark mark-1))
         (m2 (copy-mark mark-2)))
        ((mark= m1 m2))
      (if (end-of-line-p m1)
          (terpri str)
          (write-char (line-character (mark-line m1) (mark-charpos m1)) str))
      (move-mark m1))))

;;; Point motion.

(defun move-beginning-of-line (buffer)
  (setf (mark-charpos (buffer-point buffer)) 0)
  (values))

(defun move-end-of-line (buffer)
  (let ((point (buffer-point buffer)))
    (setf (mark-charpos point) (line-length (mark-line point))))
  (values))

(defun move-beginning-of-buffer (buffer)
  (setf (mark-line (buffer-point buffer)) (first-line buffer)
        (mark-charpos (buffer-point buffer)) 0)
  (values))

(defun move-end-of-buffer (buffer)
  (let ((point (buffer-point buffer)))
    (setf (mark-line point) (last-line buffer)
          (mark-charpos point) (line-length (mark-line point))))
  (values))

(defun move-mark (mark &optional (n 1))
  "Move MARK forward by N character. Move backwards if N is negative.
Returns false when the mark reaches the start or end of the buffer, true otherwise."
  (cond ((minusp n)
         (setf n (- n))
         (dotimes (i n)
           (let ((current-line (mark-line mark)))
             (cond ((zerop (mark-charpos mark))
                    (cond ((previous-line current-line)
                           ;; At start of line.
                           (setf (mark-line mark) (previous-line current-line)
                                 (mark-charpos mark) (line-length (previous-line current-line))))
                          (t ;; At start of buffer.
                           (return-from move-mark nil))))
                   (t ;; Moving within a line.
                    (decf (mark-charpos mark)))))))
        (t
         (dotimes (i n)
           (let ((current-line (mark-line mark)))
             (cond ((eql (line-length current-line) (mark-charpos mark))
                    (cond ((next-line current-line)
                           ;; At end of line.
                           (setf (mark-line mark) (next-line current-line)
                                 (mark-charpos mark) 0))
                          (t (return-from move-mark nil))))
                   (t ;; Moving within a line.
                    (incf (mark-charpos mark))))))))
  t)

(defun move-char (buffer &optional (n 1))
  "Move point forward by N characters. Move backwards if N is negative."
  (move-mark (buffer-point buffer) n)
  (values))

(defun move-line (buffer &optional (n 1))
  "Move point down by N lines. N may be negative.
Tries to stay as close to the hint column as possible."
  (let* ((accessor #'next-line)
         (point (buffer-point buffer)))
    (when (not (eql *last-command* 'next-line))
      (setf (buffer-property buffer 'column-hint 0) (mark-charpos point)))
    (setf *this-command* 'next-line)
    (when (minusp n)
      (setf n (- n)
            accessor #'previous-line))
    (dotimes (i n)
      (let* ((current-line (mark-line point))
             (new-line (funcall accessor current-line)))
        (cond (new-line
               (setf (mark-line point) new-line
                     (mark-charpos point) (min (buffer-property buffer 'column-hint)
                                               (line-length new-line))))
              (t (return))))))
  (values))

(defun character-right-of (mark)
  (cond ((eql (mark-charpos mark) (line-length (mark-line mark)))
         (cond
           ((next-line (mark-line mark))
            ;; At end of line.
            #\Newline)
           (t ;; At end of buffer.
            nil)))
        (t (line-character (mark-line mark) (mark-charpos mark)))))

(defun character-left-of (mark)
  (cond ((eql (mark-charpos mark) 0)
         (cond
           ((previous-line (mark-line mark))
            ;; At start of line.
            #\Newline)
           (t ;; At start of buffer.
            nil)))
        (t (line-character (mark-line mark) (1- (mark-charpos mark))))))

(defun scan (mark predicate jump key)
  (loop
     (let ((ch (funcall key mark)))
       (when (not ch)
         (return nil))
       (when (funcall predicate ch)
         (return t))
       (when (not (move-mark mark jump))
         (return nil)))))

(defun scan-forward (mark predicate)
  (scan mark predicate 1 #'character-right-of))

(defun scan-backward (mark predicate)
  (scan mark predicate -1 #'character-left-of))

(defun move-word (buffer &optional (n 1))
  "Move point forward by N words. N may be negative."
  (let ((point (buffer-point buffer))
        (fn #'scan-forward))
    (when (minusp n)<commit_msg>Little changes, but made on Mezzanine!<commit_after>(defpackage :mezzanine.editor
  (:use :cl)
  (:export #:spawn))

(in-package :mezzanine.editor)

;;; Lines.

(defclass line ()
  ((%next :initarg :next :accessor next-line)
   (%prev :initarg :prev :accessor previous-line)
   (%data :initarg :data :accessor data)
   (%version :initarg :version :accessor line-version)
   (%number :initarg :number :accessor line-number)
   (%mark-list :initarg :mark-list :accessor line-mark-list)
   (%buffer :initarg :buffer :accessor line-buffer))
  (:default-initargs :next nil
                     :prev nil
                     :data (make-array 50 :element-type 'character :adjustable t :fill-pointer 0)
                     :version 0
                     :number 0
                     :mark-list '()
                     :buffer nil))

(defgeneric line-character (line charpos))
(defgeneric (setf line-character) (value line charpos))
(defgeneric line-length (line))

(defmethod line-character ((line line) charpos)
  (aref (data line) charpos))

(defmethod (setf line-character) (value (line line) charpos)
  (setf (aref (data line) charpos) value))

(defmethod line-length ((line line))
  (length (data line)))

(defmethod print-object ((object line) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "N:~D V:~D" (line-number object) (line-version object))))

;;; Marks.

(defclass mark ()
  ((%line :initarg :line :reader mark-line)
   (%charpos :initarg :charpos :reader mark-charpos)
   ;; :left, :right or :temporary.
   (%kind :initarg :kind :reader mark-kind)))

(defgeneric (setf mark-line) (value mark))
(defgeneric (setf mark-charpos) (value mark))
(defgeneric (setf mark-kind) (value mark))

(defmethod print-object ((object mark) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~S:~D ~S" (mark-line object) (mark-charpos object) (mark-kind object))))

;;; Buffers.

(defclass buffer ()
  ((%first-line :accessor first-line)
   (%last-line :accessor last-line)
   (%point :reader buffer-point)
   (%mark :reader buffer-mark)
   (%mark-active :initarg :mark-active :accessor buffer-mark-active)
   (%properties))
  (:default-initargs :mark-active nil))

(defgeneric buffer-property (buffer property-name &optional default))
(defgeneric (setf buffer-property) (value buffer property-name &optional default))

(defmethod buffer-property ((buffer buffer) property-name &optional default)
  (gethash property-name (slot-value buffer '%properties) default))

(defmethod (setf buffer-property) (value (buffer buffer) property-name &optional default)
  (setf (gethash property-name (slot-value buffer '%properties) default) value))

(defmethod initialize-instance :after ((instance buffer) &key &allow-other-keys)
  (let ((line (make-instance 'line :buffer instance)))
    (setf (first-line instance) line
          (last-line instance) line
          (slot-value instance '%properties) (make-hash-table)
          (slot-value instance '%point) (make-mark line 0 :right)
          (slot-value instance '%mark) (make-mark line 0 :left))))

;;; The editor itself.

(defclass editor ()
  ((%fifo :initarg :fifo :reader fifo)
   (%pending-event :initarg :pending-event :accessor pending-event)
   (%pending-redisplay :initarg :pending-redisplay :accessor pending-redisplay)
   (%window :initarg :window :accessor window)
   (%frame :initarg :frame :accessor frame)
   (%buffer-list :initarg :buffer-list :accessor buffer-list)
   (%buffer :initarg :buffer :accessor current-buffer)
   (%last-buffer :initarg :last-buffer :accessor last-buffer)
   (%font :initarg :font :reader font)
   (%foreground-colour :initarg :foreground-colour :accessor foreground-colour)
   (%background-colour :initarg :background-colour :accessor background-colour)
   (%killed-region :initarg :killed-region :accessor killed-region)
   (%global-key-map :initarg :global-key-map :accessor global-key-map)
   (%post-command-hooks :initarg :post-command-hooks :accessor post-command-hooks)
   ;; Redisplay state.
   (%current-screen :initarg :screen :accessor editor-current-screen)
   (%line-cache :initarg :display-line-cache :accessor display-line-cache))
  (:default-initargs :pending-event nil
                     :pending-redisplay t
                     :foreground-colour mezzanine.gui:*default-foreground-colour*
                     :background-colour mezzanine.gui:*default-background-colour*
                     :buffer-list '()
                     :last-buffer '()
                     :killed-region nil
                     :global-key-map (make-hash-table)
                     :post-command-hooks '()
                     :screen nil
                     :display-line-cache '()))

(defvar *last-command*)
(defvar *this-command*)
(defvar *last-character*)
(defvar *this-character*)
(defvar *last-chord*)
(defvar *this-chord*)
(defvar *minibuffer*)
(defvar *minibuffer-key-map*)

(defvar *editor*)

(defgeneric dispatch-event (editor event)
  (:method (editor event)))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:window-activation-event))
  (setf (mezzanine.gui.widgets:activep (frame editor)) (mezzanine.gui.compositor:state event))
  (mezzanine.gui.widgets:draw-frame (frame editor)))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:mouse-event))
  (handler-case
      (mezzanine.gui.widgets:frame-mouse-event (frame editor) event)
    (mezzanine.gui.widgets:close-button-clicked ()
      (throw 'quit nil))))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:window-close-event))
  (declare (ignore editor event))
  (throw 'quit nil))

(defmethod dispatch-event (editor (event mezzanine.gui.compositor:key-event))
  (when (not (mezzanine.gui.compositor:key-releasep event))
    (throw 'next-character
      (if (mezzanine.gui.compositor:key-modifier-state event)
          ;; Force character to uppercase when a modifier key is active, gets
          ;; around weirdness in how character names are processed.
          ;; #\C-a and #\C-A both parse as the same character (C-LATIN_CAPITAL_LETTER_A).
          (sys.int::make-character (char-code (char-upcase (mezzanine.gui.compositor:key-key event)))
                                   :control (find :control (mezzanine.gui.compositor:key-modifier-state event))
                                   :meta (find :meta (mezzanine.gui.compositor:key-modifier-state event))
                                   :super (find :super (mezzanine.gui.compositor:key-modifier-state event))
                                   :hyper (find :hyper (mezzanine.gui.compositor:key-modifier-state event)))
          (mezzanine.gui.compositor:key-key event)))))

(defun editor-read-char-1 ()
  (catch 'next-character
    (when (pending-event *editor*)
      (let ((event (pending-event *editor*)))
        (setf (pending-event *editor*) nil)
      (dispatch-event *editor* event)))
    (when (pending-redisplay *editor*)
      (throw 'next-character nil))
    (loop
       (dispatch-event *editor* (mezzanine.supervisor:fifo-pop (fifo *editor*))))))

(defun editor-read-char ()
  (loop
     (let ((ch (editor-read-char-1)))
       (when ch
         (return ch)))
     (setf (pending-redisplay *editor*) (not (redisplay)))))

(define-condition pending-input () ())

(defun check-pending-input ()
  (cond ((pending-event *editor*)
         (signal 'pending-input))
        (t (let ((event (mezzanine.supervisor:fifo-pop (fifo *editor*) nil)))
             (when event
               (setf (pending-event *editor*) event)
               (signal 'pending-input))))))

(defun refresh-title ()
  (let ((buffer (current-buffer *editor*)))
    (setf (mezzanine.gui.widgets:frame-title (frame *editor*))
          (format nil "Editor - ~A~A"
                  (or (buffer-property buffer 'name) "Untitled")
                  (cond ((buffer-property buffer 'new-file)
                         " (New file)")
                        ((buffer-modified buffer)
                         " (Modified)")
                        (t ""))))
    (mezzanine.gui.widgets:draw-frame (frame *editor*))))

(defun switch-to-buffer (buffer)
  (setf (current-buffer *editor*) buffer
        (pending-redisplay *editor*) t)
  (refresh-title))

;;; Mark management.

(defun make-mark (line charpos &optional kind)
  (setf kind (or kind :temporary))
  (check-type kind (member :left :right :temporary))
  (let ((mark (make-instance 'mark
                             :line line
                             :charpos charpos
                             :kind kind)))
    (unless (eql kind :temporary)
      (push mark (line-mark-list line)))
    mark))

(defmethod (setf mark-line) (value (mark mark))
  (unless (eql (mark-kind mark) :temporary)
    (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark))))
    (push mark (line-mark-list value)))
  (setf (slot-value mark '%charpos) (min (line-length value) (mark-charpos mark))
        (slot-value mark '%line) value))

(defmethod (setf mark-charpos) (value (mark mark))
  (check-type value (integer 0))
  (assert (<= value (line-length (mark-line mark))) (value) "Tried to move mark past end of line.")
  (setf (slot-value mark '%charpos) value))

(defmethod (setf mark-kind) (value (mark mark))
  (check-type value (member :temporary :left :right))
  (unless (eql (mark-kind mark) :temporary)
    ;; Remove from existing mark list.
    (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark)))))
  (unless (eql value :temporary)
    ;; Add to mark list.
    (push mark (line-mark-list (mark-line mark))))
  (setf (slot-value mark '%kind) value))

(defun copy-mark (mark &optional kind)
  (make-mark (mark-line mark) (mark-charpos mark) kind))

(defun delete-mark (mark)
  (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark)))))

(defmacro with-mark ((name where &optional kind) &body body)
  `(let ((,name nil))
     (unwind-protect
          (progn
            (setf ,name (copy-mark ,where ,kind))
            ,@body)
       (when ,name
         (delete-mark ,name)))))

(defun move-mark-to-mark (move-this-one here)
  (setf (mark-line move-this-one) (mark-line here)
        (mark-charpos move-this-one) (mark-charpos here)))

(defun mark= (a b)
  (and (eql (mark-line a) (mark-line b))
       (eql (mark-charpos a) (mark-charpos b))))

(defun mark< (a b)
  (or (< (line-number (mark-line a)) (line-number (mark-line b)))
      (and (eql (line-number (mark-line a)) (line-number (mark-line b)))
           (< (mark-charpos a) (mark-charpos b)))))

(defun mark> (a b)
  (mark< b a))

(defun mark<= (a b)
  (not (mark> a b)))

(defun mark>= (a b)
  (not (mark< a b)))

(defun point-to-mark (buffer mark)
  (move-mark-to-mark (buffer-point buffer) mark))

(defun mark-to-point (buffer mark)
  (move-mark-to-mark mark (buffer-point buffer)))

(defun mark-at-point-p (buffer mark)
  (mark= mark (buffer-point buffer)))

(defun start-of-line-p (mark)
  (eql (mark-charpos mark) 0))

(defun end-of-line-p (mark)
  (eql (mark-charpos mark) (line-length (mark-line mark))))

;;; Sub-editor. Buffer manipulation.

(defun buffer-modified (buffer)
  (buffer-property buffer 'modified))

(defun (setf buffer-modified) (value buffer)
  (when (not (eql (buffer-property buffer 'modified) value))
    (setf (buffer-property buffer 'modified) value)
    (refresh-title))
  value)

(defconstant +line-number-increment+ 10000)

(defun fully-renumber-lines-from (line)
  (do ((l line (next l)))
      ((null l))
    (setf (line-number line) (+ (line-number (prev line)) +line-number-increment+))))

(defun insert-line (point)
  "Insert a new line at POINT, splitting the current line if needed.
Don't use this, use INSERT instead."
  (let* ((current-line (mark-line point))
         (current-charpos (mark-charpos point))
         (new-line (make-instance 'line
                                  :buffer (line-buffer current-line)
                                  :next (next-line current-line)
                                  :prev current-line
                                  :data (make-array (- (line-length current-line)
                                                       current-charpos)
                                                    :element-type 'character
                                                    :adjustable t
                                                    :fill-pointer t))))
    ;; Update line contents.
    (replace (data new-line) (data current-line)
             :start2 current-charpos)
    (setf (fill-pointer (data current-line)) current-charpos)
    (incf (line-version current-line))
    ;; Link into the line list.
    (cond ((next-line current-line)
           (setf (previous-line (next-line current-line)) new-line))
          ((line-buffer current-line)
           (setf (last-line (line-buffer current-line)) new-line)))
    (setf (next-line current-line) new-line)
    ;; Ensure coherent numbering.
    (cond ((and (next-line new-line)
                (eql (1+ (line-number current-line)) (line-number (next-line new-line))))
           ;; No numbers between. Give up and renumber everything from the new line forward.
           ;; Could be smarter.
           (fully-renumber-lines-from new-line))
          ((next-line new-line)
           ;; Midway between the previous (current) and the next line.
           (setf (line-number new-line) (+ (line-number current-line)
                                           (truncate (- (line-number (next-line new-line)) (line-number current-line)) 2))))
          (t (setf (line-number new-line) (+ (line-number current-line) +line-number-increment+))))
    ;; Update marks.
    (dolist (mark (line-mark-list current-line))
      (when (or (and (eql (mark-kind mark) :right)
                     (eql (mark-charpos mark) current-charpos))
                (> (mark-charpos mark) current-charpos))
        (let ((real-pos (- (line-length current-line) (mark-charpos mark))))
          (setf (mark-line mark) new-line
                (mark-charpos mark) real-pos))))
    ;; Mark buffer modified (if any).
    (when (line-buffer current-line)
      (setf (buffer-modified (line-buffer current-line)) t)))
  (values))

(defun insert-char (point character)
  "Insert CHARACTER at POINT.
Don't use this directly, use INSERT instead."
  (let* ((current-line (mark-line point))
         (current-charpos (mark-charpos point)))
    (cond ((eql (line-length current-line) current-charpos)
           ;; Inserting at end.
           (vector-push-extend character (data current-line)))
          (t ;; Inserting in the middle or at the start.
           ;; Make sure the vector is long enough.
           (vector-push-extend character (data current-line))
           (replace (data current-line) (data current-line)
                    :start1 (1+ current-charpos)
                    :start2 current-charpos)
           (setf (aref (data current-line) current-charpos) character)))
    (incf (line-version current-line))
    ;; Update marks.
    (dolist (mark (line-mark-list current-line))
      (when (or (and (eql (mark-kind mark) :right)
                     (eql (mark-charpos mark) current-charpos))
                (> (mark-charpos mark) current-charpos))
        (incf (mark-charpos mark))))
    ;; Mark buffer modified (if any).
    (when (line-buffer current-line)
      (setf (buffer-modified (line-buffer current-line)) t)))
  (values))

(defun insert (buffer string)
  "Insert STRING into BUFFER at point. STRING is a string-designator, so can be a character."
  (loop for ch across (string string)
     if (char= ch #\Newline)
     do (insert-line (buffer-point buffer))
     else do (insert-char (buffer-point buffer) ch)))

(defun order-marks (mark-1 mark-2)
  (let ((line-1 (mark-line mark-1))
        (line-2 (mark-line mark-2)))
    (cond ((eql line-1 line-2)
           (if (> (mark-charpos mark-1) (mark-charpos mark-2))
               (values mark-2 mark-1)
               (values mark-1 mark-2)))
          ((> (line-number line-1)
              (line-number line-2))
           (values mark-2 mark-1))
          (t (values mark-1 mark-2)))))

(defun insert-region-at-mark (point mark-1 mark-2)
  (setf (values mark-1 mark-2) (order-marks mark-1 mark-2))
  (let ((line-1 (mark-line mark-1))
        (chpos-1 (mark-charpos mark-1))
        (line-2 (mark-line mark-2))
        (chpos-2 (mark-charpos mark-2))
        (insert-line (mark-line point))
        (insert-chpos (mark-charpos point)))
    (cond ((eql line-1 line-2)
           ;; Not inserting any newlines, just make the line bigger.
           (when (not (eql chpos-1 chpos-2))
             (adjust-array (data insert-line)
                           (+ insert-chpos (- chpos-2 chpos-1))
                           :fill-pointer t)
             (when (not (eql (line-length insert-line) insert-chpos))
               ;; Inserting in the middle, need to shuffle data up.
               (replace (data insert-line) (data insert-line)
                        :start1 (+ insert-chpos (- chpos-2 chpos-1))
                        :start2 insert-chpos))
             ;; Insert new data into the hole.
             (replace (data insert-line) (data line-1)
                      :start1 insert-chpos
                      :start2 chpos-1
                      :end2 chpos-2)
             (incf (line-version insert-line))
             ;; Update marks.
             (dolist (mark (line-mark-list insert-line))
               (when (or (and (eql (mark-kind mark) :right)
                              (eql (mark-charpos mark) insert-chpos))
                         (> (mark-charpos mark) insert-chpos))
                 (incf (mark-charpos mark) (- chpos-2 chpos-1))))
             ;; Mark buffer modified (if any).
             (when (line-buffer line-1)
               (setf (buffer-modified (line-buffer line-1)) t))))
          (t ;; Inserting multiple lines.
           ;; todo properly...
           (do ((m1 (copy-mark mark-1))
                (m2 (copy-mark mark-2)))
               ((mark= m1 m2))
             (if (end-of-line-p m1)
                 (insert-line point)
                 (insert-char point (line-character (mark-line m1) (mark-charpos m1))))
             (move-mark m1))))))

(defun insert-region (buffer mark-1 mark-2)
  (insert-region-at-mark (buffer-point buffer)
                         mark-1 mark-2))

(defun yank-region (buffer)
  (when (killed-region *editor*)
    (insert-region buffer (car (killed-region *editor*)) (cdr (killed-region *editor*)))))

(defun delete-region (buffer mark-1 mark-2)
  "Delete region designated by MARK-1 and MARK-2 from buffer.
Returns the deleted region as a pair of marks into a disembodied line."
  (setf (values mark-1 mark-2) (order-marks mark-1 mark-2))
  (cond ((eql (mark-line mark-1) (mark-line mark-2))
         ;; Same line.
         (let* ((line (mark-line mark-1))
                (start (mark-charpos mark-1))
                (end (mark-charpos mark-2))
                (data (make-array (- end start)
                                  :element-type 'character
                                  :adjustable t
                                  :fill-pointer t)))
           ;; Extract deleted data.
           (replace data (data line)
                    :start2 start
                    :end2 end)
           ;; Delete data.
           (replace (data line) (data line)
                    :start1 start
                    :start2 end)
           (decf (fill-pointer (data line)) (- end start))
           ;; Update version.
           (incf (line-version line))
           ;; Update marks.
           (dolist (mark (line-mark-list line))
             (when (> (mark-charpos mark) start)
               (decf (mark-charpos mark) (- end start))))
           ;; Mark buffer modified (if any).
           (when (line-buffer line)
             (setf (buffer-modified (line-buffer line)) t))
           ;; Done.
           (let ((new-line (make-instance 'line :data data)))
             (values (make-mark new-line 0 :left)
                     (make-mark new-line (length data) :right)))))
        (t ;; Different lines.
         (let* ((first-line (mark-line mark-1))
                (first-chpos (mark-charpos mark-1))
                (next-line (next-line first-line))
                (last-line (mark-line mark-2))
                (last-chpos (mark-charpos mark-2))
                (data (make-array (- (line-length first-line) first-chpos)
                                  :element-type 'character
                                  :adjustable t
                                  :fill-pointer t)))
           (replace data (data first-line) :start2 first-chpos)
           ;; Join lines together.
           (adjust-array (data first-line)
                         (+ first-chpos
                            (- (line-length last-line) last-chpos))
                         :fill-pointer t)
           (replace (data first-line) (data last-line)
                    :start1 first-chpos
                    :start2 last-chpos)
           (incf (line-version first-line))
           (incf (line-version last-line))
           ;; Unlink intermediate lines & the last line from the line list.
           (cond ((next-line last-line)
                  (setf (previous-line (next-line last-line)) first-line))
                 (t (setf (last-line buffer) first-line)))
           (setf (next-line first-line) (next-line last-line))
           (setf (next-line last-line) nil
                 (line-buffer last-line) nil
                 (fill-pointer (data last-line)) last-chpos)
           ;; Adjust first-line marks.
           (dolist (mark (line-mark-list first-line))
             (when (> (mark-charpos mark) first-chpos)
               (setf (mark-charpos mark) first-chpos)))
           ;; Adjust last-line marks.
           (dolist (mark (line-mark-list last-line))
             (let ((new-pos (+ first-chpos (max 0 (- (mark-charpos mark) last-chpos)))))
               (setf (mark-line mark) first-line
                     (mark-charpos mark) new-pos)))
           ;; Adjust middle marks and fix lines.
           (do ((line next-line (next-line line)))
               ((eql line last-line))
             (incf (line-version line))
             (setf (line-buffer line) nil)
             (dolist (mark (line-mark-list line))
               (setf (mark-line mark) first-line
                     (mark-charpos mark) first-chpos)))
           ;; Mark buffer modified (if any).
           (when (line-buffer first-line)
             (setf (buffer-modified (line-buffer first-line)) t))
           ;; Done.
           (let ((new-line (make-instance 'line
                                          :data data
                                          :next next-line)))
             (setf (previous-line next-line) new-line)
             (values (make-mark new-line 0 :left)
                     (make-mark last-line last-chpos :right)))))))

(defun kill-region (buffer mark-1 mark-2)
  (multiple-value-bind (first-mark last-mark)
      (delete-region buffer mark-1 mark-2)
    (when (or (not (mark= first-mark last-mark))
              (eql *last-command* 'kill-region))
      (setf *this-command* 'kill-region))
    (cond ((and (killed-region *editor*)
                (eql *last-command* 'kill-region))
           ;; Append to killed region.
           (insert-region-at-mark (cdr (killed-region *editor*))
                                  first-mark last-mark))
          (t ;; New killed region.
           (setf (killed-region *editor*) (cons first-mark last-mark))))))

(defun kill-line (buffer)
  "Kill from point to the end of the line. If the point is at the end of the line,
then merge the current line and next line."
  (let ((point (buffer-point buffer)))
    (with-mark (here point :left)
      (if (end-of-line-p point)
          (move-mark point)
          (move-end-of-line buffer))
      (unwind-protect
           (kill-region buffer here point)
        (point-to-mark buffer here))))
  (values))

(defun delete-char (buffer &optional (n 1))
  "Delete the following N characters (previous if N is negative)."
  (let ((point (buffer-point buffer)))
    (with-mark (here point :left)
      (move-mark point n)
      (unwind-protect
           (delete-region buffer here point)
        (point-to-mark buffer here))))
  (values))

(defun buffer-string (buffer mark-1 mark-2)
  (setf (values mark-1 mark-2) (order-marks mark-1 mark-2))
  (with-output-to-string (str)
    (do ((m1 (copy-mark mark-1))
         (m2 (copy-mark mark-2)))
        ((mark= m1 m2))
      (if (end-of-line-p m1)
          (terpri str)
          (write-char (line-character (mark-line m1) (mark-charpos m1)) str))
      (move-mark m1))))

;;; Point motion.

(defun move-beginning-of-line (buffer)
  (setf (mark-charpos (buffer-point buffer)) 0)
  (values))

(defun move-end-of-line (buffer)
  (let ((point (buffer-point buffer)))
    (setf (mark-charpos point) (line-length (mark-line point))))
  (values))

(defun move-beginning-of-buffer (buffer)
  (setf (mark-line (buffer-point buffer)) (first-line buffer)
        (mark-charpos (buffer-point buffer)) 0)
  (values))

(defun move-end-of-buffer (buffer)
  (let ((point (buffer-point buffer)))
    (setf (mark-line point) (last-line buffer)
          (mark-charpos point) (line-length (mark-line point))))
  (values))

(defun move-mark (mark &optional (n 1))
  "Move MARK forward by N character. Move backwards if N is negative.
Returns false when the mark reaches the start or end of the buffer, true otherwise."
  (cond ((minusp n)
         (setf n (- n))
         (dotimes (i n)
           (let ((current-line (mark-line mark)))
             (cond ((zerop (mark-charpos mark))
                    (cond ((previous-line current-line)
                           ;; At start of line.
                           (setf (mark-line mark) (previous-line current-line)
                                 (mark-charpos mark) (line-length (previous-line current-line))))
                          (t ;; At start of buffer.
                           (return-from move-mark nil))))
                   (t ;; Moving within a line.
                    (decf (mark-charpos mark)))))))
        (t
         (dotimes (i n)
           (let ((current-line (mark-line mark)))
             (cond ((eql (line-length current-line) (mark-charpos mark))
                    (cond ((next-line current-line)
                           ;; At end of line.
                           (setf (mark-line mark) (next-line current-line)
                                 (mark-charpos mark) 0))
                          (t (return-from move-mark nil))))
                   (t ;; Moving within a line.
                    (incf (mark-charpos mark))))))))
  t)

(defun move-char (buffer &optional (n 1))
  "Move point forward by N characters. Move backwards if N is negative."
  (move-mark (buffer-point buffer) n)
  (values))

(defun move-line (buffer &optional (n 1))
  "Move point down by N lines. N may be negative.
Tries to stay as close to the hint column as possible."
  (let* ((accessor #'next-line)
         (point (buffer-point buffer)))
    (when (not (eql *last-command* 'next-line))
      (setf (buffer-property buffer 'column-hint 0) (mark-charpos point)))
    (setf *this-command* 'next-line)
    (when (minusp n)
      (setf n (- n)
            accessor #'previous-line))
    (dotimes (i n)
      (let* ((current-line (mark-line point))
             (new-line (funcall accessor current-line)))
        (cond (new-line
               (setf (mark-line point) new-line
                     (mark-charpos point) (min (buffer-property buffer 'column-hint)
                                               (line-length new-line))))
              (t (return))))))
  (values))

(defun character-right-of (mark)
  (cond ((end-of-line-p mark)
         (cond
           ((next-line (mark-line mark))
            ;; At end of line.
            #\Newline)
           (t ;; At end of buffer.
            nil)))
        (t (line-character (mark-line mark) (mark-charpos mark)))))

(defun character-left-of (mark)
  (cond ((start-of-line-p mark)
         (cond
           ((previous-line (mark-line mark))
            ;; At start of line.
            #\Newline)
           (t ;; At start of buffer.
            nil)))
        (t (line-character (mark-line mark) (1- (mark-charpos mark))))))

(defun scan (mark predicate jump key)
  (loop
     (let ((ch (funcall key mark)))
       (when (not ch)
         (return nil))
       (when (funcall predicate ch)
         (return t))
       (when (not (move-mark mark jump))
         (return nil)))))

(defun scan-forward (mark predicate)
  (scan mark predicate 1 #'character-right-of))

(defun scan-backward (mark predicate)
  (scan mark predicate -1 #'character-left-of))

(defun move-word (buffer &optional (n 1))
  "Move point forward by N words. N may be negative."
  (let ((point (buffer-point buffer))
        (fn #'scan-forward))
    (when (minusp n)
{'fraction_non_alphanumeric': 0.13951172612711601, 'fraction_numerical': 0.0051333997184356, 'mean_word_length': 2.0969268396427054, 'pattern_counts': {'":': 0, '<': 17, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 66, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1395398', 'n_tokens_mistral': 18071, 'n_tokens_neox': 17540, 'n_words': 5074}