src/cowl-container.lisp

   1 (in-package #:cowl)
   2 (compiler-opts)
   3
   4 (defclass container (widget)
   5   ((contents :type (simple-array (or null widget) 2) :reader contents-of
   6              :documentation "A matrix of contained widgets")
   7    (row-heights :type list :accessor row-heights :initarg :row-heights :accessor row-heights-of
   8                   :documentation "Heights of the rows, list of either a stretch-weight (:weight . number),
   9 or a fixed value (:fixed . number).")
  10    (column-widths :type list :accessor column-widths :initarg :column-widths :accessor column-widths-of
  11                   :documentation "Widths of the columns, list of either a stretch-weight (:weight . number),
  12 or a fixed value (:fixed . number).")
  13    (computed-row-heights :type list :accessor computed-row-heights-of)
  14    (computed-column-widths :type list :accessor computed-column-widths-of))
  15   (:documentation "A grid-layout container for other widgets."))
  16
  17 (defmethod (setf contents-of) (ncontents (container container))
  18   (with-slots (contents) container
  19     (cond
  20       ((listp ncontents)
  21        (unless (listp (first ncontents)) (error "contents must be a list of lists"))
  22        ;; (format t "Making a ~ax~a grid~%" (length contents) (length (first contents)))
  23        (setf contents
  24              (make-array (list (length ncontents) (length (first ncontents)))
  25                          :element-type '(or null widget)
  26                          :initial-contents ncontents)))
  27       ((arrayp ncontents)
  28        (setf contents ncontents))))
  29   (with-accessors ((contents contents-of)) container
  30     (loop for row below (array-dimension contents 0) do
  31          (loop for column below (array-dimension contents 1) do
  32               (let ((widget (aref contents row column)))
  33                 (when widget
  34                   (setf (parent-of widget) container)))))
  35     (unless (slot-boundp container 'row-heights)
  36       (setf (slot-value container 'row-heights)
  37             (make-list (array-dimension contents 0)
  38                        :initial-element (cons :expand (if (default-font)
  39                                                           (ftgl:get-font-line-height (default-font))
  40                                                           10))))
  41       ;; (format t "row heights unintialized, set to ~a~%" (slot-value container 'row-heights))
  42       )
  43     (unless (slot-boundp container 'column-widths)
  44       (setf (slot-value container 'column-widths)
  45             (make-list (array-dimension contents 1)
  46                        :initial-element (cons :expand (if (default-font)
  47                                                           (ftgl:get-font-line-height (default-font))
  48                                                           10))))
  49       ;; (format t "column widths unintialized, set to ~a~%" (slot-value container 'column-widths))
  50       )))
  51
  52
  53 (defmethod initialize-instance :after ((container container) &key rows columns contents)
  54   (cond
  55     (contents
  56      (setf (contents-of container) contents))
  57     ((and (realp columns) (realp rows))
  58      (setf (contents-of container)
  59            (make-array (list rows columns)
  60                        :element-type '(or null widget)
  61                        :initial-element nil)))))
  62
  63 (defmethod set-cell ((container container) row column widget)
  64   (when (aref (contents-of container) row column)
  65     (detach (aref (contents-of container) row column)))
  66   (setf (aref (contents-of container) row column)
  67         widget)
  68   (when widget
  69     (setf (parent-of widget) container)))
  70
  71 (defun row-widget-heights-of (2d-array)
  72   (loop for row below (array-dimension 2d-array 0) collecting
  73        (loop for column below (array-dimension 2d-array 1) collecting
  74             (let ((widget (aref 2d-array row column)))
  75               (if widget
  76                   (total-ideal-height-of widget)
  77                   0)))))
  78
  79 (defun column-widget-widths-of (2d-array)
  80   (loop for column below (array-dimension 2d-array 1) collecting
  81        (loop for row below (array-dimension 2d-array 0) collecting
  82             (let ((widget (aref 2d-array row column)))
  83               (if widget
  84                   (total-ideal-width-of widget)
  85                   0)))))
  86
  87 (defmethod contents-list ((container container))
  88   "Just collect up all of the contents into one list, ignoring empty cells."
  89   (loop for column below (array-dimension (contents-of container) 1) nconcing
  90        (loop for row below (array-dimension (contents-of container) 0)
  91             when (aref (contents-of container) row column)
  92           collecting
  93             (aref (contents-of container) row column))))
  94
  95 (defun compute-ideal-sizes (sizes set-ideal-sizes)
  96   (loop for size in sizes
  97      for ideal-sizes in set-ideal-sizes
  98      collecting
  99      (ecase (car size)
 100        ((:expand :weight) (reduce #'max (cons (cdr size) ideal-sizes)))
 101        (:fixed (cdr size)))))
 102
 103
 104 (defmethod ideal-width-of ((container container))
 105   (if (slot-boundp (x container) 'ideal-size)
 106       (slot-value (x container) 'ideal-size)
 107       (reduce #'+
 108               (compute-ideal-sizes (column-widths-of container)
 109                                    (column-widget-widths-of (contents-of container))))))
 110
 111 (defmethod ideal-height-of ((container container))
 112   (if (slot-boundp (y container) 'ideal-size)
 113       (slot-value (y container) 'ideal-size)
 114       (reduce #'+
 115               (compute-ideal-sizes (row-heights-of container)
 116                                    (row-widget-heights-of (contents-of container))))))
 117
 118
 119 (defun compute-set-sizes (available-size sizes set-ideal-sizes)
 120   (let* ((available-weighted-size available-size)
 121          (total-weight 0.0)
 122          (out-sizes
 123           (loop for size in sizes
 124              for ideal-sizes in set-ideal-sizes
 125              collecting
 126                (ecase (car size)
 127                  (:weight
 128                   (incf total-weight (cdr size))
 129                   size)
 130                  ((:expand :fixed)
 131                   (let ((size (min available-weighted-size
 132                                    (ecase (car size)
 133                                      (:expand (reduce #'max (cons (cdr size) ideal-sizes)))
 134                                      (:fixed (cdr size))))))
 135                     (decf available-weighted-size size)
 136                     size))))))
 137     (map-into out-sizes
 138               #'(lambda (size)
 139                   (if (consp size)
 140                       (* (cdr size) (/ available-weighted-size total-weight))
 141                       size))
 142               out-sizes)))
 143
 144 (defmethod detach ((container container))
 145   "Callback for when an widget is detached from the current view (ie. it goes off the screen)."
 146   (mapcar #'detach (contents-list container)))
 147
 148 (defmethod layout ((container container))
 149   (setf (computed-row-heights-of container)
 150         (compute-set-sizes (current-size-of (y container))
 151                            (row-heights-of container)
 152                            (row-widget-heights-of (contents-of container)))
 153         (computed-column-widths-of container)
 154         (compute-set-sizes (current-size-of (x container))
 155                            (column-widths-of container)
 156                            (column-widget-widths-of (contents-of container))))
 157   ;; (format t "computed ~a~%  widths~a~%  heights~a~%"
 158   ;;      container
 159   ;;      (computed-column-widths-of container)
 160   ;;      (computed-row-heights-of container))
 161   (let ((ix 0.0) (iy 0.0))
 162     (loop for row below (array-dimension (contents-of container) 0)
 163        for height in (computed-row-heights-of container) do
 164        (loop for column below (array-dimension (contents-of container) 1)
 165           for width in (computed-column-widths-of container) do
 166           (let ((widget (aref (contents-of container) row column)))
 167             (when widget
 168               (setf (total-current-size-of (x widget)) (min width (total-ideal-width-of widget))
 169                     (total-current-size-of (y widget)) (min height (total-ideal-height-of widget))
 170                     (current-offset-of (x widget)) ix
 171                     (current-offset-of (y widget)) iy)
 172               (layout widget)))
 173           (incf ix width))
 174        (incf iy height)
 175        (setf ix 0.0))))
 176
 177 (defmethod draw ((container container))
 178   (layout container)
 179   (with-slots (x y) container
 180     (mapcar #'(lambda (widget)
 181                 (gl:with-push-matrix
 182                   (gl:translate-f (current-offset-of (x widget))
 183                                   (current-offset-of (y widget))
 184                                   0.0)
 185                   (draw widget)))
 186             (contents-list container))))
 187
 188 (defmethod update-text ((container container))
 189   (mapc #'update-text (contents-list container)))
 190
 191
 192 (defmacro define-propogating-container-method (name (&rest lambda-list) &body forms)
 193   "Defines a method named name, with lambda-list prepended by (container container),
 194 that propogates to child widgets, x and y must appear in the lambda list.
 195 For the course of forms, widget is also bound to the widget located."
 196   `(defmethod ,name ,(list* '(container container) lambda-list)
 197      (declare (optimize (debug 3)))
 198      (when (and (slot-boundp container 'computed-row-heights)
 199                 (slot-boundp container 'computed-column-widths))
 200        (let ((y-row 0))
 201          (loop for row-height in (computed-row-heights-of container)
 202             for iy from 0 do
 203             (let ((x-column 0))
 204               (loop for column-width in (computed-column-widths-of container)
 205                  for ix from 0 do
 206                  (when (and (>= x x-column)
 207                             (<= x (+ column-width x-column))
 208                             (>= y y-row)
 209                             (<= y (+ row-height y-row)))
 210                    (let ((widget (aref (contents-of container) iy ix)))
 211                      (when widget
 212                        ,@forms)))
 213                  (incf x-column column-width)))
 214             (incf y-row row-height))))))
 215
 216 (define-propogating-container-method handle-mouse-button (button press x y)
 217   (handle-mouse-button widget
 218                        button press
 219                        (- x (current-offset-of (x widget)))
 220                        (- y (current-offset-of (y widget)))))
 221
 222 (define-propogating-container-method handle-mouse-wheel (zrel x y)
 223   (handle-mouse-wheel widget
 224                       zrel
 225                       (- x (current-offset-of (x widget)))
 226                       (- y (current-offset-of (y widget)))))
 227
 228
 229
 230
 231 (defmacro contents-iterate-forwards (contents widget-name &body forms)
 232   (let ((x (gensym "X"))
 233         (y (gensym "Y"))
 234         (c (gensym "CONTENTS")))
 235     `(let ((,c ,contents))
 236        (loop for ,y below (array-dimension ,c 0) do
 237             (loop for ,x below (array-dimension ,c 1) do
 238                  (let ((,widget-name (aref ,c ,y ,x)))
 239                    ,@forms))))))
 240
 241 (defmacro contents-iterate-backwards (contents widget-name &body forms)
 242   (let ((x (gensym "X"))
 243         (y (gensym "Y"))
 244         (c (gensym "CONTENTS")))
 245     `(let ((,c ,contents))
 246        (loop for ,y from (1- (array-dimension ,c 0)) downto 0 do
 247             (loop for ,x from (1- (array-dimension ,c 1)) downto 0 do
 248                  (let ((,widget-name (aref ,c ,y ,x)))
 249                    ,@forms))))))
 250
 251
 252 (defun find-first-focusable (widget)
 253   "Find the first focusable widget that is widget, or is in widget.
 254 Depth-first search"
 255   (declare (type widget widget))
 256   (cond
 257     ((accept-focus-p widget)
 258      widget)
 259     ((typep widget 'container)
 260      (contents-iterate-forwards (contents-of widget) w
 261        (when (and w (setf w (find-first-focusable w)))
 262          (return-from find-first-focusable w))))))
 263
 264 (defun find-last-focusable (widget)
 265   "Find the last focusable widget that is widget, or is in widget.
 266 Depth-first search"
 267   (declare (type widget widget))
 268   (cond
 269     ((accept-focus-p widget)
 270      widget)
 271     ((typep widget 'container)
 272      (contents-iterate-backwards (contents-of widget) w
 273        (when (and w (setf w (find-last-focusable w)))
 274          (return-from find-last-focusable w))))))
 275
 276
 277 (defun next-widget (widget)
 278   (declare (type widget widget))
 279   (let ((parent (when (slot-boundp widget 'parent)
 280                   (parent-of widget))))
 281     (when parent
 282       (when (typep parent 'container)
 283         (let (found)
 284           (contents-iterate-forwards (contents-of parent) w
 285             (if found
 286                 (when (and w (setf w (find-first-focusable w)))
 287                   (return-from next-widget w))
 288                 ;;Found our own widget in the container, from now on, search for something focusable
 289                 (when (eql w widget)
 290                   (setf found t))))))
 291       ;;Nothing was found - go up a level
 292       (next-widget parent))))
 293
 294 (defun prev-widget (widget)
 295   (declare (type widget widget))
 296   (let ((parent (when (slot-boundp widget 'parent)
 297                   (parent-of widget))))
 298     (when parent
 299       (when (typep parent 'container)
 300         (let (found)
 301           (contents-iterate-backwards (contents-of parent) w
 302             (if found
 303                 (when (and w (setf w (find-last-focusable w)))
 304                   (return-from prev-widget w))
 305                 ;;Found our own widget in the container, from now on, search for something focusable
 306                 (when (eql w widget)
 307                   (setf found t))))))
 308       ;;Nothing was found - go up a level
 309       (prev-widget parent))))