1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: gtkstyle.lisp,v 1.4 2007/01/14 23:19:14 espen Exp $
30 (eval-when (:compile-toplevel :load-toplevel :execute)
31 (defbinding %style-font-desc-offset () int))
33 (defclass style (gobject)
37 :setter (setf style-fg)
42 :setter (setf style-bg)
47 :setter (setf style-light)
52 :setter (setf style-dark)
57 :setter (setf style-mid)
62 :setter (setf style-text)
67 :setter (setf style-base)
72 :setter (setf style-text-aa)
77 :setter (setf style-black)
82 :setter (setf style-white)
86 :offset #.(%style-font-desc-offset)
88 :accessor style-font-desc
90 :type pango:font-description)
93 :accessor style-xthickness
98 :accessor style-ythickness
110 :getter style-light-gc)
113 :getter style-dark-gc)
116 :getter style-mid-gc)
119 :getter style-text-gc)
122 :getter style-base-gc)
125 :getter style-text-aa-gc)
128 :getter style-black-gc)
131 :getter style-white-gc))
132 (:metaclass gobject-class))
135 (defbinding style-copy () style
138 (defbinding style-attach () style
142 (defbinding style-detach () style
146 (deftype color-type ()
147 '(enum :fg :bg :light :dark :mid :text :base :text-aa :white :black))
149 (defbinding %style-get-color () (copy-of gdk:color)
151 (color-type color-type)
154 (defbinding %style-set-color () nil
156 (color-type color-type)
160 (defbinding %style-get-gc () gdk:gc
162 (color-type color-type)
165 (defun %style-get-color-vector (style color-type)
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)))
173 (defun %style-set-color-vector (style color-type vector)
175 for (symbol index) in (enum-mapping 'state-type)
176 do (%style-set-color style color-type symbol (svref vector index))))
178 (defun %style-get-gc-vector (style color-type)
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)))
186 (defmacro define-style-color-accessor (name type)
188 (defun ,name (style &optional state)
190 (%style-get-color style ,type state)
191 (%style-get-color-vector style ,type)))
192 (defun (setf ,name) (color style &optional state)
194 (%style-set-color style ,type state color)
195 (%style-set-color-vector style ,type color)))))
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)
206 (defun style-black (style)
207 (%style-get-color style :black :normal))
209 (defun style-white (style)
210 (%style-get-color style :black :normal))
212 (defmacro define-style-gc-reader (name type)
213 `(defun ,name (style &optional state)
215 (%style-get-gc style ,type state)
216 (%style-get-gc-vector style ,type))))
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)
227 (defun style-black-gc (style)
228 (%style-get-gc style :black :normal))
230 (defun style-white-gc (style)
231 (%style-get-gc style :white :normal))