src/cowl-input.lisp

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