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-positions* (list 0 (length (text-of input))))
  60   (setf *edit-mode-cursor-blink-state* t)
  61   (setf *edit-mode-cursor-blink-last-change* (get-internal-real-time)))
  62
  63 (defmethod finish-edit-mode ((input input) confirm-edit)
  64   "Hook method called after the text input is complete, confirmed or cancelled.
  65 If confirm-edit is true, call the writer callback, else revert text to previous state."
  66   (if confirm-edit
  67       (when (slot-boundp input 'writer)
  68         (funcall (slot-value input 'writer) (text-of input)))
  69       (setf (text-of input) *edit-mode-text-memento*)))
  70
  71 (defmethod blur ((input input))
  72   "Invokes leave-edit-mode."
  73   (assert (eql input *focused-widget*))
  74   (leave-edit-mode t))
  75
  76 (defun leave-edit-mode (&optional (confirm-edit t))
  77   "A command to drop the focused widget out of edit-mode.
  78 Invokes finish-edit-mode."
  79   (declare (type boolean confirm-edit))
  80   (finish-edit-mode *focused-widget* confirm-edit)
  81   (setf *focused-widget* nil)
  82   (mapc #'funcall *leave-edit-mode-hooks*))
  83
  84 (defmethod offset-to-char-x-char-y ((input input) ox oy)
  85   "Converts a cursor offset to a 'char coordinate', of the line and colum number
  86 of wrapped text."
  87   (let* ((iy (max 0 (min (1- (length (lines-of input)))
  88                          (floor oy (ftgl:get-font-line-height (font-of input))))))
  89          (ix (font-string-character-position (font-of input)
  90                                              (elt (lines-of input) iy)
  91                                              (max 0 (floor ox)))))
  92     ;; (format t "cursor at ~a,~a~%" ix iy)
  93     (cursor-x-y-to-position input ix iy)))
  94
  95 (defun input-selection-drag-mouse-motion (mx my)
  96   "Handler for mouse motion while an input is having a selection dragged."
  97   (destructuring-bind (cx cy) (cumulative-offset-of *focused-widget*)
  98     (let ((x (- mx cx))
  99           (y (- my cy)))
 100       ;; (format t "Dragging at ~a,~a which is ~a,~a offset from ~a,~a~%" (glfw:get-mouse-pos) x y cx cy)
 101       (setf (second *edit-mode-drag-anchors*)
 102             (offset-to-char-x-char-y *focused-widget* x y))
 103       (setf (edit-mode-cursor-positions) *edit-mode-drag-anchors*)))
 104   t)
 105
 106 ;; ?? mouse-button-handlers mouse-motion-handlers
 107 (defun input-selection-drag-finish (button press x y)
 108   (when (and (not press)
 109              (eql button :left))
 110     (setf *mouse-button-handlers* (delete #'input-selection-drag-finish *mouse-button-handlers*))
 111     (setf *mouse-motion-handlers* (delete #'input-selection-drag-mouse-motion *mouse-motion-handlers*))
 112     t))
 113
 114 (defmethod handle-mouse-button ((input input) button press x y)
 115   (if (and press (eql button :left))
 116       (progn
 117         (focus input)
 118         (setf *edit-mode-drag-anchors*
 119               (make-list 2 :initial-element
 120                          (offset-to-char-x-char-y input
 121                                                   (- x
 122                                                      (before-margin-of (x input))
 123                                                      (before-border-width-of (x input))
 124                                                      (before-padding-of (x input)))
 125                                                   (- y
 126                                                      (before-margin-of (y input))
 127                                                      (before-border-width-of (y input))
 128                                                      (before-padding-of (y input))))))
 129         (setf (edit-mode-cursor-positions) *edit-mode-drag-anchors*)
 130         ;; (format t "anchors: ~a; cursor positions: ~a~%" *edit-mode-drag-anchors* *edit-mode-cursor-positions*)
 131         (pushnew #'input-selection-drag-mouse-motion *mouse-motion-handlers*)
 132         (pushnew #'input-selection-drag-finish *mouse-button-handlers*)
 133         t)
 134       (call-next-method)))
 135
 136
 137 (defun edit-mode-cursor-positions-fix ()
 138   (setf *edit-mode-cursor-positions* (sort *edit-mode-cursor-positions* #'<)
 139         (first *edit-mode-cursor-positions*) (max 0 (first *edit-mode-cursor-positions*))
 140         (second *edit-mode-cursor-positions*) (min (length (display-text-of *focused-widget*))
 141                                                    (second *edit-mode-cursor-positions*))))
 142
 143 (defun edit-mode-cursor-positions () *edit-mode-cursor-positions*)
 144 (defun (setf edit-mode-cursor-positions) (val)
 145   (when *focused-widget*
 146     (setf *edit-mode-cursor-positions*
 147           (mapcar #'(lambda (val) (mod val (1+ (length (display-text-of *focused-widget*)))))
 148                   (if (listp val) val (list val val)))))
 149   (edit-mode-cursor-positions-fix)
 150   val)
 151
 152
 153 (defun cursor-position (cursor-index)
 154   (let ((lines-length 0))
 155     (loop for line in (lines-of *focused-widget*)
 156        for i from 0
 157        do
 158        (when (and (>= cursor-index lines-length)
 159                   (<= cursor-index (+ (length line) lines-length)))
 160          (return-from cursor-position (list (- cursor-index lines-length) i)))
 161        (incf lines-length (length line)))
 162     (list (length (car (last (lines-of *focused-widget*))))
 163           (1- (length (lines-of *focused-widget*))))))
 164
 165 (defun edit-mode-update-cursor-blink ()
 166   (when (> (- (get-internal-real-time)
 167               *edit-mode-cursor-blink-last-change*)
 168            *edit-mode-cursor-blink-time*)
 169     (setf *edit-mode-cursor-blink-last-change* (get-internal-real-time)
 170           *edit-mode-cursor-blink-state* (not *edit-mode-cursor-blink-state*)))
 171   *edit-mode-cursor-blink-state*)
 172
 173 (defmethod detach ((input input))
 174   (when (eql input *focused-widget*)
 175     (leave-edit-mode nil)))
 176
 177 (defmethod draw-cursor ((input input))
 178   (gl:disable gl:+texture-2d+)
 179   (apply #'gl:color-4f (foreground-colour-of input))
 180   (if (apply #'= *edit-mode-cursor-positions*)
 181       (progn
 182         (unless (edit-mode-update-cursor-blink)
 183           (return-from draw-cursor))
 184         (gl:begin gl:+lines+))
 185       (gl:begin gl:+quads+))
 186   (labels ((cursor-x-offset (cursor-pos)
 187              (destructuring-bind (cursor-x cursor-y) cursor-pos
 188                (font-string-cursor-offset
 189                 (font-of input)
 190                 (elt (lines-of input) cursor-y)
 191                 cursor-x)))
 192            (cursor-y-offset (cursor-pos)
 193              (* (second cursor-pos) (ftgl:get-font-line-height (font-of input))))
 194            (vertex-pair (cursor-pos &optional down)
 195              (let ((cursor-x-offset (cursor-x-offset cursor-pos))
 196                    (cursor-y-offset (cursor-y-offset cursor-pos)))
 197                (if down
 198                    (progn
 199                      (gl:vertex-2f cursor-x-offset cursor-y-offset)
 200                      (gl:vertex-2f cursor-x-offset (+ cursor-y-offset (ftgl:get-font-line-height (font-of input)))))
 201                    (progn
 202                      (gl:vertex-2f cursor-x-offset (+ cursor-y-offset (ftgl:get-font-line-height (font-of input))))
 203                      (gl:vertex-2f cursor-x-offset cursor-y-offset))))))
 204
 205     (let ((cursor-pos-front (cursor-position (first *edit-mode-cursor-positions*))))
 206       (vertex-pair cursor-pos-front t)
 207       (unless (apply #'= *edit-mode-cursor-positions*)
 208         (let ((cursor-pos-back (cursor-position (second *edit-mode-cursor-positions*))))
 209           (do ((i (second cursor-pos-front) (1+ i)))
 210               ((>= i (second cursor-pos-back)))
 211             (vertex-pair (list (length (elt (lines-of *focused-widget*) i)) i))
 212             (vertex-pair (list 0 (1+ i)) t))
 213           (vertex-pair cursor-pos-back)))))
 214   (gl:end))
 215
 216 (defmethod draw ((input input))
 217   (when (eql input *focused-widget*)
 218     (draw-cursor input))
 219   (call-next-method))
 220
 221 (defun string-insert (string replacement position)
 222   "Returns a string with the character at the position, or between the cons pair of positions, in string."
 223   (cond
 224     ((typep position '(cons integer (cons integer null)))
 225      (concatenate 'string
 226                   (subseq string 0 (first position))
 227                   replacement
 228                   (subseq string (second position))))
 229     ((typep position 'integer)
 230      (concatenate 'string
 231                   (subseq string 0 position)
 232                   replacement
 233                   (subseq string position)))))
 234
 235 (defmethod (setf text-of) (val (input input))
 236   (call-next-method)
 237   (when *focused-widget*
 238     (setf (edit-mode-cursor-positions)
 239           (list (max (first *edit-mode-cursor-positions*) (length val))
 240                 (max (second *edit-mode-cursor-positions*) (length val))))
 241     (when *edit-mode-drag-anchors*
 242       (setf (first *edit-mode-drag-anchors*) (max (first *edit-mode-drag-anchors*) (length val))
 243             (second *edit-mode-drag-anchors*) (max (second *edit-mode-drag-anchors*) (length val))))))
 244
 245 (defun edit-mode-backspace-text ()
 246   (unless (apply #'= (cons 0 *edit-mode-cursor-positions*))
 247     (setf (first *edit-mode-cursor-positions*)
 248           (min (first *edit-mode-cursor-positions*)
 249                (1- (second *edit-mode-cursor-positions*))))
 250     (with-accessors ((text text-of)) *focused-widget*
 251       (psetf text (string-insert text nil *edit-mode-cursor-positions*)
 252              (edit-mode-cursor-positions) (first *edit-mode-cursor-positions*)))))
 253
 254 (defun edit-mode-delete-text ()
 255   (with-accessors ((text text-of)) *focused-widget*
 256     (unless (apply #'= (cons (length text) *edit-mode-cursor-positions*))
 257       (setf (second *edit-mode-cursor-positions*)
 258             (max (second *edit-mode-cursor-positions*)
 259                  (1+ (first *edit-mode-cursor-positions*))))
 260       (psetf text (string-insert text nil *edit-mode-cursor-positions*)
 261              (edit-mode-cursor-positions) (first *edit-mode-cursor-positions*)))))
 262
 263 (defun edit-mode-insert-text (char)
 264   (with-accessors ((text text-of)) *focused-widget*
 265     (psetf text (string-insert text (list char) *edit-mode-cursor-positions*)
 266            (edit-mode-cursor-positions) (1+ (first *edit-mode-cursor-positions*)))))
 267
 268 (defun edit-mode-backwards-word (position)
 269   (if (zerop position)
 270       0
 271       (or (position-if #'blankp (text-of *focused-widget*) :from-end t :end position)
 272           0)))
 273
 274 (defun edit-mode-forwards-word (position)
 275   (if (= position (length (text-of *focused-widget*)))
 276       (length (text-of *focused-widget*))
 277       (or (position-if #'blankp (text-of *focused-widget*) :start (1+ position))
 278           (length (text-of *focused-widget*)))))
 279
 280 (defun edit-mode-move-line (position delta)
 281   (destructuring-bind (cx cy) (cursor-position position)
 282     (let ((x-offset (font-string-cursor-offset (font-of *focused-widget*)
 283                                                (elt (lines-of *focused-widget*)
 284                                                     cy)
 285                                                cx)))
 286       (setf cy (mod (+ cy delta) (length (lines-of *focused-widget*))))
 287       (+ (loop for i below cy for line in (lines-of *focused-widget*)
 288             summing (length line))
 289          (font-string-character-position (font-of *focused-widget*)
 290                                          (elt (lines-of *focused-widget*) cy)
 291                                          x-offset)))))
 292
 293 (defmethod accept-char-p ((input input) character)
 294   (graphic-char-p character))
 295
 296
 297 (defmethod handle-key ((input input) key press)
 298   (when press
 299     (setf *edit-mode-cursor-blink-last-change* (get-internal-real-time)
 300           *edit-mode-cursor-blink-state* t)
 301     (etypecase key
 302       (character
 303        (when (accept-char-p input key)
 304          (edit-mode-insert-text key)))
 305       (symbol
 306        (case key
 307          (:home
 308           (if (intersection *held-keys* '(:lshift :rshift))
 309               (setf (first *edit-mode-cursor-positions*) 0)
 310               (setf (edit-mode-cursor-positions) 0))
 311           t)
 312          (:end
 313           (if (intersection *held-keys* '(:lshift :rshift))
 314               (setf (second *edit-mode-cursor-positions*) (length (text-of input)))
 315               (setf (edit-mode-cursor-positions) (length (text-of input))))
 316           t)
 317          (:backspace (edit-mode-backspace-text) t)
 318          (:del (edit-mode-delete-text) t)
 319          ((:enter :kp-enter) (leave-edit-mode t) t)
 320          (:esc (leave-edit-mode nil) t)
 321          (:left
 322           (cond
 323             ((intersection *held-keys* '(:lshift :rshift))
 324              (setf (first *edit-mode-cursor-positions*)
 325                    (if (intersection *held-keys* '(:lctrl :rctrl))
 326                        (edit-mode-backwards-word (first *edit-mode-cursor-positions*))
 327                        (1- (first *edit-mode-cursor-positions*))))
 328              (edit-mode-cursor-positions-fix))
 329             ((intersection *held-keys* '(:lctrl :rctrl))
 330              (setf (edit-mode-cursor-positions)
 331                    (edit-mode-backwards-word (first *edit-mode-cursor-positions*))))
 332             (t
 333              (setf (edit-mode-cursor-positions) (1- (first *edit-mode-cursor-positions*)))))
 334           t)
 335          (:right
 336           (cond
 337             ((intersection *held-keys* '(:lshift :rshift))
 338              (setf (second *edit-mode-cursor-positions*)
 339                    (if (intersection *held-keys* '(:lctrl :rctrl))
 340                        (edit-mode-forwards-word (second *edit-mode-cursor-positions*))
 341                        (1+ (second *edit-mode-cursor-positions*))))
 342              (edit-mode-cursor-positions-fix))
 343             ((intersection *held-keys* '(:lctrl :rctrl))
 344              (setf (edit-mode-cursor-positions)
 345                    (edit-mode-forwards-word (second *edit-mode-cursor-positions*))))
 346             (t
 347              (setf (edit-mode-cursor-positions) (1+ (second *edit-mode-cursor-positions*)))))
 348           t)
 349          (:up
 350           (cond
 351             ((intersection *held-keys* '(:lshift :rshift))
 352              (setf (first *edit-mode-cursor-positions*)
 353                    (edit-mode-move-line (first *edit-mode-cursor-positions*) -1))
 354              (edit-mode-cursor-positions-fix))
 355             (t
 356              (setf (edit-mode-cursor-positions)
 357                    (edit-mode-move-line (first *edit-mode-cursor-positions*) -1))))
 358           t)
 359          (:down
 360           (cond
 361             ((intersection *held-keys* '(:lshift :rshift))
 362              (setf (second *edit-mode-cursor-positions*)
 363                    (edit-mode-move-line (second *edit-mode-cursor-positions*) 1))
 364              (edit-mode-cursor-positions-fix))
 365             (t
 366              (setf (edit-mode-cursor-positions)
 367                    (edit-mode-move-line (second *edit-mode-cursor-positions*) 1))))
 368           t))))))