112ac1d3 |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net> |
3b1ba482 |
3 | ;; |
112ac1d3 |
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: |
3b1ba482 |
11 | ;; |
112ac1d3 |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
3b1ba482 |
14 | ;; |
112ac1d3 |
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. |
3b1ba482 |
22 | |
112ac1d3 |
23 | ;; $Id: gtkstyle.lisp,v 1.3 2005-04-23 16:48:52 espen Exp $ |
3b1ba482 |
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)) |
57a54f53 |
232 | |
233 | (export |
234 | '(style-fg style-bg style-light style-dark style-mid style-text style-base |
235 | style-text-aa style-fg-gc style-bg-gc style-light-gc style-dark-gc |
236 | style-mid-gc style-text-gc style-base-gc style-text-aa-gc)) |