src/cowl-widget.lisp

   1 (in-package #:cowl)
   2
   3 (compiler-opts)
   4
   5 ;; (font *applications*)
   6 (defclass widget-measurement ()
   7   ((current-offset :type real :initform 0
   8                    :initarg :current-offset :accessor current-offset-of
   9                    :documentation "The actual current offset relative to the parent widget")
  10    (current-size :type real :initform (and (default-font) (ftgl:get-font-line-height (default-font)))
  11                  :initarg :current-size :accessor current-size-of
  12                  :documentation "The current measurement size of the content (ie. excluding padding, border and margin).")
  13    (ideal-size :type real
  14                :initarg :ideal-size :accessor ideal-size-of
  15                :documentation "The ideal, preferred absolute size of the content of this measurement.")
  16    (constraints :type (cons real real)
  17                 :initarg :constraints :accessor constraints-of
  18                 :documentation "The (minimum . maximum) size for this measurement.")
  19    (margin :type (cons real real)
  20            :initarg :margin :initform (cons 2 2) :accessor margin-of
  21            :documentation "Cons-pair of margin widths in pixels outside the border of this widget.")
  22    (border-width :type (cons real real)
  23                  :initarg :border-width :initform (cons 1 1) :accessor border-width-of
  24                  :documentation "Cons-pair of widths in pixels of the border.")
  25    (padding :type (cons real real)
  26             :initarg :padding :initform (cons 2 2) :accessor padding-of
  27             :documentation "Cons-pair of widths in pixels of the border.")
  28    (border-colour :type (cons list list) :initarg :border-colour :accessor border-colour-of
  29                   :initform (cons '(1.0 1.0 1.0 1.0) '(1.0 1.0 1.0 1.0))
  30                   :documentation "Cons-pair of lists of RGBA float 0.0->1.0 values."))
  31   (:documentation "A measurement in one dimension (namely x or y) of an widget and
  32 its associated data for laying out in containers."))
  33
  34 ;; this warns because generic functions are implicly created
  35 ;; perhaps use the (defgeneric :method syntax instead)?
  36 (defmacro define-before-after-accessors (class &rest slots)
  37   `(progn
  38      ,@(mapcan
  39         #'(lambda (slot)
  40             `((defmethod ,(intern (format nil "BEFORE-~a-OF" slot)) ((,class ,class))
  41                 (car (slot-value ,class ',slot)))
  42               (defmethod (setf ,(intern (format nil "BEFORE-~a-OF" slot))) (val (,class ,class))
  43                 (setf (car (slot-value ,class ',slot)) val))
  44               (defmethod ,(intern (format nil "AFTER-~a-OF" slot)) ((,class ,class))
  45                 (cdr (slot-value ,class ',slot)))
  46               (defmethod (setf ,(intern (format nil "AFTER-~a-OF" slot))) (val (,class ,class))
  47                 (setf (cdr (slot-value ,class ',slot)) val))))
  48         slots)))
  49
  50 (define-before-after-accessors widget-measurement margin border-width padding border-colour)
  51
  52 (defmethod minimum-size-of ((widget-measurement widget-measurement))
  53   (car (constraints-of widget-measurement)))
  54
  55 (defmethod (setf minimum-size-of) (val (widget-measurement widget-measurement))
  56   (setf (car (constraints-of widget-measurement)) val))
  57
  58 (defmethod maximum-size-of ((widget-measurement widget-measurement))
  59   (cdr (constraints-of widget-measurement)))
  60
  61 (defmethod (setf maximum-size-of) (val (widget-measurement widget-measurement))
  62   (setf (cdr (constraints-of widget-measurement)) val))
  63
  64
  65 (defmethod first-border-width-of ((widget-measurement widget-measurement))
  66   (with-slots (border-width) widget-measurement
  67     (if (consp border-width)
  68         (car border-width)
  69         border-width)))
  70
  71 (defmethod (setf total-current-size-of) (size (widget-measurement widget-measurement))
  72   "Computes the current internal size and sets it from an external total size."
  73   (setf (current-size-of widget-measurement)
  74         (- size
  75            (before-padding-of widget-measurement)
  76            (after-padding-of widget-measurement)
  77            (before-border-width-of widget-measurement)
  78            (after-border-width-of widget-measurement)
  79            (before-margin-of widget-measurement)
  80            (after-margin-of widget-measurement))))
  81
  82 (defmethod total-current-size-of ((widget-measurement widget-measurement))
  83   "Computes the total current outer size, including padding, border and margin of this dimension."
  84   (+ (slot-value widget-measurement 'current-size)
  85      (before-padding-of widget-measurement)
  86      (after-padding-of widget-measurement)
  87      (before-border-width-of widget-measurement)
  88      (after-border-width-of widget-measurement)
  89      (before-margin-of widget-measurement)
  90      (after-margin-of widget-measurement)))
  91
  92
  93 (defmethod (setf total-ideal-size-of) (size (widget-measurement widget-measurement))
  94   "Computes the ideal internal size and sets it from an external total size."
  95   (setf (ideal-size-of widget-measurement)
  96         (- size
  97            (before-padding-of widget-measurement)
  98            (after-padding-of widget-measurement)
  99            (before-border-width-of widget-measurement)
 100            (after-border-width-of widget-measurement)
 101            (before-margin-of widget-measurement)
 102            (after-margin-of widget-measurement))))
 103
 104 (defmethod total-ideal-size-of ((widget-measurement widget-measurement))
 105   "Computes the total ideal outer size, including padding, border and margin of this dimension."
 106   (if (slot-boundp widget-measurement 'ideal-size)
 107       (+ (slot-value widget-measurement 'ideal-size)
 108          (before-padding-of widget-measurement)
 109          (after-padding-of widget-measurement)
 110          (before-border-width-of widget-measurement)
 111          (after-border-width-of widget-measurement)
 112          (before-margin-of widget-measurement)
 113          (after-margin-of widget-measurement))
 114       0))
 115
 116 (defmethod content-offset-of ((widget-measurement widget-measurement))
 117   "Offset from the top left of the widget to the content start"
 118   (+ (before-margin-of widget-measurement)
 119      (before-border-width-of widget-measurement)
 120      (before-padding-of widget-measurement)))
 121
 122 ;; this references cowl contaner before it is declared, ok, but leads to warnings
 123 (defclass widget ()
 124   ((parent :accessor parent-of :type widget :initarg :parent)
 125    (visible :accessor visibility-of :type boolean
 126             :initform t :initarg :visible
 127             :documentation "Inhibits the widget from being drawn. It is still
 128 present in the layout though.")
 129    (x :accessor x :type widget-measurement
 130       :initform (make-instance 'widget-measurement))
 131    (y :accessor y :type widget-measurement
 132       :initform (make-instance 'widget-measurement))
 133    (foreground-colour :type list
 134                       :accessor foreground-colour-of
 135                       :documentation "Colour of the text, default solid border
 136 colour and highlight.")
 137    (background-colour :type list
 138                       :accessor background-colour-of
 139                       :documentation "Colour of the background of the widget
 140 and base colour of default inset/outset border."))
 141   (:documentation "The base class for all on-screen-display widgets"))
 142
 143 (defmethod initialize-instance :after
 144     ((widget widget) &key x y width height style padding margin
 145      padding-left padding-right padding-top padding-bottom
 146      margin-left margin-right margin-top margin-bottom
 147      border-width-left border-width-right border-width-top border-width-bottom
 148      foreground-colour background-colour
 149      (border-style :solid border-stylep)
 150      (border-width 1 border-widthp)
 151      (border-colour nil border-colourp)
 152      &allow-other-keys)
 153   (when (realp x) (setf (current-offset-of (x widget)) x))
 154   (when (realp y) (setf (current-offset-of (y widget)) y))
 155   (when (realp width)  (setf (ideal-size-of (x widget))   width
 156                              (current-size-of (x widget)) width))
 157   (when (realp height) (setf (ideal-size-of (y widget))   height
 158                              (current-size-of (y widget)) height))
 159
 160   ;; style settings -  borders depend on colours.
 161   (setf (foreground-colour-of widget)
 162         (or foreground-colour (get-style-value widget :foreground-colour style))
 163         (background-colour-of widget)
 164         (or background-colour (get-style-value widget :background-colour style))
 165         (margin-of widget)
 166         (or margin (get-style-value widget :margin style))
 167         (padding-of widget)
 168         (or padding (get-style-value widget :padding style)))
 169
 170   ;; pedantic paddings and margins widths
 171   (when padding-left (setf (before-padding-of (x widget)) padding-left))
 172   (when padding-right (setf (after-padding-of (x widget)) padding-right))
 173   (when padding-top (setf (before-padding-of (y widget)) padding-top))
 174   (when padding-bottom (setf (after-padding-of (y widget)) padding-bottom))
 175   (when margin-left (setf (before-margin-of (x widget)) margin-left))
 176   (when margin-right (setf (after-margin-of (x widget)) margin-right))
 177   (when margin-top (setf (before-margin-of (y widget)) margin-top))
 178   (when margin-bottom (setf (after-margin-of (y widget)) margin-bottom))
 179
 180   (if (or border-stylep border-widthp border-colourp)
 181       (set-borders widget border-style border-width border-colour)
 182       (let ((borders (get-style-value widget :borders style)))
 183         (when borders
 184           (apply #'set-borders (cons widget borders)))))
 185
 186   ;; pedantic borders widths
 187   (when border-width-left (setf (before-border-width-of (x widget)) border-width-left))
 188   (when border-width-right (setf (after-border-width-of (x widget)) border-width-right))
 189   (when border-width-top (setf (before-border-width-of (y widget)) border-width-top))
 190   (when border-width-bottom (setf (after-border-width-of (y widget)) border-width-bottom)))
 191
 192 (defun set-widget-style (widget style)
 193   (declare (type widget widget))
 194
 195   ;; style settings -  borders depend on colours.
 196   (setf (foreground-colour-of widget)
 197         (get-style-value widget :foreground-colour style)
 198         (background-colour-of widget)
 199         (get-style-value widget :background-colour style)
 200         (margin-of widget)
 201         (get-style-value widget :margin style)
 202         (padding-of widget)
 203         (get-style-value widget :padding style))
 204   (let ((borders (get-style-value widget :borders style)))
 205     (when borders
 206       (apply #'set-borders (cons widget borders)))))
 207
 208
 209 (defmethod detach ((widget widget))
 210   "Callback for when an widget is detached from the current view (ie. it goes off the screen).")
 211
 212 (defmethod (setf padding-of) (val (widget widget))
 213   (setf (padding-of (x widget)) (cons val val)
 214         (padding-of (y widget)) (cons val val)))
 215
 216 (defmethod (setf margin-of) (val (widget widget))
 217   (setf (margin-of (x widget)) (cons val val)
 218         (margin-of (y widget)) (cons val val)))
 219
 220 (defmethod ideal-width-of ((widget widget))
 221   (if (slot-boundp (x widget) 'ideal-size)
 222       (ideal-size-of (x widget))
 223       0))
 224
 225 (defmethod ideal-height-of ((widget widget))
 226   (if (slot-boundp (y widget) 'ideal-size)
 227       (ideal-size-of (y widget))
 228       0))
 229
 230 (defmethod total-ideal-width-of ((widget widget))
 231   (with-accessors ((widget-measurement x)) widget
 232     (+ (ideal-width-of widget)
 233        (before-padding-of widget-measurement)
 234        (after-padding-of widget-measurement)
 235        (before-border-width-of widget-measurement)
 236        (after-border-width-of widget-measurement)
 237        (before-margin-of widget-measurement)
 238        (after-margin-of widget-measurement))))
 239
 240 (defmethod total-ideal-height-of ((widget widget))
 241   (with-accessors ((widget-measurement y)) widget
 242     (+ (ideal-height-of widget)
 243        (before-padding-of widget-measurement)
 244        (after-padding-of widget-measurement)
 245        (before-border-width-of widget-measurement)
 246        (after-border-width-of widget-measurement)
 247        (before-margin-of widget-measurement)
 248        (after-margin-of widget-measurement))))
 249
 250 (defmethod cumulative-offset-of ((widget widget))
 251   "Returns the cumulative offset in the viewport as (list x y)"
 252   (apply #'mapcar (cons #'+ (loop for n = widget then (and (slot-boundp n 'parent) (parent-of n))
 253                                while n
 254                                nconcing
 255                                (list (list (current-offset-of (x n)) (current-offset-of (y n)))
 256                                      (list (before-margin-of (x n)) (before-margin-of (y n)))
 257                                      (list (before-border-width-of (x n)) (before-border-width-of (y n)))
 258                                      (list (before-padding-of (x n)) (before-padding-of (y n))))))))
 259
 260 (defmethod current-offset-before-border-of ((widget widget))
 261   (destructuring-bind (cx cy) (cumulative-offset-of widget)
 262     (list (+ cx (before-border-width-of (x widget)))
 263           (+ cy (before-border-width-of (y widget))))))
 264
 265 (defmethod current-offset-before-border-of ((widget widget))
 266   (list (+ (current-offset-of (x widget))
 267            (before-border-width-of (x widget)))
 268         (+ (current-offset-of (y widget))
 269            (before-border-width-of (y widget)))))
 270
 271 (defmethod set-borders ((widget widget) style &optional (width 1) colour)
 272   (declare (type (member :solid :inset :outset :none) style))
 273   "Set up borders to one of the four presets."
 274   (with-slots (x y) widget
 275     (flet ((dark-light (delta)
 276              (let ((base-colour (or colour
 277                                     (if (slot-boundp widget 'background-colour)
 278                                         (background-colour-of widget)
 279                                         '(0.5 0.5 0.5 0.5)))))
 280                (cons (list (- (elt base-colour 0) delta)
 281                            (- (elt base-colour 1) delta)
 282                            (- (elt base-colour 2) delta)
 283                            (elt base-colour 3))
 284                      (list (+ (elt base-colour 0) delta)
 285                            (+ (elt base-colour 1) delta)
 286                            (+ (elt base-colour 2) delta)
 287                            (elt base-colour 3))))))
 288       (ecase style
 289         (:solid
 290          (unless colour (setf colour
 291                               (if (slot-boundp widget 'foreground-colour)
 292                                   (foreground-colour-of widget)
 293                                   '(1.0 1.0 1.0 1.0))))
 294          (setf (border-width-of x) (cons width width)
 295                (border-width-of y) (cons width width)
 296                (border-colour-of x) (cons colour colour)
 297                (border-colour-of y) (cons colour colour)))
 298         (:outset
 299          (setf (border-width-of x) (cons width width)
 300                (border-width-of y) (cons width width)
 301                (border-colour-of x) (dark-light -0.25)
 302                (border-colour-of y) (dark-light -0.25)))
 303         (:inset
 304          (setf (border-width-of x) (cons width width)
 305                (border-width-of y) (cons width width)
 306                (border-colour-of x) (dark-light 0.25)
 307                (border-colour-of y) (dark-light 0.25)))
 308         ((nil :none)
 309          (setf (border-width-of x) (cons 0 0)
 310                (border-width-of y) (cons 0 0)))))))
 311
 312 (defmethod layout ((widget widget))
 313   "Lay-out the contents of the widget when the sizes/offsets change.")
 314
 315
 316 (defmacro with-widget-box-bindings (widget &body forms)
 317   "Makes bindings for b[xy][01][01] thus:
 318       bx00  bx01                   bx10 bx11
 319  by00 +     +----------------------+    +
 320             |                      |
 321  by01 +-----+----------------------+----+
 322       |     |                      |    |
 323       |     |                      |    |
 324       |     |      Content         |    |
 325       |     |                      |    |
 326       |     |                      |    |
 327  by10 +-----+----------------------+----+
 328             |                      |
 329  by11 +     +----------------------+    "
 330   (let ((widget-s (gensym "WIDGET-"))
 331         (x (gensym "X-"))
 332         (y (gensym "Y-")))
 333     `(let* ((,widget-s ,widget)
 334             (,x (x ,widget-s))
 335             (,y (y ,widget-s))
 336             (bx00 (before-margin-of ,x))
 337             (bx01 (+ bx00 (before-border-width-of ,x)))
 338             (bx10 (+ bx01 (current-size-of ,x) (before-padding-of ,x) (after-padding-of ,x)))
 339             (bx11 (+ bx10 (after-border-width-of ,x)))
 340             (by00 (before-margin-of ,y))
 341             (by01 (+ by00 (before-border-width-of ,y)))
 342             (by10 (+ by01 (current-size-of ,y) (before-padding-of ,y) (after-padding-of ,y)))
 343             (by11 (+ by10 (after-border-width-of ,y))))
 344        ,@forms)))
 345
 346
 347 (defmethod draw ((widget widget))
 348   "No-op method here for testing")
 349
 350 (defmethod draw :around ((widget widget))
 351   "Draws the borders and background colour, if approcpriate, of the widget and translates it to the right position for drawing.
 352 This is the border layout.
 353       bx00  bx01                   bx10 bx11
 354  by00 +     +----------------------+    +
 355             |                      |
 356  by01 +-----+----------------------+----+
 357       |     |                      |    |
 358       |     |                      |    |
 359       |     |      Content         |    |
 360       |     |                      |    |
 361       |     |                      |    |
 362  by10 +-----+----------------------+----+
 363             |                      |
 364  by11 +     +----------------------+    +"
 365
 366   (unless (visibility-of widget)
 367     (return-from draw))
 368
 369   (with-slots (x y) widget
 370     (gl:disable gl:+texture-2d+)
 371
 372     (with-widget-box-bindings widget
 373       ;; left border
 374       (when (plusp (before-border-width-of x))
 375         (apply #'gl:color-4f (before-border-colour-of x))
 376         (gl:rect-f bx00 by10 bx01 by01))
 377       ;; top border
 378       (when (plusp (before-border-width-of y))
 379         (apply #'gl:color-4f (before-border-colour-of y))
 380         (gl:rect-f bx01 by01 bx10 by00))
 381       ;; right border
 382       (when (plusp (after-border-width-of x))
 383         (apply #'gl:color-4f (after-border-colour-of x))
 384         (gl:rect-f bx10 by10 bx11 by01))
 385       ;; bottom border
 386       (when (plusp (after-border-width-of y))
 387         (apply #'gl:color-4f (after-border-colour-of y))
 388         (gl:rect-f bx01 by11 bx10 by10))
 389
 390       ;; background
 391       (when (slot-boundp widget 'background-colour)
 392         (apply #'gl:color-4f (background-colour-of widget))
 393         (gl:rect-f bx10 by01 bx01 by10))
 394
 395       (when (next-method-p)
 396         (gl:with-push-matrix
 397           (gl:translate-f (coerce (+ bx01 (before-padding-of x)) 'single-float)
 398                           (coerce (+ by01 (before-padding-of y)) 'single-float)
 399                           0.0)
 400           (call-next-method))))))