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.18 2005/04/23 16:48:52 espen Exp $
27 (defmethod shared-initialize ((container container) names &rest initargs
28 &key child children child-args
29 (show-children nil show-children-p))
30 (declare (ignore child children))
32 (if (not show-children)
33 (setf (user-data container 'show-recursive-p) nil)
34 (signal-connect container 'show #'container-show-recursive
35 :object t :remove t)))
38 (initial-add container
39 #'(lambda (container args)
40 (apply #'container-add container (append (mklist args) child-args)))
41 initargs :child :children))
44 (defmethod compute-signal-function ((container container) signal function object)
45 (if (eq object :children)
46 #'(lambda (&rest args)
47 (mapc #'(lambda (child)
48 (apply function child (rest args)))
49 (container-children container)))
53 (defbinding %container-add () nil
57 (defmethod container-add ((container container) (widget widget) &rest args)
58 (%container-add container widget)
61 (slot-value widget 'child-properties)
64 (gethash (class-of container) *container-to-child-class-mappings*)
65 :parent container :child widget args))))
67 (defbinding %container-remove () nil
71 (defmethod container-remove ((container container) (widget widget))
72 (%container-remove container widget)
73 (slot-makunbound widget 'child-properties))
76 (defbinding %container-child-get-property () nil
79 (property-name string)
82 (defbinding %container-child-set-property () nil
85 (property-name string)
89 (defbinding container-check-resize () nil
90 (container container))
92 (def-callback-marshal %foreach-callback (nil widget))
94 (defbinding %container-foreach (container callback-id) nil
96 ((callback %foreach-callback) pointer)
97 (callback-id unsigned-int))
99 (defun container-foreach (container function)
100 (with-callback-function (id function)
101 (%container-foreach container id)))
103 (defbinding %container-forall (container callback-id) nil
104 (container container)
105 ((callback %foreach-callback) pointer)
106 (callback-id unsigned-int))
108 (defun container-forall (container function)
109 (with-callback-function (id function)
110 (%container-forall container id)))
112 (defun map-container (seqtype func container)
115 (container-foreach container func)
122 (push (funcall func child) list)))
125 (let ((seq (make-sequence seqtype (container-length container)))
130 (setf (elt seq index) (funcall func child))
134 (defmethod container-children ((container container))
135 (map-container 'list #'identity container))
137 (defmethod (setf container-children) (children (container container))
138 (dolist (child (container-children container))
139 (container-remove container child))
140 (dolist (child children)
141 (apply #'container-add container (mklist child)))
144 (defun container-length (container)
146 (container-foreach container
148 (declare (ignore child))
152 (defbinding container-resize-children () nil
153 (container container))
155 (defbinding container-propagate-expose () nil
156 (container container)
158 (event gdk:expose-event))
161 (defbinding %container-get-focus-chain () boolean
162 (container container)
163 (focusable-widgets (glist widget) :out))
165 (defun container-focus-chain (container)
166 (multiple-value-bind (chain-set-p focusable-widgets)
167 (%container-get-focus-chain container)
168 (and chain-set-p focusable-widgets)))
170 (defbinding %container-set-focus-chain () nil
171 (container container)
172 (focusable-widgets (glist widget)))
174 (defbinding %container-unset-focus-chain () nil
175 (container container))
177 (defun (setf container-focus-chain) (focusable-widgets container)
178 (if (null focusable-widgets)
179 (%container-unset-focus-chain container)
180 (%container-set-focus-chain container focusable-widgets)))
182 (defgeneric container-show-recursive (container))
184 (defmethod container-show-recursive ((container container))
185 "Recursively shows any child widgets except widgets explicit hidden during construction."
186 (labels ((recursive-show (widget)
187 (when (typep widget 'container)
188 (if (not (user-data-p widget 'show-recursive-p))
189 (container-foreach widget #'recursive-show)
190 (unset-user-data widget 'show-recursive-p)))
191 (unless (widget-hidden-p widget)
192 (widget-show widget))))
193 (container-foreach container #'recursive-show)))