src/cowl.lisp

   1
   2 (in-package #:cowl)
   3
   4 (defvar *root-widget* nil
   5   "Cowl widgets are layed out in grid containers,
   6 this represents the root of the tree. TODO say more")
   7
   8 (defvar *font* nil
   9   "The default font used for text widgets.")
  10
  11 (defparameter *default-font-size* 12)
  12
  13 (defun delete-default-font ()
  14   (when *font*
  15     (ftgl:font-delete *font*)
  16     (setf *font* nil)))
  17
  18 (defun default-font ()
  19   (unless *font*
  20     (ftgl:initialise)
  21     (setf *font* (ftgl:new-texture-font))
  22     (ftgl:font-set-face-size *font* *default-font-size*))
  23   *font*)
  24
  25 (defun (setf default-font) (font)
  26   (delete-default-font)
  27   (setf *font* font))
  28
  29 ;;; INPUT STATE
  30
  31 (defparameter *focused-widget* nil
  32   "The currently active input widget. If nil, nothing is currently being edited.")
  33 (declaim (type (or input null) *focused-widget*))
  34
  35 (defparameter *ignore-events* nil
  36   "This must be set to T before any event processing is done.
  37 The reason this is here is to prevent superfluous events from
  38 firing during application startup before the system is ready.")
  39 (declaim (type boolean *ignore-events*))
  40
  41 (defparameter *prev-mouse* (cons 0 0)
  42   "Cons pair (x . y) of the last mouse position.")
  43
  44 (defparameter *held-keys* nil
  45   "A list of currently held keys, characters or keywords.")
  46
  47
  48 ;;;; GENERIC FUNCTIONS FOR INPUT
  49
  50 (defgeneric handle-mouse-button (widget button press x y)
  51   (:documentation "When a widget needs to respond to a click, implement this.
  52 The x and y arguments are the relative location to the widget.")
  53   (:method (widget button press x y)))
  54
  55 (defgeneric handle-mouse-wheel (widget zrel x y)
  56   (:documentation "When a widget needs to respond to wheel motion, implement this.
  57 The x and y arguments are the relative location to the widget.")
  58   (:method (widget zrel x y)))
  59
  60 (defgeneric handle-mouse-motion (widget x y)
  61   (:documentation "When a widget needs to respond to mouse motion, implement this.
  62 The x and y arguments are the relative location to the widget.
  63 It's probably best, however, if you register a function on *mouse-motion-handlers*
  64 only when required.")
  65   (:method (widget x y)))
  66
  67 (defgeneric handle-key (widget key press)
  68   (:documentation "When a widget needs to respond to a key press/release when it
  69 is focused, implement this.")
  70   (:method (widget key press)))
  71
  72 (defgeneric update-text (widget)
  73   (:documentation "Calls all the text updater methods in all the descendents of widget.")
  74   (:method (widget)))
  75
  76 (defgeneric accept-focus-p (widget)
  77   (:documentation "Whether this widget will accept focus or not. Returns boolean.")
  78   (:method (widget)))
  79
  80 (defgeneric blur (widget)
  81   (:documentation "Called just before this widget is un-focused;
  82 ie. *focused-widget* will still be bound to widget when it is called.")
  83   (:method (widget) "Default no-op" nil)
  84   (:method :after (widget)
  85     "Clear the *focused-widget* parameter, after main actions."
  86     (when (eql *focused-widget* widget)
  87       (setf *focused-widget* nil))))
  88
  89 (defgeneric focus (widget)
  90   (:documentation "Focus this widget. Call to place this widget in focus.
  91 Implement as a main method to determine actions to be taken just
  92 after *focused-widget* is set to widget.")
  93   (:method :around (widget)
  94     "Ensure that we can accept focus and defocus whatever is currently in focus before widget is focused."
  95     (when (accept-focus-p widget)
  96       (when *focused-widget*
  97         (blur *focused-widget*))
  98       (setf *focused-widget* widget)
  99       (call-next-method))))
 100
 101
 102 ;;; EARLY  EVENT HANDLERS
 103
 104 ;; List handlers for various event types, these are triggered first until one returns t
 105 (defparameter *mouse-button-handlers* nil
 106   "List of functions triggered on a mouse button press/release event. Return t if event was handled, otherwise nil.
 107 Arguments passed are: button (keyword symbol :left, :middle, :right), press (t (press) or nil (release)), x, y (integer position of mouse).")
 108 (defparameter *mouse-motion-handlers* nil
 109   "List of functions triggered on a mouse motion event. Return t if event was handled, otherwise nil.
 110 Arguments passed are: x, y (integer position of mouse).")
 111 (defparameter *mouse-wheel-handlers* nil
 112   "List of functions triggered on a mouse wheel event. Return t if event was handled, otherwise nil.
 113 Arguments passed are: zrel (integer delta of mouse wheel 'position'), x, y (integer position of mouse).")
 114 (defparameter *key-handlers* nil
 115   "List of functions triggered on a key press/release event. Return t if event was handled, otherwise nil.
 116 Arguments passed are key (keyword symbol or character), press (t (press) or nil (release)).")
 117
 118
 119 ;;; TOP-LEVEL EVENT HANDLERS
 120
 121 (defun key-event (key press)
 122   "Send a key event to cowl. Key is either a character type or a keyword of the key.
 123 Action should either be T for a press or NIL for a release."
 124   (declare (type (or character symbol) key))
 125   (declare (type boolean press))
 126   (unless *ignore-events*
 127     (if press
 128         (pushnew key *held-keys*)
 129         (setf *held-keys*
 130               (delete key *held-keys*)))
 131     (case key
 132       (:tab (warn "FIXME: Unhandled tabbing focus")))
 133     (when *focused-widget*
 134       (handle-key *focused-widget* key press))))
 135
 136
 137 (defun mouse-button-event (button press &optional (x (car *prev-mouse*)) (y (cdr *prev-mouse*)))
 138   "Send a new mouse button event into Cowl.
 139 This should be called on press/release.
 140 Button should be one of :LEFT, :MIDDLE, or :RIGHT.
 141 x and y are the current mouse coordinates;
 142 if they are unspecified, the last value given to mouse-motion-event will be used."
 143   (declare (type symbol button))
 144   (declare (type boolean press))
 145   (declare (type (integer 0) x y))
 146   (unless *ignore-events*
 147     (unless (some #'(lambda (h)
 148                       (funcall h button press x y))
 149                   *mouse-button-handlers*)
 150       (handle-mouse-button *root-widget* button press
 151                            (- x (current-offset-of (x *root-widget*)))
 152                            (- y (current-offset-of (y *root-widget*)))))))
 153
 154 (defun mouse-wheel-event (zrel &optional  (x (car *prev-mouse*)) (y (cdr *prev-mouse*)))
 155   "Send a new wheel event. zrel is the difference from the last event of the
 156 mouse wheel position. Nominally this would be 1 or -1.
 157 x and y are the current mouse coordinates;
 158 if they are unspecified, the last value given to mouse-motion-event will be used."
 159   (declare (type integer zrel))
 160   (declare (type (integer 0) x y))
 161   (unless *ignore-events*
 162     (unless (some #'(lambda (h)
 163                       (funcall h zrel x y))
 164                   *mouse-motion-handlers*)
 165       (handle-mouse-wheel *root-widget* zrel
 166                           (- x (current-offset-of (x *root-widget*)))
 167                           (- y (current-offset-of (y *root-widget*)))))))
 168
 169 (defun mouse-motion-event (x y)
 170   "Send a new mouse position into Cowl.
 171 This should be hooked up typically to the windowing system, with coordinates relative to the
 172 top-left of the viewport. This means, for some mouse position generators, you will need to
 173 invert the y axis, eg. (- viewport-height y 1)."
 174   (declare (type (integer 0) x y))
 175   (prog1 (unless *ignore-events*
 176            (some #'(lambda (h)
 177                      (funcall h x y))
 178                  *mouse-motion-handlers*))
 179     (setf (car *prev-mouse*) x
 180           (cdr *prev-mouse*) y)))
 181
 182
 183 ;;; TOP-LEVEL RENDER
 184
 185 (defun layout-root (&optional (root-widget *root-widget*))
 186   (layout *root-widget*))
 187
 188 (defun draw-root (&optional (root-widget *root-widget*))
 189   "This is the top-level method to render a cowl widget sheet.
 190 It will start with *root-widget*, unless an argument is supplied, which will nominally be a container."
 191   (destructuring-bind (width height)
 192       (let ((viewport (list 0 0 0 0)))
 193         (gl:get-integerv gl:+viewport+ viewport)
 194         (cddr viewport))
 195     (gl:with-push-attrib (gl:+current-bit+ gl:+lighting-bit+ gl:+texture-bit+ gl:+depth-buffer-bit+ gl:+polygon-bit+)
 196       (gl:disable gl:+lighting+)
 197       (gl:disable gl:+depth-test+)
 198       (gl:depth-mask gl:+false+)
 199       (gl:enable gl:+texture-2d+)
 200       (gl:shade-model gl:+flat+)
 201       (gl:polygon-mode gl:+front-and-back+ gl:+fill+)
 202       (gl:with-projection-matrix
 203           ((glu:ortho-2d 0 width height 0))
 204         (gl:with-push-matrix
 205           (gl:load-identity)
 206           (gl:translate-f (current-offset-of (x root-widget))
 207                           (current-offset-of (y root-widget))
 208                           0.0)
 209           (draw root-widget))))))
 210