(in-package :editor)

(defun linewise ()
  b-vim-linewise)

(defun exclusive ()
  b-vim-exclusive)

(defun inclusive ()
  (not b-vim-exclusive))

(defun (setf linewise) (val)
  (setf b-vim-linewise val))

(defun (setf exclusive) (val)
  (setf b-vim-exclusive val))

(defun (setf inclusive) (val)
  (setf b-vim-exclusive (not val)))

(defun just-blanks (start end)
  "Returns T if the characters from start to end are spaces."
  (loop for ch across (points-to-string start end)
        if (not (eql ch #\Space))
        do (return nil)
        finally (return t)))

(defun blanks-before (point)
  (with-point ((bol point :temporary))
    (line-start bol)
    (just-blanks bol point)))

(defun blanks-after (point)
  (with-point ((eol point :temporary))
    (line-end eol)
    (just-blanks point eol)))

(defun scroll-line-to-place (line-num place)
  (when line-num
    (move-point (current-point) (buffers-start (current-buffer)))
    ;; This seems like it could be a fairly expensive operation.  Hope not.
    (line-offset (current-point) (1- line-num)))
  (with-point ((point (current-point)))
    (setf point 
          (ecase place
            (:top point)
            (:middle
             (line-offset point
                          (- (floor (window-height (current-window))
                                    2))))
            (:bottom
             (line-offset point
                          (- 1 (window-height (current-window)))))))
    (if point
      (line-start point)
      (setf point (buffers-start (current-buffer))))
    (when point
      (move-point (window-display-start (current-window))
                  point))))

(def-vim-char-attribute :whitespace '(#\Space #\Return #\Newline #\Tab))
(def-vim-char-attribute :keyword
  (loop for ch across "-_0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
        collect ch))
(def-vim-char-attribute :filename
  (loop for ch across "0123456789/\\.-_+,#$%{}[]:abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!~="
        collect ch))

(defmethod vim-char-attribute ((type symbol) &optional (point (current-point)))
  (member (next-character point) (gethash type b-vim-char-attributes)))
(defmethod vim-char-attribute ((test function) &optional (point (current-point)))
  (funcall test (next-character point)))
(defmethod vim-char-attribute ((types list) &optional (point (current-point)))
  (let* ((invert-p (eql (car types) :not))
         (types (if invert-p (cdr types) types)))
    (loop for type in types
          if (vim-char-attribute type point)
          return (not invert-p)
          finally return invert-p)))

(defun vim-find-attribute (forward attributes &optional (point (current-point)))
  (with-point ((started-at point))
    (let ((offset (if forward 1 -1)))
      (loop while (and (not (vim-char-attribute attributes point))
                       (character-offset point offset)))
      (and (point/= started-at point)
           (vim-char-attribute attributes point)))))

(defun xor (x y)
  (or (and x (not y))
      (and y (not x))))

(defun white-p (point)
  (vim-char-attribute :whitespace point))

(defun skip-white (point forward)
  (if (white-p point)
    (vim-find-attribute forward '(:not :whitespace) point)
    t))

(defun skip-non-white (point forward)
  (if (white-p point)
    t
    (vim-find-attribute forward :whitespace point)))

;; FIXME: optimize this a bit so we're not creating several new functions
;; every time we call with-move.  Discussion: the only way to do that
;; that I can see is change all the functions in the LABELS to macros.
;; I think, for now, I won't worry about it.
(defmacro with-move ((forward point &key (word-type :keyword)) &body body)
  (rebinding (forward point word-type)
    (with-unique-names (limit limit-test)
      `(block with-move
         (let ((,limit nil)
               (,limit-test (if ,forward #'point<= #'point>=)))
           (macrolet ((must (&body body)
                        `(let ((res (and ,@body)))
                           (if (and res (test-limit))
                             res
                             (return-from with-move nil)))))
             (labels ((set-point (new-point)
                        (setf ,point new-point))
                      (set-direction (new-direction)
                        (setf ,forward new-direction))
                      (test-limit ()
                        (or (not ,limit)
                            (funcall ,limit-test point ,limit)))
                      (line-limit (point)
                        (if ,forward
                          (line-end point)
                          (line-start point)))
                      (set-limit (limit-point)
                        (setf ,limit limit-point))
                      (go-forward ()
                        (setf ,forward t))
                      (u-turn ()
                        (setf ,forward (not ,forward)))
                      (invert (list)
                        (if (eql (car list) :not)
                          (cdr list)
                          (cons :not list)))
                      (skip-current ()
                        (loop for attrib in '((:whitespace)
                                              (,word-type)
                                              (:not :whitespace ,word-type))
                              until (vim-char-attribute attrib ,point)
                              finally return (must (vim-find-attribute ,forward (invert attrib) ,point))))
                      (fix-endp (endp)
                        (if endp
                          (must (character-offset ,point (if ,forward -1 1)))
                          t))
                      (boundary (&optional endp)
                        (must (skip-current)
                              (fix-endp endp)))
                      (skip (&rest attribute)
                        (let ((inverted-attribute (invert attribute)))
                          (or (vim-char-attribute inverted-attribute ,point)
                              (must (vim-find-attribute ,forward inverted-attribute ,point)))))
                      (bump ()
                        (must (character-offset ,point (if ,forward 1 -1))))
                      (unbump ()
                        (must (character-offset ,point (if ,forward -1 1))))
                      (find (attribute &optional endp)
                        (skip (invert attribute))
                        (fix-endp endp))
                      (go-here ()
                        (move-point (current-point) point)))
               ,@body)))))))

