chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / gtk / gtkcontainer.lisp
1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
3 ;;
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:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
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.
22
23 ;; $Id: gtkcontainer.lisp,v 1.26 2008-05-06 00:04:42 espen Exp $
24
25 (in-package "GTK")
26
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))
32
33
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
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))
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
60   (call-next-method)
61   (initial-add container 
62    #'(lambda (container args) 
63        (apply #'container-add container (append (mklist args) child-args)))
64    initargs :child :children))
65
66
67 (defmethod compute-signal-function ((container container) signal function object args)
68   (declare (ignore signal))
69   (if (eq object :children)
70       #'(lambda (container &rest emission-args)
71           (let ((all-args (nconc emission-args args)))
72             (container-foreach container
73              #'(lambda (child)
74                  (apply function child all-args)))))
75     (call-next-method)))
76
77
78 (defbinding %container-add () nil
79   (container container)
80   (widget widget))
81
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
91 (defun init-child-slots (container child args)
92   (when args
93     (setf
94      (slot-value child 'child-properties)
95      (apply
96       #'make-instance (find-child-class (class-of container))
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)
103
104 (defmethod container-add ((container container) (widgets list) &rest args)
105   (dolist (widget widgets)
106     (apply #'container-add container widget args)))
107
108 (defbinding %container-remove () nil
109   (container container)
110   (widget widget))
111
112 (defmethod container-remove ((container container) (widget widget))
113   (%container-remove container widget)
114   (slot-makunbound widget 'child-properties))
115
116
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
130 (defbinding container-check-resize () nil
131   (container container))
132
133 (define-callback-marshal %foreach-callback nil (widget))
134
135 (defbinding %container-foreach (container callback-id) nil
136   (container container)
137   (%foreach-callback callback)
138   (callback-id unsigned-int))
139
140 (defun container-foreach (container function)
141   (with-callback-function (id function)
142     (%container-foreach container id)))
143
144 (defbinding %container-forall (container callback-id) nil
145   (container container)
146   (%foreach-callback callback)
147   (callback-id unsigned-int))
148
149 (defun container-forall (container function)
150   (with-callback-function (id function)
151     (%container-forall container id)))
152
153 (defun map-container (seqtype func container)
154   (case seqtype
155     ((nil)
156      (container-foreach container func)
157      nil)
158     (list
159      (let ((list nil))
160        (container-foreach container
161         #'(lambda (child)
162             (push (funcall func child) list)))
163        (nreverse list)))
164     (t
165      (let ((seq (make-sequence seqtype (container-length container)))
166            (index 0))
167        (container-foreach container
168         #'(lambda (child)
169             (setf (elt seq index) (funcall func child))
170             (incf index)))
171        seq))))
172
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))
181   (let ((external-children (container-children container))
182         (all-children (container-all-children container)))
183     (loop
184      for child in all-children
185      unless (find child external-children)
186      collect child)))
187
188 (defmethod (setf container-children) (children (container container))
189   (dolist (child (container-children container))
190     (container-remove container child))
191   (dolist (child children)
192     (apply #'container-add container (mklist child)))
193   children)
194
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))
202
203 (defbinding container-resize-children () nil
204   (container container))
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)))
232
233 (defgeneric container-show-recursive (container))
234
235 (defmethod container-show-recursive ((container container))
236   "Recursively show any child widgets except widgets explicit hidden during construction."
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)))