src/cowl-convenience.lisp

   1
   2 (in-package #:cowl)
   3
   4 (defmacro make-hbox ((&rest container-keyargs) &body contents)
   5   `(make-instance 'container
   6                   ,@container-keyargs
   7                   :contents (list (list ,@contents))
   8                   :column-widths (make-list ,(list-length contents) :initial-element '(:expand . 10))
   9                   :style :hbox))
  10
  11 (defmacro make-vbox ((&rest container-keyargs) &body contents)
  12   `(make-instance 'container
  13                   ,@container-keyargs
  14                   :contents (list ,@(mapcar #'(lambda (widget) `(list ,widget)) contents))
  15                   :row-heights (make-list ,(list-length contents) :initial-element '(:expand . 10))
  16                   :style :vbox))
  17
  18 (defmacro make-grid ((&rest container-keyargs) &body contents)
  19   `(make-instance 'container
  20                   ,@container-keyargs
  21                   :contents (list ,@(mapcar #'(lambda (row) `(list ,@row)) contents))
  22                   :row-heights (make-list ,(list-length contents) :initial-element '(:expand . 10))
  23                   :column-widths (make-list ,(list-length (first contents)) :initial-element '(:expand . 10))
  24                   :style :grid))
  25
  26 (defmacro make-scroll-button ((&rest text-button-keyargs)
  27                               format-text variable-place
  28                               &key (update-p t)
  29                               (wheel-delta-form 0.1)
  30                               minimum
  31                               maximum)
  32   `(labels ((numeric-writer (new-value &optional self)
  33               (prog1 (if ,update-p
  34                          (setf ,variable-place
  35                                ,(cond
  36                                  ((and minimum maximum)
  37                                   `(max ,minimum (min ,maximum new-value)))
  38                                  (minimum `(max ,minimum new-value))
  39                                  (maximum `(min ,maximum new-value))
  40                                  (t 'new-value)))
  41                          ,variable-place)
  42                 (when self (update-text self)))))
  43      (make-instance 'numeric-input ,@text-button-keyargs
  44                     :writer #'numeric-writer
  45                     :text-updater #'(lambda (self)
  46                                       (declare (ignorable self))
  47                                       (if ,update-p (format nil ,format-text ,variable-place) "-"))
  48                     :middle-click
  49                     (lambda (self)
  50                       (declare (ignorable self))
  51                       (funcall #'numeric-writer
  52                                (+ ,variable-place (* ,wheel-delta-form 0.1)))
  53                       t)
  54                     :right-click
  55                     (lambda (self)
  56                       (declare (ignorable self))
  57                       (funcall #'numeric-writer
  58                                (- ,variable-place (* ,wheel-delta-form 0.1)))
  59                       t)
  60                     :wheel
  61                     (lambda (self zrel)
  62                       (declare (ignorable self))
  63                       (funcall #'numeric-writer
  64                                (+ ,variable-place (* zrel ,wheel-delta-form)))
  65                       t))))
  66
  67 (defmacro make-callback-toggle-button ((&rest text-button-initargs)
  68                                        reader-function writer-function)
  69   `(flet ((update-style (self val)
  70             (set-widget-style self (if val :depressed-button :button))))
  71      (let ((button (make-instance
  72              'text-button ,@text-button-initargs
  73              :left-click
  74              #'(lambda (self)
  75                  (update-style self (funcall ,writer-function
  76                                              (not (funcall ,reader-function))))
  77                  t))))
  78        (update-style button (funcall ,reader-function))
  79        button)))
  80
  81 (defmacro make-toggle-button (place &rest text-button-initargs)
  82   `(labels ((reader () ,place)
  83             (writer (val) (setf ,place val)))
  84      (declare (inline reader writer))
  85      (make-callback-toggle-button
  86       (,@text-button-initargs)
  87       #'reader #'writer)))
  88
  89
  90
  91
  92 (defmacro make-clampf-button ((&rest text-button-keyargs) format-text variable-place)
  93   `(make-scroll-button (,@text-button-keyargs)
  94                       ,format-text ,variable-place
  95                       :minimum 0.0
  96                       :maximum 1.0))
  97
  98 (defmacro make-simple-numeric-button ((&rest text-button-keyargs)
  99                                       format-text
 100                                       reader
 101                                       writer
 102                                       &key
 103                                       (delta-form 10)
 104                                       (middle-click-value `(- ,reader (/ ,delta-form 10)))
 105                                       (right-click-value `(+ ,reader (/ ,delta-form 10)))
 106                                       (mouse-wheel-value `(+ ,reader (* zrel ,delta-form))))
 107   "Make a simple numeric button, format-text is the way to format it.
 108 reader is a form to evaluate to get the value.
 109 writer is a function with a single argument to set the new value.
 110 delta-form is a form to increment/decrement the value by if no click/wheel forms are given.
 111 right/middle-click-value are a new form that returns a new value for when that event happens.
 112 mouse-wheel-value is the same, but zrel is bound to the wheel delta.
 113 For these forms, the value of self is bound to the numeric-button."
 114   `(make-instance 'numeric-input ,@text-button-keyargs
 115                   :text-updater #'(lambda (self)
 116                                     (declare (ignorable self))
 117                                     (format nil ,format-text ,reader))
 118                   :writer ,writer
 119                   :middle-click
 120                   #'(lambda (self)
 121                       (declare (ignorable self))
 122                       (funcall ,writer ,middle-click-value)
 123                       (update-text self)
 124                       t)
 125                   :right-click
 126                   #'(lambda (self)
 127                       (declare (ignorable self))
 128                       (funcall ,writer ,right-click-value)
 129                       (update-text self)
 130                       t)
 131                   :wheel
 132                   #'(lambda (self zrel)
 133                       (declare (ignorable self))
 134                       (funcall ,writer ,mouse-wheel-value)
 135                       (update-text self)
 136                       t)))
 137
 138
 139
 140
 141 (defmacro make-button ((&rest text-button-keyargs) text &body left-click-forms)
 142   `(make-instance 'text-button ,@text-button-keyargs
 143                   :text ,text
 144                   :left-click #'(lambda (self)
 145                                   (declare (ignorable self))
 146                                   ,@left-click-forms
 147                                   t)))
 148
 149
 150 (defmacro make-text-block ((&rest text-initargs) text)
 151   `(make-instance 'text ,@text-initargs :wrap t :text ,text :style :text-block :width 600))
 152
 153 (defmacro make-label (text &rest text-initargs)
 154   `(make-instance 'text ,@text-initargs :wrap nil :text ,text :style :label))
 155
 156 (defmacro make-dynamic-text ((&rest text-initargs) &body forms)
 157   `(make-instance 'text ,@text-initargs
 158                   :text-updater #'(lambda (self)
 159                                     (declare (ignorable self))
 160                                     ,@forms)))
 161
 162 (defmacro make-tab-panel (&body text-contents)
 163   `(let ((tab-content-callbacks
 164           (make-array ,(length text-contents)
 165                       :initial-contents
 166                       (list ,@(loop for text-content in text-contents collecting
 167                                    (if (eql (second text-content) :function)
 168                                        `(function ,(third text-content))
 169                                        `(constantly ,@(cdr text-content)))))))
 170          (tab-panel)
 171          (buttons (make-array ,(length text-contents))))
 172      (flet ((update (selected)
 173               (loop for widget across buttons
 174                  for i from 0 do
 175                  (if (= i selected)
 176                      (set-widget-style widget :depressed-button)
 177                      (set-widget-style widget :button)))
 178               (set-cell tab-panel 1 0 (funcall (elt tab-content-callbacks selected)))))
 179        (setf tab-panel
 180              (make-vbox (:row-heights '((:expand . 10) (:weight . 1.0)))
 181                (make-hbox ()
 182                  ,@(loop for text-label in (mapcar #'first text-contents)
 183                       for i from 0 collecting
 184                       `(setf (aref buttons ,i)
 185                             (make-button () ,text-label
 186                                (update ,i)))))
 187                nil))
 188        (update 0)
 189        tab-panel)))
 190
 191
 192 (defun progress-screen (title progress)
 193   (destructuring-bind (display-width display-height)
 194       (let ((viewport (list 0 0 0 0)))
 195         (gl:get-integerv gl:+viewport+ viewport)
 196         (cddr viewport))
 197     (let* ((progress-meter
 198             (make-instance 'progress :width display-width :height 20))
 199            (*root-widget*
 200             (make-vbox (:x 0 :y 0 :width display-width :height display-height
 201                            :row-heights `((:expand . ,(/ display-width 3))
 202                                           (:expand . 20)
 203                                           (:expand . 20)
 204                                           (:expand . ,(/ display-width 3))))
 205               nil
 206               (make-hbox (:column-widths '((:weight . 1.0) (:expand . 10.0) (:weight . 1.0)))
 207                 nil
 208                 (make-instance 'text :text title)
 209                 nil)
 210               progress-meter
 211               nil))
 212            (*ignore-events* t))
 213       (declare (special *ignore-events*))
 214       (gl:clear (logior gl:+color-buffer-bit+))
 215       (setf (progress-of progress-meter) progress)
 216       (draw-cowl))))
 217