chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gtk / gtkstyle.lisp
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))