/[cells]/cells-gtk/layout.lisp
ViewVC logotype

Contents of /cells-gtk/layout.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Mon Jan 28 23:59:22 2008 UTC (6 years, 2 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
*** empty log message ***
1 #|
2
3 Cells Gtk
4
5 Copyright (c) 2004 by Vasilis Margioulas <vasilism@sch.gr>
6
7 You have the right to distribute and use this software as governed by
8 the terms of the Lisp Lesser GNU Public License (LLGPL):
9
10 (http://opensource.franz.com/preamble.html)
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 Lisp Lesser GNU Public License for more details.
16
17 |#
18
19 (in-package :cgtk)
20
21 (def-widget box ()
22 ()
23 (homogeneous spacing)
24 ()
25 :value (c-in nil)
26 :homogeneous (c-in nil)
27 :spacing (c-in 0))
28
29 (defobserver .kids ((self box))
30 (when new-value
31 (dolist (kid new-value)
32 (gtk-box-pack-start (id self) (id kid)
33 (expand? kid) (fill? kid) (padding? kid)))
34 #+clisp (call-next-method)))
35
36 (def-widget hbox (box)
37 () () ()
38 :new-args (c_1 (list (homogeneous self) (spacing self))))
39 (def-widget vbox (box)
40 () () ()
41 :new-args (c_1 (list (homogeneous self) (spacing self))))
42
43 (def-widget table ()
44 ((elements :accessor elements :initarg :elements :initform (c-in nil))
45 (homogeneous :accessor homogeneous :initarg :homogeneous :initform nil)
46 (rows-count :accessor rows-count :initarg :rows-count :initform (c? (length (elements self))))
47 (cols-count :accessor cols-count :initarg :cols-count
48 :initform (c? (let ((elems (elements self)))
49 (if elems (apply #'max (mapcar #'length elems)) 0)))))
50 ()
51 ()
52 :new-args (c_1 (list (rows-count self) (cols-count self) (homogeneous self)))
53 :kids (c? (apply #'append (mapcar (lambda (x) (remove-if #'null x))
54 (elements self)))))
55
56 (defun next-row-item-not-null (row start-col)
57 (or
58 (loop for item in (subseq row (1+ start-col))
59 for pos from (1+ start-col) do
60 (when item (return pos))
61 finally (return pos))
62 (1+ start-col)))
63
64 (defobserver elements ((self table))
65 (loop for row in new-value
66 for row-num from 0 do
67 (loop for kid in row
68 for col-num from 0 do
69 (when kid
70 (gtk-table-attach (id self) (id kid)
71 col-num (next-row-item-not-null row col-num)
72 row-num (1+ row-num)
73 (logior (if (x-expand kid) (ash 1 0) 0) (if (x-fill kid) (ash 1 2) 0))
74 (logior (if (y-expand kid) (ash 1 0) 0) (if (y-fill kid) (ash 1 2) 0))
75 (x-pad kid)
76 (y-pad kid))))))
77
78 (def-widget hpaned ()
79 ((divider-pos :accessor divider-pos :initarg :divider-pos :initform (c-in 0)))
80 ()
81 ())
82
83 (defobserver divider-pos ((self hpaned))
84 (when new-value
85 (gtk-paned-set-position (id self) new-value)))
86
87 (defobserver .kids ((self hpaned))
88 (when new-value
89 (gtk-paned-add1 (id self) (id (make-be 'frame
90 :shadow 'in
91 :kids (kids-list? (first new-value)))))
92 (and (cadr new-value)
93 (gtk-paned-add2 (id self) (id (make-be 'frame
94 :shadow 'in
95 :kids (kids-list? (cadr new-value)))))))
96 #+clisp (call-next-method))
97
98 (def-widget vpaned ()
99 ((divider-pos :accessor divider-pos :initarg :divider-pos :initform (c-in 0)))
100 ()
101 ())
102
103 (defobserver divider-pos ((self vpaned))
104 (when new-value
105 (gtk-paned-set-position (id self) new-value)))
106
107 (defobserver .kids ((self vpaned))
108 (when new-value
109 (gtk-paned-add1 (id self) (id (make-be 'frame
110 :shadow 'in
111 :kids (kids-list? (first new-value)))))
112 (and (cadr new-value)
113 (gtk-paned-add2 (id self) (id (make-be 'frame
114 :shadow 'in
115 :kids (kids-list? (cadr new-value)))))))
116 #+clisp (call-next-method))
117
118
119 (def-widget frame ()
120 ((shadow :accessor shadow? :initarg :shadow :initform nil)
121 (label :accessor label :initarg :label :initform (c-in nil)))
122 (label-widget label-align shadow-type)
123 ()
124 :shadow-type (c-in nil)
125 :new-args (c_1 (list nil)))
126
127 (defobserver label ((self frame))
128 (when new-value
129 (gtk-frame-set-label (id self) new-value)))
130
131 (defobserver shadow ((self frame))
132 (when new-value
133 (with-integrity (:change 'frame-shadpw)
134 (setf (shadow-type self)
135 (ecase new-value
136 (none 0)
137 (in 1)
138 (out 2)
139 (etched-in 3)
140 (etched-out 4))))))
141
142 (defobserver .kids ((self frame))
143 (assert-bin self)
144 (dolist (kid new-value)
145 (gtk-container-add (id self) (id kid)))
146 #+clisp (call-next-method))
147
148 (def-widget aspect-frame (frame)
149 ((xalign :accessor xalign :initarg :xalign :initform 0.5)
150 (yalign :accessor yalign :initarg :yalign :initform 0.5)
151 (ratio :accessor ratio? :initarg :ratio :initform 1)
152 (obey-child :accessor obey-child :initarg :obey-child :initform nil))
153 () ()
154 :new-args (c_1 (list
155 nil
156 (coerce (xalign self) 'single-float)
157 (coerce (yalign self) 'single-float)
158 (coerce (ratio? self) 'single-float)
159 (obey-child self))))
160
161 (def-widget hseparator ()
162 () () ())
163
164 (def-widget vseparator ()
165 () () ())
166
167 (def-widget expander ()
168 ((label :accessor label :initarg :label :initform (c-in nil)))
169 (expanded spacing use-underline use-markup label-widget)
170 ()
171 :new-args (c_1 (list nil)))
172
173 (defobserver label ((self expander))
174 (when new-value
175 (gtk-expander-set-label (id self) new-value)))
176
177 (defobserver .kids ((self expander))
178 (assert-bin self)
179 (dolist (kid new-value)
180 (gtk-container-add (id self) (id kid)))
181 #+clisp (call-next-method))
182
183 (def-widget scrolled-window ()
184 ()
185 (policy placement shadow-type)
186 ()
187 :expand t :fill t
188 :policy (list 1 1)
189 :new-args (list +c-null+ +c-null+))
190
191 (defobserver .kids ((self scrolled-window))
192 (assert-bin self)
193 (dolist (kid new-value)
194 (if (member (class-name (class-of kid)) '(listbox treebox tree-view text-view layout) :test #'equal)
195 (gtk-container-add (id self) (id kid))
196 (gtk-scrolled-window-add-with-viewport (id self) (id kid))))
197 #+clisp (call-next-method))
198
199 (def-widget notebook ()
200 ((tab-labels :accessor tab-labels :initarg :tab-labels :initform (c-in nil))
201 (tab-labels-widgets :accessor tab-labels-widgets :initform (c-in nil))
202 (show-page :accessor show-page :initarg :show-page :initform (c-in 0))
203 (tab-pos :accessor tab-pos :initarg :tab-pos :initform (c-in nil)))
204 (current-page show-tabs show-border scrollable tab-border
205 homogeneous-tabs)
206 ()
207 :current-page (c-in nil)
208 :show-tabs (c-in t))
209
210 (defobserver tab-pos ((self notebook))
211 (when new-value
212 (gtk-notebook-set-tab-pos
213 (id self)
214 (case new-value
215 (:left 0)
216 (:right 1)
217 (:top 2)
218 (:bottom 3)
219 (t 2)))))
220
221 (defun notebook-contains-page-p (notebook widget &aux (wid (cffi:pointer-address (id widget))))
222 (loop for i from 1 to (gtk-notebook-get-n-pages (id notebook))
223 for page = (gtk-notebook-get-nth-page (id notebook) (1- i))
224 when (= wid (cffi:pointer-address page)) return t))
225
226 (defobserver show-page ((self notebook))
227 (when (and new-value (>= new-value 0) (< new-value (length (kids self))))
228 (setf (current-page self) new-value)))
229
230 (defobserver .kids ((self notebook))
231 ;(dolist (widget (tab-labels-widgets self)) ;; This was from the original code.
232 ; (not-to-be widget)) ;; It causes errors.
233 (with-integrity (:change 'notebook-kids)
234 (loop for kid in new-value
235 for pos from 0
236 for label = (nth pos (tab-labels self))
237 unless (notebook-contains-page-p self kid) do
238 (let ((lbl (and label (make-be 'label :text label))))
239 (when lbl (push lbl (tab-labels-widgets self)))
240 (gtk-notebook-append-page (id self) (id kid) (and lbl (id lbl)))))
241 (loop for page from 0 to (length new-value) do
242 (setf (current-page self) page))
243 (when (and (show-page self) (>= (show-page self) 0) (< (show-page self) (length new-value)))
244 (setf (current-page self) (show-page self)))
245 #+clisp (call-next-method)))
246
247 (def-widget alignment ()
248 ((xalign :accessor xalign :initarg :xalign :initform 0.5)
249 (yalign :accessor yalign :initarg :yalign :initform 0.5)
250 (xscale :accessor xscale :initarg :xscale :initform 0)
251 (yscale :accessor yscale :initarg :yscale :initform 0))
252 ()
253 ()
254 :new-args (c_1 (list (coerce (xalign self) 'single-float)
255 (coerce (yalign self) 'single-float)
256 (coerce (xscale self) 'single-float)
257 (coerce (yscale self) 'single-float))))
258
259 (defobserver xalign ((self alignment))
260 (when new-value
261 (gtk-alignment-set
262 (id self)
263 (coerce (xalign self) 'single-float)
264 (coerce (yalign self) 'single-float)
265 (coerce (xscale self) 'single-float)
266 (coerce (yscale self) 'single-float))))
267 (defobserver yalign ((self alignment))
268 (when new-value
269 (gtk-alignment-set
270 (id self)
271 (coerce (xalign self) 'single-float)
272 (coerce (yalign self) 'single-float)
273 (coerce (xscale self) 'single-float)
274 (coerce (yscale self) 'single-float))))
275 (defobserver xscale ((self alignment))
276 (when new-value
277 (gtk-alignment-set
278 (id self)
279 (coerce (xalign self) 'single-float)
280 (coerce (yalign self) 'single-float)
281 (coerce (xscale self) 'single-float)
282 (coerce (yscale self) 'single-float))))
283 (defobserver yscale ((self alignment))
284 (when new-value
285 (gtk-alignment-set
286 (id self)
287 (coerce (xalign self) 'single-float)
288 (coerce (yalign self) 'single-float)
289 (coerce (xscale self) 'single-float)
290 (coerce (yscale self) 'single-float))))
291
292
293 (defobserver .kids ((self alignment))
294 (assert-bin self)
295 (dolist (kid new-value)
296 (gtk-container-add (id self) (id kid)))
297 #+clisp (call-next-method))

  ViewVC Help
Powered by ViewVC 1.1.5