3b1ba482 |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
2 | ;; Copyright (C) 1999-2004 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
4 | ;; This library is free software; you can redistribute it and/or |
5 | ;; modify it under the terms of the GNU Lesser General Public |
6 | ;; License as published by the Free Software Foundation; either |
7 | ;; version 2 of the License, or (at your option) any later version. |
8 | ;; |
9 | ;; This library is distributed in the hope that it will be useful, |
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;; Lesser General Public License for more details. |
13 | ;; |
14 | ;; You should have received a copy of the GNU Lesser General Public |
15 | ;; License along with this library; if not, write to the Free Software |
16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
17 | |
57a54f53 |
18 | ;; $Id: gtkstyle.lisp,v 1.2 2005-04-17 21:43:16 espen Exp $ |
3b1ba482 |
19 | |
20 | (in-package "GTK") |
21 | |
22 | |
23 | ;;; Styles |
24 | |
25 | (eval-when (:compile-toplevel :load-toplevel :execute) |
26 | (defbinding %style-font-desc-offset () int)) |
27 | |
28 | (defclass style (gobject) |
29 | ((fg |
30 | :allocation :virtual |
31 | :getter style-fg |
32 | :setter (setf style-fg) |
33 | :initarg :fg) |
34 | (bg |
35 | :allocation :virtual |
36 | :getter style-bg |
37 | :setter (setf style-bg) |
38 | :initarg :bg) |
39 | (light |
40 | :allocation :virtual |
41 | :getter style-light |
42 | :setter (setf style-light) |
43 | :initarg :light) |
44 | (dark |
45 | :allocation :virtual |
46 | :getter style-dark |
47 | :setter (setf style-dark) |
48 | :initarg :dark) |
49 | (mid |
50 | :allocation :virtual |
51 | :getter style-mid |
52 | :setter (setf style-mid) |
53 | :initarg :mid) |
54 | (text |
55 | :allocation :virtual |
56 | :getter style-text |
57 | :setter (setf style-text) |
58 | :initarg :text) |
59 | (base |
60 | :allocation :virtual |
61 | :getter style-base |
62 | :setter (setf style-base) |
63 | :initarg :base) |
64 | (text-aa |
65 | :allocation :virtual |
66 | :getter style-text-aa |
67 | :setter (setf style-text-aa) |
68 | :initarg :text-aa) |
69 | (black |
70 | :allocation :virtual |
71 | :getter style-black |
72 | :setter (setf style-black) |
73 | :initarg :black) |
74 | (white |
75 | :allocation :virtual |
76 | :getter style-white |
77 | :setter (setf style-white) |
78 | :initarg :white) |
79 | |
80 | (font-desc |
81 | :offset #.(%style-font-desc-offset) |
82 | :allocation :alien |
83 | :accessor style-font-desc |
84 | :initarg :font-desc |
85 | :type pango:font-description) |
86 | (xthickness |
87 | :allocation :alien |
88 | :accessor style-xthickness |
89 | :initarg :xthickness |
90 | :type int) |
91 | (ythickness |
92 | :allocation :alien |
93 | :accessor style-ythickness |
94 | :initarg :ythickness |
95 | :type int) |
96 | |
97 | (fg-gc |
98 | :allocation :virtual |
99 | :getter style-fg-gc) |
100 | (bg-gc |
101 | :allocation :virtual |
102 | :getter style-bg-gc) |
103 | (light-gc |
104 | :allocation :virtual |
105 | :getter style-light-gc) |
106 | (dark-gc |
107 | :allocation :virtual |
108 | :getter style-dark-gc) |
109 | (mid-gc |
110 | :allocation :virtual |
111 | :getter style-mid-gc) |
112 | (text-gc |
113 | :allocation :virtual |
114 | :getter style-text-gc) |
115 | (base-gc |
116 | :allocation :virtual |
117 | :getter style-base-gc) |
118 | (text-aa-gc |
119 | :allocation :virtual |
120 | :getter style-text-aa-gc) |
121 | (black-gc |
122 | :allocation :virtual |
123 | :getter style-black-gc) |
124 | (white-gc |
125 | :allocation :virtual |
126 | :getter style-white-gc)) |
127 | (:metaclass gobject-class)) |
128 | |
129 | |
130 | (defbinding style-copy () style |
131 | (style style)) |
132 | |
133 | (defbinding style-attach () style |
134 | (style style) |
135 | (window window)) |
136 | |
137 | (defbinding style-detach () style |
138 | (style style)) |
139 | |
140 | |
141 | (deftype color-type () |
142 | '(enum :fg :bg :light :dark :mid :text :base :text-aa :white :black)) |
143 | |
144 | (defbinding %style-get-color () (copy-of gdk:color) |
145 | (style style) |
146 | (color-type color-type) |
147 | (state state-type)) |
148 | |
149 | (defbinding %style-set-color () nil |
150 | (style style) |
151 | (color-type color-type) |
152 | (state state-type) |
153 | (color gdk:color)) |
154 | |
155 | (defbinding %style-get-gc () gdk:gc |
156 | (style style) |
157 | (color-type color-type) |
158 | (state state-type)) |
159 | |
160 | (defun %style-get-color-vector (style color-type) |
161 | (loop |
162 | with states = (enum-mapping 'state-type) |
163 | with vector = (make-array (length states)) |
164 | for (symbol index) in states |
165 | do (setf (svref vector index) (%style-get-color style color-type symbol)) |
166 | finally (return vector))) |
167 | |
168 | (defun %style-set-color-vector (style color-type vector) |
169 | (loop |
170 | for (symbol index) in (enum-mapping 'state-type) |
171 | do (%style-set-color style color-type symbol (svref vector index)))) |
172 | |
173 | (defun %style-get-gc-vector (style color-type) |
174 | (loop |
175 | with states = (enum-mapping 'state-type) |
176 | with vector = (make-array (length states)) |
177 | for (symbol index) in states |
178 | do (setf (svref vector index) (%style-get-gc style color-type symbol)) |
179 | finally (return vector))) |
180 | |
181 | (defmacro define-style-color-accessor (name type) |
182 | `(progn |
183 | (defun ,name (style &optional state) |
184 | (if state |
185 | (%style-get-color style ,type state) |
186 | (%style-get-color-vector style ,type))) |
187 | (defun (setf ,name) (color style &optional state) |
188 | (if state |
189 | (%style-set-color style ,type state color) |
190 | (%style-set-color-vector style ,type color))))) |
191 | |
192 | (define-style-color-accessor style-fg :fg) |
193 | (define-style-color-accessor style-bg :bg) |
194 | (define-style-color-accessor style-light :light) |
195 | (define-style-color-accessor style-dark :dark) |
196 | (define-style-color-accessor style-mid :mid) |
197 | (define-style-color-accessor style-text :text) |
198 | (define-style-color-accessor style-base :base) |
199 | (define-style-color-accessor style-text-aa :text-aa) |
200 | |
201 | (defun style-black (style) |
202 | (%style-get-color style :black :normal)) |
203 | |
204 | (defun style-white (style) |
205 | (%style-get-color style :black :normal)) |
206 | |
207 | (defmacro define-style-gc-reader (name type) |
208 | `(defun ,name (style &optional state) |
209 | (if state |
210 | (%style-get-gc style ,type state) |
211 | (%style-get-gc-vector style ,type)))) |
212 | |
213 | (define-style-gc-reader style-fg-gc :fg) |
214 | (define-style-gc-reader style-bg-gc :bg) |
215 | (define-style-gc-reader style-light-gc :light) |
216 | (define-style-gc-reader style-dark-gc :dark) |
217 | (define-style-gc-reader style-mid-gc :mid) |
218 | (define-style-gc-reader style-text-gc :text) |
219 | (define-style-gc-reader style-base-gc :base) |
220 | (define-style-gc-reader style-text-aa-gc :text-aa) |
221 | |
222 | (defun style-black-gc (style) |
223 | (%style-get-gc style :black :normal)) |
224 | |
225 | (defun style-white-gc (style) |
226 | (%style-get-gc style :white :normal)) |
57a54f53 |
227 | |
228 | (export |
229 | '(style-fg style-bg style-light style-dark style-mid style-text style-base |
230 | style-text-aa style-fg-gc style-bg-gc style-light-gc style-dark-gc |
231 | style-mid-gc style-text-gc style-base-gc style-text-aa-gc)) |