src/cowl-input.lisp

   1 (in-package #:cowl)
   2
   3 (defclass input (text-button)
   4   ((writer :initarg :writer :type (function (t))
   5            :documentation "Whenever edit mode is left and the text confirmed, this callback is called
   6 with the new string."))
   7   (:documentation "Widget for editable text. "))
   8
   9 ;;; INPUT STATE
  10
  11 (defparameter *focused-widget* nil
  12   "The currently active input widget. If nil, nothing is currently being edited.")
  13 (declaim (type (or input null) *focused-widget*))
  14
  15
  16 (defparameter *edit-mode-cursor-positions* (list 0 0)
  17   "A list of two values of the current cursor position. If the values are different,
  18 this signifies a selection.")
  19 (declaim (type (cons (integer 0) (cons (integer 0) null)) *edit-mode-cursor-positions*))
  20
  21 (defparameter *edit-mode-cursor-blink-state* t
  22   "Whether the cursor is currently blinked on or off")
  23 (declaim (type boolean *edit-mode-cursor-blink-state*))
  24
  25 (defparameter *edit-mode-cursor-blink-time* (/ internal-time-units-per-second 2)
  26   "Setting for how long the cursor should blink before toggling")
  27
  28 (defparameter *edit-mode-cursor-blink-last-change* 0
  29   "Current time of the last state change of blink")
  30
  31 (defparameter *edit-mode-text-memento* "You should never see this"
  32   "The text before we entered edit-mode (for reverting back if the user cancels editing)")
  33 (declaim (type string *edit-mode-text-memento*))
  34
  35 (defparameter *edit-mode-drag-anchors* nil
  36   "If not-nil, the first is the initial position of the drag and the second
  37 Or nil if there is no drag currently happening.")
  38 (declaim (type (or (cons (integer 0) (cons (integer 0) null)) null) *edit-mode-drag-anchors*))
  39
  40 (defparameter *enter-edit-mode-hooks* nil
  41   "A list of functions called BEFORE entering edit mode.
  42 This can be used, eg. for ensuring that a character
  43 reader event handler is registered in the client application.")
  44 (defparameter *leave-edit-mode-hooks* nil
  45   "A list of functions called AFTER leaving edit mode.
  46 This can be used for undoing the effects of
  47 *enter-edit-mode-hooks*, when editing is finished.")
  48
  49 (defmethod accept-focus-p ((input input))
  50   (declare (ignore input))
  51   t)
  52
  53 (defmethod focus ((input input))
  54   "Sets up edit mode with input as the active widget."
  55   (assert (eql input *focused-widget*))
  56   (mapc #'funcall *enter-edit-mode-hooks*)
  57   (setf *edit-mode-text-memento* (text-of *focused-widget*))
  58   (setf *edit-mode-cursor-blink-state* t)
  59   (setf *edit-mode-cursor-blink-last-change* (get-internal-real-time)))
  60
  61 (defmethod finish-edit-mode ((input input) confirm-edit)
  62   "Hook method called after the text input is complete, confirmed or cancelled.
  63 If confirm-edit is true, call the writer callback, else revert text to previous state."
  64   (if confirm-edit
  65       (when (slot-boundp input 'writer)
  66         (funcall (slot-value input 'writer) (text-of input)))
  67       (setf (text-of input) *edit-mode-text-memento*)))
  68
  69 (defmethod blur ((input input))
  70   "Invokes leave-edit-mode."
  71   (assert (eql input *focused-widget*))
  72   (leave-edit-mode t))
  73
  74 (defun leave-edit-mode (&optional (confirm-edit t))
  75   "A command to drop the focused widget out of edit-mode.
  76 Invokes finish-edit-mode."
  77   (declare (type boolean confirm-edit))
  78   (finish-edit-mode *focused-widget* confirm-edit)
  79   (setf *focused-widget* nil)
  80   (mapc #'funcall *leave-edit-mode-hooks*))
  81
  82 (defmethod offset-to-char-x-char-y ((input input) ox oy)
  83   "Converts a cursor offset to a “char coordinate”, of the line and colum number
  84 of wrapped text."
  85   (let* ((iy (max 0 (min (1- (length (lines-of input)))
  86                          (floor oy (ftgl:font-line-height (font-of input))))))
  87          (ix (font-string-character-position (font-of input)
  88                                              (elt (lines-of input) iy)
  89                                              (max 0 (floor ox)))))
  90     ;; (format t "cursor at ~a,~a~%" ix iy)
  91     (cursor-x-y-to-position input ix iy)))
  92
  93 (defun input-selection-drag-mouse-motion (mx my)
  94   "Handler for mouse motion while an input is having a selection dragged."
  95   (destructuring-bind (cx cy) (cumulative-offset-of *focused-widget*)
  96     (let ((x (- mx cx))
  97           (y (- my cy)))
  98       ;; (format t "Dragging at ~a,~a which is ~a,~a offset from ~a,~a~%" (glfw:get-mouse-pos) x y cx cy)
  99       (setf (second *edit-mode-drag-anchors*)
 100             (offset-to-char-x-char-y *focused-widget* x y))
 101       (setf (edit-mode-cursor-positions) *edit-mode-drag-anchors*)))
 102   t)
 103
 104 ;; ?? mouse-button-handlers mouse-motion-handlers
 105 (defun input-selection-drag-finish (button press x y)
 106   (when (and (not press)
 107              (eql button :left))
 108     (setf *mouse-button-handlers* (delete #'input-selection-drag-finish *mouse-button-handlers*))
 109     (setf *mouse-motion-handlers* (delete #'input-selection-drag-mouse-motion *mouse-motion-handlers*))
 110     t))
 111
 112 (defmethod handle-mouse-button ((input input) button press x y)
 113   (if (and press (eql button :left))
 114       (progn
 115         (focus input)
 116         (setf *edit-mode-drag-anchors*
 117               (make-list 2 :initial-element
 118                          (offset-to-char-x-char-y input
 119                                                   (- x
 120                                                      (before-margin-of (x input))
 121                                                      (before-border-width-of (x input))
 122                                                      (before-padding-of (x input)))
 123                                                   (- y
 124                                                      (before-margin-of (y input))
 125                                                      (before-border-width-of (y input))
 126                                                      (before-padding-of (y input))))))
 127         (setf (edit-mode-cursor-positions) *edit-mode-drag-anchors*)
 128         ;; (format t "anchors: ~a; cursor positions: ~a~%" *edit-mode-drag-anchors* *edit-mode-cursor-positions*)
 129         (pushnew #'input-selection-drag-mouse-motion *mouse-motion-handlers*)
 130         (pushnew #'input-selection-drag-finish *mouse-button-handlers*)
 131         t)
 132       (call-next-method)))
 133
 134
 135 (defun edit-mode-cursor-positions-fix ()
 136   (setf *edit-mode-cursor-positions* (sort *edit-mode-cursor-positions* #'<)
 137         (first *edit-mode-cursor-positions*) (max 0 (first *edit-mode-cursor-positions*))
 138         (second *edit-mode-cursor-positions*) (min (length (text-of *focused-widget*))
 139                                                    (second *edit-mode-cursor-positions*))))
 140
 141 (defun edit-mode-cursor-positions () *edit-mode-cursor-positions*)
 142 (defun (setf edit-mode-cursor-positions) (val)
 143   (when *focused-widget*
 144     (setf *edit-mode-cursor-positions*
 145           (mapcar #'(lambda (val) (mod val (1+ (length (text-of *focused-widget*)))))
 146                   (if (listp val) val (list val val)))))
 147   (edit-mode-cursor-positions-fix)
 148   val)
 149
 150
 151 (defun cursor-position (cursor-index)
 152   (let ((lines-length 0))
 153     (loop for line in (lines-of *focused-widget*)
 154        for i from 0
 155        do
 156        (when (and (>= cursor-index lines-length)
 157                   (<= cursor-index (+ (length line) lines-length)))
 158          (return-from cursor-position (list (- cursor-index lines-length) i)))
 159        (incf lines-length (length line)))
 160     (list (length (car (last (lines-of *focused-widget*))))
 161           (1- (length (lines-of *focused-widget*))))))
 162
 163 (defun edit-mode-update-cursor-blink ()
 164   (when (> (- (get-internal-real-time)
 165               *edit-mode-cursor-blink-last-change*)
 166            *edit-mode-cursor-blink-time*)
 167     (setf *edit-mode-cursor-blink-last-change* (get-internal-real-time)
 168           *edit-mode-cursor-blink-state* (not *edit-mode-cursor-blink-state*)))
 169   *edit-mode-cursor-blink-state*)
 170
 171 (defmethod detach ((input input))
 172   (when (eql input *focused-widget*)
 173     (leave-edit-mode nil)))
 174
 175 (defmethod draw-cursor ((input input))
 176   (gl:disable gl:+texture-2d+)
 177   (apply #'gl:color-4f (foreground-colour-of input))
 178   (if (apply #'= *edit-mode-cursor-positions*)
 179       (progn
 180         (unless (edit-mode-update-cursor-blink)
 181           (return-from draw-cursor))
 182         (gl:begin gl:+lines+))
 183       (gl:begin gl:+quads+))
 184   (labels ((cursor-x-offset (cursor-pos)
 185              (destructuring-bind (cursor-x cursor-y) cursor-pos
 186                (font-string-cursor-offset
 187                 (font-of input)
 188                 (elt (lines-of input) cursor-y)
 189                 cursor-x)))
 190            (cursor-y-offset (cursor-pos)
 191              (* (second cursor-pos) (ftgl:font-line-height (font-of input))))
 192            (vertex-pair (cursor-pos &optional down)
 193              (let ((cursor-x-offset (cursor-x-offset cursor-pos))
 194                    (cursor-y-offset (cursor-y-offset cursor-pos)))
 195                (if down
 196                    (progn
 197                      (gl:vertex-2f cursor-x-offset cursor-y-offset)
 198                      (gl:vertex-2f cursor-x-offset (+ cursor-y-offset (ftgl:font-line-height (font-of input)))))
 199                    (progn
 200                      (gl:vertex-2f cursor-x-offset (+ cursor-y-offset (ftgl:font-line-height (font-of input))))
 201                      (gl:vertex-2f cursor-x-offset cursor-y-offset))))))
 202
 203     (let ((cursor-pos-front (cursor-position (first *edit-mode-cursor-positions*))))
 204       (vertex-pair cursor-pos-front t)
 205       (unless (apply #'= *edit-mode-cursor-positions*)
 206         (let ((cursor-pos-back (cursor-position (second *edit-mode-cursor-positions*))))
 207           (do ((i (second cursor-pos-front) (1+ i)))
 208               ((>= i (second cursor-pos-back)))
 209             (vertex-pair (list (length (elt (lines-of *focused-widget*) i)) i))
 210             (vertex-pair (list 0 (1+ i)) t))
 211           (vertex-pair cursor-pos-back)))))
 212   (gl:end))
 213
 214 (defmethod draw ((input input))
 215   (when (eql input *focused-widget*)
 216     (draw-cursor input))
 217   (call-next-method))
 218
 219 (defun string-insert (string replacement position)
 220   "Returns a string with the character at the position, or between the cons pair of positions, in string."
 221   (cond
 222     ((typep position '(cons integer (cons integer null)))
 223      (concatenate 'string
 224                   (subseq string 0 (first position))
 225                   replacement
 226                   (subseq string (second position))))
 227     ((typep position 'integer)
 228      (concatenate 'string
 229                   (subseq string 0 position)
 230                   replacement
 231                   (subseq string position)))))
 232
 233 (defmethod (setf text-of) (val (input input))
 234   (call-next-method)
 235   (when *focused-widget*
 236     (setf (edit-mode-cursor-positions)
 237           (list (max (first *edit-mode-cursor-positions*) (length val))
 238                 (max (second *edit-mode-cursor-positions*) (length val))))
 239     (when *edit-mode-drag-anchors*
 240       (setf (first *edit-mode-drag-anchors*) (max (first *edit-mode-drag-anchors*) (length val))
 241             (second *edit-mode-drag-anchors*) (max (second *edit-mode-drag-anchors*) (length val))))))
 242
 243 (defun edit-mode-backspace-text ()
 244   (unless (apply #'= (cons 0 *edit-mode-cursor-positions*))
 245     (setf (first *edit-mode-cursor-positions*)
 246           (min (first *edit-mode-cursor-positions*)
 247                (1- (second *edit-mode-cursor-positions*))))
 248     (with-accessors ((text text-of)) *focused-widget*
 249       (psetf text (string-insert text nil *edit-mode-cursor-positions*)
 250              (edit-mode-cursor-positions) (first *edit-mode-cursor-positions*)))))
 251
 252 (defun edit-mode-delete-text ()
 253   (with-accessors ((text text-of)) *focused-widget*
 254     (unless (apply #'= (cons (length text) *edit-mode-cursor-positions*))
 255       (setf (second *edit-mode-cursor-positions*)
 256             (max (second *edit-mode-cursor-positions*)
 257                  (1+ (first *edit-mode-cursor-positions*))))
 258       (psetf text (string-insert text nil *edit-mode-cursor-positions*)
 259              (edit-mode-cursor-positions) (first *edit-mode-cursor-positions*)))))
 260
 261 (defun edit-mode-insert-text (char)
 262   (with-accessors ((text text-of)) *focused-widget*
 263     (psetf text (string-insert text (list char) *edit-mode-cursor-positions*)
 264            (edit-mode-cursor-positions) (1+ (first *edit-mode-cursor-positions*)))))
 265
 266 (defun edit-mode-backwards-word (position)
 267   (if (zerop position)
 268       0
 269       (or (position-if #'blankp (text-of *focused-widget*) :from-end t :end position)
 270           0)))
 271
 272 (defun edit-mode-forwards-word (position)
 273   (if (= position (length (text-of *focused-widget*)))
 274       (length (text-of *focused-widget*))
 275       (or (position-if #'blankp (text-of *focused-widget*) :start (1+ position))
 276           (length (text-of *focused-widget*)))))
 277
 278 (defun edit-mode-move-line (position delta)
 279   (destructuring-bind (cx cy) (cursor-position position)
 280     (let ((x-offset (font-string-cursor-offset (font-of *focused-widget*)
 281                                                (elt (lines-of *focused-widget*)
 282                                                     cy)
 283                                                cx)))
 284       (setf cy (mod (+ cy delta) (length (lines-of *focused-widget*))))
 285       (+ (loop for i below cy for line in (lines-of *focused-widget*)
 286             summing (length line))
 287          (font-string-character-position (font-of *focused-widget*)
 288                                          (elt (lines-of *focused-widget*) cy)
 289                                          x-offset)))))
 290
 291 (defmethod accept-char-p ((input input) character)
 292   (graphic-char-p character))
 293
 294
 295 (defmethod handle-key ((input input) key press)
 296   (when press
 297     (setf *edit-mode-cursor-blink-last-change* (get-internal-real-time)
 298           *edit-mode-cursor-blink-state* t)
 299     (etypecase key
 300       (character
 301        (when (accept-char-p input key)
 302          (edit-mode-insert-text key)))
 303       (symbol
 304        (case key
 305          (:home
 306           (if (intersection *held-keys* '(:lshift :rshift))
 307               (setf (first *edit-mode-cursor-positions*) 0)
 308               (setf (edit-mode-cursor-positions) 0))
 309           t)
 310          (:end
 311           (if (intersection *held-keys* '(:lshift :rshift))
 312               (setf (second *edit-mode-cursor-positions*) (length (text-of input)))
 313               (setf (edit-mode-cursor-positions) (length (text-of input))))
 314           t)
 315          (:backspace (edit-mode-backspace-text) t)
 316          (:del (edit-mode-delete-text) t)
 317          ((:enter :kp-enter) (leave-edit-mode t) t)
 318          (:esc (leave-edit-mode nil) t)
 319          (:left
 320           (cond
 321             ((intersection *held-keys* '(:lshift :rshift))
 322              (setf (first *edit-mode-cursor-positions*)
 323                    (if (intersection *held-keys* '(:lctrl :rctrl))
 324                        (edit-mode-backwards-word (first *edit-mode-cursor-positions*))
 325                        (1- (first *edit-mode-cursor-positions*))))
 326              (edit-mode-cursor-positions-fix))
 327             ((intersection *held-keys* '(:lctrl :rctrl))
 328              (setf (edit-mode-cursor-positions)
 329                    (edit-mode-backwards-word (first *edit-mode-cursor-positions*))))
 330             (t
 331              (setf (edit-mode-cursor-positions) (1- (first *edit-mode-cursor-positions*)))))
 332           t)
 333          (:right
 334           (cond
 335             ((intersection *held-keys* '(:lshift :rshift))
 336              (setf (second *edit-mode-cursor-positions*)
 337                    (if (intersection *held-keys* '(:lctrl :rctrl))
 338                        (edit-mode-forwards-word (second *edit-mode-cursor-positions*))
 339                        (1+ (second *edit-mode-cursor-positions*))))
 340              (edit-mode-cursor-positions-fix))
 341             ((intersection *held-keys* '(:lctrl :rctrl))
 342              (setf (edit-mode-cursor-positions)
 343                    (edit-mode-forwards-word (second *edit-mode-cursor-positions*))))
 344             (t
 345              (setf (edit-mode-cursor-positions) (1+ (second *edit-mode-cursor-positions*)))))
 346           t)
 347          (:up
 348           (cond
 349             ((intersection *held-keys* '(:lshift :rshift))
 350              (setf (first *edit-mode-cursor-positions*)
 351                    (edit-mode-move-line (first *edit-mode-cursor-positions*) -1))
 352              (edit-mode-cursor-positions-fix))
 353             (t
 354              (setf (edit-mode-cursor-positions)
 355                    (edit-mode-move-line (first *edit-mode-cursor-positions*) -1))))
 356           t)
 357          (:down
 358           (cond
 359             ((intersection *held-keys* '(:lshift :rshift))
 360              (setf (second *edit-mode-cursor-positions*)
 361                    (edit-mode-move-line (second *edit-mode-cursor-positions*) 1))
 362              (edit-mode-cursor-positions-fix))
 363             (t
 364              (setf (edit-mode-cursor-positions)
 365                    (edit-mode-move-line (second *edit-mode-cursor-positions*) 1))))
 366           t))))))