(defgeneric vim-offset (n type forward point &key &allow-other-keys))
(defmethod vim-offset (count (type (eql :word)) forward point &key end (word-type :keyword))
  (setf count (or count 1))
  (loop for n below count
        while
        ; This code highlights that e & b are inverses of each other, and
        ; w and ge are inverses of each other.  That is, e & b do the same
        ; things in opposite directions; same for w and ge.
        (with-move (forward point :word-type word-type)
          (cond ((xor forward end)
                 (boundary)
                 (skip :whitespace))
                (t (bump)
                   (skip :whitespace)
                   (boundary :end))))
        finally return (= n count)))

(defmethod vim-offset (count (type (eql :bigword)) forward point &key end)
  (flet ((move ()
           (with-move (forward point)
             (cond ((xor forward end)
                    (skip :not :whitespace)
                    (skip :whitespace))
                   (t (bump)
                      (skip :whitespace)
                      (skip :not :whitespace)
                      (unbump))))))
    (setf count (or count 1))
    (loop for n below count
          while (move)
          finally return (= n count))))

(defun current-word (&optional (word-type :keyword) (point (current-point)))
  (unless (listp word-type)
    (setf word-type (list word-type)))
  (with-point ((start point)
               (end point))
    (with-move (t start)
      (find word-type)
      (u-turn)
      (find (invert word-type) :end)
      (move-point end start)
      (go-forward)
      (set-point end)
      (find (invert word-type))
      (points-to-string start end))))

(defun move-over-word (p type end)
  (vim-offset 1 type nil b-vim-point-before-movement)
  (vim-offset (or p 1) type t (current-point) :end end))

(defun vim-read-a-character ()
  (gesture-to-simple-char
   (prompt-for-character* "Character: " t)))

(defun vim-find-char (forward p &key (ch (vim-read-a-character)) leave-before save)
  (when save
    (setf *vim-last-find-char* (list forward ch leave-before (exclusive))))
  (setf p (or p 1))
  (with-point ((point (current-point))
               (limit (current-point)))
    (with-move (forward point)
      (set-limit (line-limit limit))
      (bump)
      (loop count (equal ch (next-character point)) into count
            if (= count p)
            return t
            else do (bump))
      (when leave-before (unbump))
      (go-here))))

(defun vim-repeat-last-find (p &key invert)
  (destructuring-bind (forward ch leave-before exclusive) *vim-last-find-char*
    (cond (invert
           (setf (exclusive) (not exclusive))
           (vim-find-char (not forward) p :ch ch :leave-before leave-before))
          (t (setf (exclusive) exclusive)
             (vim-find-char forward p :ch ch :leave-before leave-before)))))

(defun finish-pending-motion (move)
  (let ((saved-vim-movement-pending b-vim-movement-pending))
    (flet ((command (p)
             (setf b-vim-movement-pending saved-vim-movement-pending)
             (move-point b-vim-point-before-movement (current-point))
             (funcall move p)
             (unless (exclusive)
               (character-offset (current-point) 1))
             (funcall *vim-pending-action*
                      b-vim-point-before-movement
                      (current-point))))
      (command nil)
      (setf *vim-last-action* #'command
            *vim-repeat-multiplier* nil
            b-vim-movement-pending nil)
      ; FIXME: (restore-modes)
      (setf (buffer-minor-mode (current-buffer) "Vim Operator Pending") nil)
      (setf (buffer-minor-mode (current-buffer) b-vim-movement-pending-ending-mode) t)
      )))