| 1 | ;; Common Lisp bindings for GTK+ v2.x |
| 2 | ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net> |
| 3 | ;; |
| 4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
| 5 | ;; a copy of this software and associated documentation files (the |
| 6 | ;; "Software"), to deal in the Software without restriction, including |
| 7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
| 8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
| 9 | ;; permit persons to whom the Software is furnished to do so, subject to |
| 10 | ;; the following conditions: |
| 11 | ;; |
| 12 | ;; The above copyright notice and this permission notice shall be |
| 13 | ;; included in all copies or substantial portions of the Software. |
| 14 | ;; |
| 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
| 16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
| 17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
| 18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
| 19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
| 20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
| 21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
| 22 | |
| 23 | ;; $Id: gtkstyle.lisp,v 1.4 2007/01/14 23:19:14 espen Exp $ |
| 24 | |
| 25 | (in-package "GTK") |
| 26 | |
| 27 | |
| 28 | ;;; Styles |
| 29 | |
| 30 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 31 | (defbinding %style-font-desc-offset () int)) |
| 32 | |
| 33 | (defclass style (gobject) |
| 34 | ((fg |
| 35 | :allocation :virtual |
| 36 | :getter style-fg |
| 37 | :setter (setf style-fg) |
| 38 | :initarg :fg) |
| 39 | (bg |
| 40 | :allocation :virtual |
| 41 | :getter style-bg |
| 42 | :setter (setf style-bg) |
| 43 | :initarg :bg) |
| 44 | (light |
| 45 | :allocation :virtual |
| 46 | :getter style-light |
| 47 | :setter (setf style-light) |
| 48 | :initarg :light) |
| 49 | (dark |
| 50 | :allocation :virtual |
| 51 | :getter style-dark |
| 52 | :setter (setf style-dark) |
| 53 | :initarg :dark) |
| 54 | (mid |
| 55 | :allocation :virtual |
| 56 | :getter style-mid |
| 57 | :setter (setf style-mid) |
| 58 | :initarg :mid) |
| 59 | (text |
| 60 | :allocation :virtual |
| 61 | :getter style-text |
| 62 | :setter (setf style-text) |
| 63 | :initarg :text) |
| 64 | (base |
| 65 | :allocation :virtual |
| 66 | :getter style-base |
| 67 | :setter (setf style-base) |
| 68 | :initarg :base) |
| 69 | (text-aa |
| 70 | :allocation :virtual |
| 71 | :getter style-text-aa |
| 72 | :setter (setf style-text-aa) |
| 73 | :initarg :text-aa) |
| 74 | (black |
| 75 | :allocation :virtual |
| 76 | :getter style-black |
| 77 | :setter (setf style-black) |
| 78 | :initarg :black) |
| 79 | (white |
| 80 | :allocation :virtual |
| 81 | :getter style-white |
| 82 | :setter (setf style-white) |
| 83 | :initarg :white) |
| 84 | |
| 85 | (font-desc |
| 86 | :offset #.(%style-font-desc-offset) |
| 87 | :allocation :alien |
| 88 | :accessor style-font-desc |
| 89 | :initarg :font-desc |
| 90 | :type pango:font-description) |
| 91 | (xthickness |
| 92 | :allocation :alien |
| 93 | :accessor style-xthickness |
| 94 | :initarg :xthickness |
| 95 | :type int) |
| 96 | (ythickness |
| 97 | :allocation :alien |
| 98 | :accessor style-ythickness |
| 99 | :initarg :ythickness |
| 100 | :type int) |
| 101 | |
| 102 | (fg-gc |
| 103 | :allocation :virtual |
| 104 | :getter style-fg-gc) |
| 105 | (bg-gc |
| 106 | :allocation :virtual |
| 107 | :getter style-bg-gc) |
| 108 | (light-gc |
| 109 | :allocation :virtual |
| 110 | :getter style-light-gc) |
| 111 | (dark-gc |
| 112 | :allocation :virtual |
| 113 | :getter style-dark-gc) |
| 114 | (mid-gc |
| 115 | :allocation :virtual |
| 116 | :getter style-mid-gc) |
| 117 | (text-gc |
| 118 | :allocation :virtual |
| 119 | :getter style-text-gc) |
| 120 | (base-gc |
| 121 | :allocation :virtual |
| 122 | :getter style-base-gc) |
| 123 | (text-aa-gc |
| 124 | :allocation :virtual |
| 125 | :getter style-text-aa-gc) |
| 126 | (black-gc |
| 127 | :allocation :virtual |
| 128 | :getter style-black-gc) |
| 129 | (white-gc |
| 130 | :allocation :virtual |
| 131 | :getter style-white-gc)) |
| 132 | (:metaclass gobject-class)) |
| 133 | |
| 134 | |
| 135 | (defbinding style-copy () style |
| 136 | (style style)) |
| 137 | |
| 138 | (defbinding style-attach () style |
| 139 | (style style) |
| 140 | (window window)) |
| 141 | |
| 142 | (defbinding style-detach () style |
| 143 | (style style)) |
| 144 | |
| 145 | |
| 146 | (deftype color-type () |
| 147 | '(enum :fg :bg :light :dark :mid :text :base :text-aa :white :black)) |
| 148 | |
| 149 | (defbinding %style-get-color () (copy-of gdk:color) |
| 150 | (style style) |
| 151 | (color-type color-type) |
| 152 | (state state-type)) |
| 153 | |
| 154 | (defbinding %style-set-color () nil |
| 155 | (style style) |
| 156 | (color-type color-type) |
| 157 | (state state-type) |
| 158 | (color gdk:color)) |
| 159 | |
| 160 | (defbinding %style-get-gc () gdk:gc |
| 161 | (style style) |
| 162 | (color-type color-type) |
| 163 | (state state-type)) |
| 164 | |
| 165 | (defun %style-get-color-vector (style color-type) |
| 166 | (loop |
| 167 | with states = (enum-mapping 'state-type) |
| 168 | with vector = (make-array (length states)) |
| 169 | for (symbol index) in states |
| 170 | do (setf (svref vector index) (%style-get-color style color-type symbol)) |
| 171 | finally (return vector))) |
| 172 | |
| 173 | (defun %style-set-color-vector (style color-type vector) |
| 174 | (loop |
| 175 | for (symbol index) in (enum-mapping 'state-type) |
| 176 | do (%style-set-color style color-type symbol (svref vector index)))) |
| 177 | |
| 178 | (defun %style-get-gc-vector (style color-type) |
| 179 | (loop |
| 180 | with states = (enum-mapping 'state-type) |
| 181 | with vector = (make-array (length states)) |
| 182 | for (symbol index) in states |
| 183 | do (setf (svref vector index) (%style-get-gc style color-type symbol)) |
| 184 | finally (return vector))) |
| 185 | |
| 186 | (defmacro define-style-color-accessor (name type) |
| 187 | `(progn |
| 188 | (defun ,name (style &optional state) |
| 189 | (if state |
| 190 | (%style-get-color style ,type state) |
| 191 | (%style-get-color-vector style ,type))) |
| 192 | (defun (setf ,name) (color style &optional state) |
| 193 | (if state |
| 194 | (%style-set-color style ,type state color) |
| 195 | (%style-set-color-vector style ,type color))))) |
| 196 | |
| 197 | (define-style-color-accessor style-fg :fg) |
| 198 | (define-style-color-accessor style-bg :bg) |
| 199 | (define-style-color-accessor style-light :light) |
| 200 | (define-style-color-accessor style-dark :dark) |
| 201 | (define-style-color-accessor style-mid :mid) |
| 202 | (define-style-color-accessor style-text :text) |
| 203 | (define-style-color-accessor style-base :base) |
| 204 | (define-style-color-accessor style-text-aa :text-aa) |
| 205 | |
| 206 | (defun style-black (style) |
| 207 | (%style-get-color style :black :normal)) |
| 208 | |
| 209 | (defun style-white (style) |
| 210 | (%style-get-color style :black :normal)) |
| 211 | |
| 212 | (defmacro define-style-gc-reader (name type) |
| 213 | `(defun ,name (style &optional state) |
| 214 | (if state |
| 215 | (%style-get-gc style ,type state) |
| 216 | (%style-get-gc-vector style ,type)))) |
| 217 | |
| 218 | (define-style-gc-reader style-fg-gc :fg) |
| 219 | (define-style-gc-reader style-bg-gc :bg) |
| 220 | (define-style-gc-reader style-light-gc :light) |
| 221 | (define-style-gc-reader style-dark-gc :dark) |
| 222 | (define-style-gc-reader style-mid-gc :mid) |
| 223 | (define-style-gc-reader style-text-gc :text) |
| 224 | (define-style-gc-reader style-base-gc :base) |
| 225 | (define-style-gc-reader style-text-aa-gc :text-aa) |
| 226 | |
| 227 | (defun style-black-gc (style) |
| 228 | (%style-get-gc style :black :normal)) |
| 229 | |
| 230 | (defun style-white-gc (style) |
| 231 | (%style-get-gc style :white :normal)) |