chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gtk / gtkcontainer.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
560af5c5 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:
560af5c5 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
560af5c5 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.
560af5c5 22
d1b6a54e 23;; $Id: gtkcontainer.lisp,v 1.26 2008-05-06 00:04:42 espen Exp $
560af5c5 24
25(in-package "GTK")
4a383aae 26
b3de3ed8 27(defgeneric container-add (container widget &rest args))
28(defgeneric container-remove (container widget))
c78ef85c 29(defgeneric container-all-children (container))
30(defgeneric container-internal-children (container))
b3de3ed8 31(defgeneric (setf container-children) (children container))
32
33
76ff9f39 34(defun initial-add (object function initargs key pkey)
35 (loop
36 as (initarg value . rest) = initargs then rest
37 do (cond
38 ((eq initarg key) (funcall function object value))
39 ((eq initarg pkey) (mapc #'(lambda (value)
40 (funcall function object value))
41 value)))
42 while rest))
43
44(defun initial-apply-add (object function initargs key pkey)
45 (initial-add object #'(lambda (object value)
46 (apply function object (mklist value)))
47 initargs key pkey))
48
49
1047e159 50(defmethod shared-initialize ((container container) names &rest initargs
67b44e86 51 &key child children child-args
76ff9f39 52 (show-children nil show-children-p))
53 (declare (ignore names child children))
67b44e86 54 (when show-children-p
55 (if (not show-children)
56 (setf (user-data container 'show-recursive-p) nil)
57 (signal-connect container 'show #'container-show-recursive
58 :object t :remove t)))
59
560af5c5 60 (call-next-method)
4a383aae 61 (initial-add container
62 #'(lambda (container args)
63 (apply #'container-add container (append (mklist args) child-args)))
64 initargs :child :children))
560af5c5 65
560af5c5 66
4c371500 67(defmethod compute-signal-function ((container container) signal function object args)
76ff9f39 68 (declare (ignore signal))
67b44e86 69 (if (eq object :children)
d1b6a54e 70 #'(lambda (container &rest emission-args)
71 (let ((all-args (nconc emission-args args)))
4c371500 72 (container-foreach container
73 #'(lambda (child)
74 (apply function child all-args)))))
03802c3c 75 (call-next-method)))
76
77
e5b416f0 78(defbinding %container-add () nil
560af5c5 79 (container container)
80 (widget widget))
81
5bf6c64b 82(defun find-child-class (container-class)
83 (or
84 (gethash container-class *container-to-child-class-mappings*)
85 (setf (gethash container-class *container-to-child-class-mappings*)
86 (or
87 (when (eq container-class (find-class 'container))
88 (find-class 'container-child))
89 (find-child-class (find-class (supertype container-class)))))))
90
9fc5c597 91(defun init-child-slots (container child args)
e5b416f0 92 (when args
93 (setf
9fc5c597 94 (slot-value child 'child-properties)
e5b416f0 95 (apply
5bf6c64b 96 #'make-instance (find-child-class (class-of container))
9fc5c597 97 :parent container :child child args))))
98
99(defmethod container-add ((container container) (widget widget) &rest args)
100 (%container-add container widget)
101 (init-child-slots container widget args)
102 widget)
e5b416f0 103
4c371500 104(defmethod container-add ((container container) (widgets list) &rest args)
105 (dolist (widget widgets)
106 (apply #'container-add container widget args)))
107
e5b416f0 108(defbinding %container-remove () nil
560af5c5 109 (container container)
110 (widget widget))
111
f9e76ebe 112(defmethod container-remove ((container container) (widget widget))
e5b416f0 113 (%container-remove container widget)
c289d084 114 (slot-makunbound widget 'child-properties))
e5b416f0 115
116
1f518a51 117(defbinding %container-child-get-property () nil
118 (container container)
119 (child widget)
120 (property-name string)
121 (value gvalue))
122
123(defbinding %container-child-set-property () nil
124 (container container)
125 (child widget)
126 (property-name string)
127 (value gvalue))
128
129
0d270bd9 130(defbinding container-check-resize () nil
560af5c5 131 (container container))
132
56ccd5b7 133(define-callback-marshal %foreach-callback nil (widget))
1de3a418 134
135(defbinding %container-foreach (container callback-id) nil
560af5c5 136 (container container)
56ccd5b7 137 (%foreach-callback callback)
1de3a418 138 (callback-id unsigned-int))
139
140(defun container-foreach (container function)
1a1949c7 141 (with-callback-function (id function)
142 (%container-foreach container id)))
560af5c5 143
d2ba9d86 144(defbinding %container-forall (container callback-id) nil
145 (container container)
56ccd5b7 146 (%foreach-callback callback)
d2ba9d86 147 (callback-id unsigned-int))
148
149(defun container-forall (container function)
150 (with-callback-function (id function)
151 (%container-forall container id)))
152
560af5c5 153(defun map-container (seqtype func container)
154 (case seqtype
155 ((nil)
1047e159 156 (container-foreach container func)
560af5c5 157 nil)
158 (list
159 (let ((list nil))
76ff9f39 160 (container-foreach container
560af5c5 161 #'(lambda (child)
162 (push (funcall func child) list)))
163 (nreverse list)))
164 (t
1de3a418 165 (let ((seq (make-sequence seqtype (container-length container)))
560af5c5 166 (index 0))
76ff9f39 167 (container-foreach container
560af5c5 168 #'(lambda (child)
169 (setf (elt seq index) (funcall func child))
170 (incf index)))
171 seq))))
172
76ff9f39 173(defmethod container-all-children ((container container))
174 (let ((internal ()))
175 (container-forall container
176 #'(lambda (child)
177 (push child internal)))
178 (nreverse internal)))
179
180(defmethod container-internal-children ((container container))
c78ef85c 181 (let ((external-children (container-children container))
76ff9f39 182 (all-children (container-all-children container)))
183 (loop
184 for child in all-children
c78ef85c 185 unless (find child external-children)
76ff9f39 186 collect child)))
e5b416f0 187
188(defmethod (setf container-children) (children (container container))
560af5c5 189 (dolist (child (container-children container))
190 (container-remove container child))
191 (dolist (child children)
d2ba9d86 192 (apply #'container-add container (mklist child)))
560af5c5 193 children)
194
1de3a418 195(defun container-length (container)
196 (let ((n 0))
197 (container-foreach container
198 #'(lambda (child)
199 (declare (ignore child))
200 (incf n)))
201 n))
560af5c5 202
0d270bd9 203(defbinding container-resize-children () nil
560af5c5 204 (container container))
1de3a418 205
206(defbinding container-propagate-expose () nil
207 (container container)
208 (child widget)
209 (event gdk:expose-event))
210
211
212(defbinding %container-get-focus-chain () boolean
213 (container container)
214 (focusable-widgets (glist widget) :out))
215
216(defun container-focus-chain (container)
217 (multiple-value-bind (chain-set-p focusable-widgets)
218 (%container-get-focus-chain container)
219 (and chain-set-p focusable-widgets)))
220
221(defbinding %container-set-focus-chain () nil
222 (container container)
223 (focusable-widgets (glist widget)))
224
225(defbinding %container-unset-focus-chain () nil
226 (container container))
227
228(defun (setf container-focus-chain) (focusable-widgets container)
229 (if (null focusable-widgets)
230 (%container-unset-focus-chain container)
231 (%container-set-focus-chain container focusable-widgets)))
67b44e86 232
233(defgeneric container-show-recursive (container))
234
235(defmethod container-show-recursive ((container container))
76ff9f39 236 "Recursively show any child widgets except widgets explicit hidden during construction."
67b44e86 237 (labels ((recursive-show (widget)
238 (when (typep widget 'container)
239 (if (not (user-data-p widget 'show-recursive-p))
240 (container-foreach widget #'recursive-show)
241 (unset-user-data widget 'show-recursive-p)))
242 (unless (widget-hidden-p widget)
243 (widget-show widget))))
244 (container-foreach container #'recursive-show)))