chiark / gitweb /
Exporting symbols
[clg] / gtk / gtkstyle.lisp
CommitLineData
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))