1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;; Lesser General Public License for more details.
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 ;; $Id: gtkcontainer.lisp,v 1.16 2005/01/06 21:00:53 espen Exp $
23 (defmethod shared-initialize ((container container) names &rest initargs
24 &key child children child-args)
25 (declare (ignore child children))
27 (initial-add container
28 #'(lambda (container args)
29 (apply #'container-add container (append (mklist args) child-args)))
30 initargs :child :children))
33 (defmethod create-callback-function ((container container) function arg1)
34 (if (eq arg1 :children)
35 #'(lambda (&rest args)
36 (mapc #'(lambda (child)
37 (apply function child (rest args)))
38 (container-children container)))
42 (defbinding %container-add () nil
46 (defmethod container-add ((container container) (widget widget) &rest args)
47 (%container-add container widget)
50 (slot-value widget 'child-properties)
53 (gethash (class-of container) *container-to-child-class-mappings*)
54 :parent container :child widget args))))
57 (defbinding %container-remove () nil
61 (defmethod container-remove ((container container) (widget widget))
62 (%container-remove container widget)
63 (slot-makunbound widget 'child-properties))
66 (defbinding %container-child-get-property () nil
69 (property-name string)
72 (defbinding %container-child-set-property () nil
75 (property-name string)
79 (defbinding container-check-resize () nil
80 (container container))
82 (def-callback-marshal %foreach-callback (nil widget))
84 (defbinding %container-foreach (container callback-id) nil
86 ((callback %foreach-callback) pointer)
87 (callback-id unsigned-int))
89 (defun container-foreach (container function)
90 (with-callback-function (id function)
91 (%container-foreach container id)))
93 (defbinding %container-forall (container callback-id) nil
95 ((callback %foreach-callback) pointer)
96 (callback-id unsigned-int))
98 (defun container-forall (container function)
99 (with-callback-function (id function)
100 (%container-forall container id)))
102 (defun map-container (seqtype func container)
105 (container-foreach container func)
112 (push (funcall func child) list)))
115 (let ((seq (make-sequence seqtype (container-length container)))
120 (setf (elt seq index) (funcall func child))
124 (defmethod container-children ((container container))
125 (map-container 'list #'identity container))
127 (defmethod (setf container-children) (children (container container))
128 (dolist (child (container-children container))
129 (container-remove container child))
130 (dolist (child children)
131 (apply #'container-add container (mklist child)))
134 (defun container-length (container)
136 (container-foreach container
138 (declare (ignore child))
142 (defbinding container-resize-children () nil
143 (container container))
145 (defbinding container-propagate-expose () nil
146 (container container)
148 (event gdk:expose-event))
151 (defbinding %container-get-focus-chain () boolean
152 (container container)
153 (focusable-widgets (glist widget) :out))
155 (defun container-focus-chain (container)
156 (multiple-value-bind (chain-set-p focusable-widgets)
157 (%container-get-focus-chain container)
158 (and chain-set-p focusable-widgets)))
160 (defbinding %container-set-focus-chain () nil
161 (container container)
162 (focusable-widgets (glist widget)))
164 (defbinding %container-unset-focus-chain () nil
165 (container container))
167 (defun (setf container-focus-chain) (focusable-widgets container)
168 (if (null focusable-widgets)
169 (%container-unset-focus-chain container)
170 (%container-set-focus-chain container focusable-widgets)))