1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: gtkcontainer.lisp,v 1.24 2007-07-04 14:24:54 espen Exp $
27 (defgeneric container-add (container widget &rest args))
28 (defgeneric container-remove (container widget))
29 (defgeneric container-all-children (container))
30 (defgeneric container-internal-children (container))
31 (defgeneric (setf container-children) (children container))
34 (defun initial-add (object function initargs key pkey)
36 as (initarg value . rest) = initargs then rest
38 ((eq initarg key) (funcall function object value))
39 ((eq initarg pkey) (mapc #'(lambda (value)
40 (funcall function object value))
44 (defun initial-apply-add (object function initargs key pkey)
45 (initial-add object #'(lambda (object value)
46 (apply function object (mklist value)))
50 (defmethod shared-initialize ((container container) names &rest initargs
51 &key child children child-args
52 (show-children nil show-children-p))
53 (declare (ignore names child children))
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)))
61 (initial-add container
62 #'(lambda (container args)
63 (apply #'container-add container (append (mklist args) child-args)))
64 initargs :child :children))
67 (defmethod compute-signal-function ((container container) signal function object args)
68 (declare (ignore signal))
69 (if (eq object :children)
70 #'(lambda (&rest emission-args)
71 (let ((all-args (nconc (rest emission-args) args)))
72 (container-foreach container
74 (apply function child all-args)))))
78 (defbinding %container-add () nil
82 (defun init-child-slots (container child args)
85 (slot-value child 'child-properties)
88 (gethash (class-of container) *container-to-child-class-mappings*)
89 :parent container :child child args))))
91 (defmethod container-add ((container container) (widget widget) &rest args)
92 (%container-add container widget)
93 (init-child-slots container widget args)
96 (defmethod container-add ((container container) (widgets list) &rest args)
97 (dolist (widget widgets)
98 (apply #'container-add container widget args)))
100 (defbinding %container-remove () nil
101 (container container)
104 (defmethod container-remove ((container container) (widget widget))
105 (%container-remove container widget)
106 (slot-makunbound widget 'child-properties))
109 (defbinding %container-child-get-property () nil
110 (container container)
112 (property-name string)
115 (defbinding %container-child-set-property () nil
116 (container container)
118 (property-name string)
122 (defbinding container-check-resize () nil
123 (container container))
125 (define-callback-marshal %foreach-callback nil (widget))
127 (defbinding %container-foreach (container callback-id) nil
128 (container container)
129 (%foreach-callback callback)
130 (callback-id unsigned-int))
132 (defun container-foreach (container function)
133 (with-callback-function (id function)
134 (%container-foreach container id)))
136 (defbinding %container-forall (container callback-id) nil
137 (container container)
138 (%foreach-callback callback)
139 (callback-id unsigned-int))
141 (defun container-forall (container function)
142 (with-callback-function (id function)
143 (%container-forall container id)))
145 (defun map-container (seqtype func container)
148 (container-foreach container func)
152 (container-foreach container
154 (push (funcall func child) list)))
157 (let ((seq (make-sequence seqtype (container-length container)))
159 (container-foreach container
161 (setf (elt seq index) (funcall func child))
165 (defmethod container-all-children ((container container))
167 (container-forall container
169 (push child internal)))
170 (nreverse internal)))
172 (defmethod container-internal-children ((container container))
173 (let ((external-children (container-children container))
174 (all-children (container-all-children container)))
176 for child in all-children
177 unless (find child external-children)
180 (defmethod (setf container-children) (children (container container))
181 (dolist (child (container-children container))
182 (container-remove container child))
183 (dolist (child children)
184 (apply #'container-add container (mklist child)))
187 (defun container-length (container)
189 (container-foreach container
191 (declare (ignore child))
195 (defbinding container-resize-children () nil
196 (container container))
198 (defbinding container-propagate-expose () nil
199 (container container)
201 (event gdk:expose-event))
204 (defbinding %container-get-focus-chain () boolean
205 (container container)
206 (focusable-widgets (glist widget) :out))
208 (defun container-focus-chain (container)
209 (multiple-value-bind (chain-set-p focusable-widgets)
210 (%container-get-focus-chain container)
211 (and chain-set-p focusable-widgets)))
213 (defbinding %container-set-focus-chain () nil
214 (container container)
215 (focusable-widgets (glist widget)))
217 (defbinding %container-unset-focus-chain () nil
218 (container container))
220 (defun (setf container-focus-chain) (focusable-widgets container)
221 (if (null focusable-widgets)
222 (%container-unset-focus-chain container)
223 (%container-set-focus-chain container focusable-widgets)))
225 (defgeneric container-show-recursive (container))
227 (defmethod container-show-recursive ((container container))
228 "Recursively show any child widgets except widgets explicit hidden during construction."
229 (labels ((recursive-show (widget)
230 (when (typep widget 'container)
231 (if (not (user-data-p widget 'show-recursive-p))
232 (container-foreach widget #'recursive-show)
233 (unset-user-data widget 'show-recursive-p)))
234 (unless (widget-hidden-p widget)
235 (widget-show widget))))
236 (container-foreach container #'recursive-show)))