chiark - git - mdw - clg/blob - 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.20 2006-02-28 16:32:18 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-children (container))
  30 (defgeneric (setf container-children) (children container))
  31
  32
  33 (defmethod shared-initialize ((container container) names &rest initargs
  34                               &key child children child-args
  35                                    (show-children nil show-children-p))
  36   (declare (ignore child children))
  37   (when show-children-p
  38     (if (not show-children)
  39         (setf (user-data container 'show-recursive-p) nil)
  40       (signal-connect container 'show #'container-show-recursive
  41        :object t :remove t)))
  42
  43   (call-next-method)
  44   (initial-add container
  45    #'(lambda (container args)
  46        (apply #'container-add container (append (mklist args) child-args)))
  47    initargs :child :children))
  48
  49
  50 (defmethod compute-signal-function ((container container) signal function object)
  51   (if (eq object :children)
  52       #'(lambda (&rest args)
  53           (mapc #'(lambda (child)
  54                     (apply function child (rest args)))
  55                 (container-children container)))
  56     (call-next-method)))
  57
  58
  59 (defbinding %container-add () nil
  60   (container container)
  61   (widget widget))
  62
  63 (defmethod container-add ((container container) (widget widget) &rest args)
  64   (%container-add container widget)
  65   (when args
  66     (setf
  67      (slot-value widget 'child-properties)
  68      (apply
  69       #'make-instance
  70       (gethash (class-of container) *container-to-child-class-mappings*)
  71       :parent container :child widget args))))
  72
  73 (defbinding %container-remove () nil
  74   (container container)
  75   (widget widget))
  76
  77 (defmethod container-remove ((container container) (widget widget))
  78   (%container-remove container widget)
  79   (slot-makunbound widget 'child-properties))
  80
  81
  82 (defbinding %container-child-get-property () nil
  83   (container container)
  84   (child widget)
  85   (property-name string)
  86   (value gvalue))
  87
  88 (defbinding %container-child-set-property () nil
  89   (container container)
  90   (child widget)
  91   (property-name string)
  92   (value gvalue))
  93
  94
  95 (defbinding container-check-resize () nil
  96   (container container))
  97
  98 (define-callback-marshal %foreach-callback nil (widget))
  99
 100 (defbinding %container-foreach (container callback-id) nil
 101   (container container)
 102   (%foreach-callback callback)
 103   (callback-id unsigned-int))
 104
 105 (defun container-foreach (container function)
 106   (with-callback-function (id function)
 107     (%container-foreach container id)))
 108
 109 (defbinding %container-forall (container callback-id) nil
 110   (container container)
 111   (%foreach-callback callback)
 112   (callback-id unsigned-int))
 113
 114 (defun container-forall (container function)
 115   (with-callback-function (id function)
 116     (%container-forall container id)))
 117
 118 (defun map-container (seqtype func container)
 119   (case seqtype
 120     ((nil)
 121      (container-foreach container func)
 122      nil)
 123     (list
 124      (let ((list nil))
 125        (container-foreach
 126         container
 127         #'(lambda (child)
 128             (push (funcall func child) list)))
 129        (nreverse list)))
 130     (t
 131      (let ((seq (make-sequence seqtype (container-length container)))
 132            (index 0))
 133        (container-foreach
 134         container
 135         #'(lambda (child)
 136             (setf (elt seq index) (funcall func child))
 137             (incf index)))
 138        seq))))
 139
 140 (defmethod container-children ((container container))
 141   (map-container 'list #'identity container))
 142
 143 (defmethod (setf container-children) (children (container container))
 144   (dolist (child (container-children container))
 145     (container-remove container child))
 146   (dolist (child children)
 147     (apply #'container-add container (mklist child)))
 148   children)
 149
 150 (defun container-length (container)
 151   (let ((n 0))
 152     (container-foreach container
 153      #'(lambda (child)
 154          (declare (ignore child))
 155          (incf n)))
 156     n))
 157
 158 (defbinding container-resize-children () nil
 159   (container container))
 160
 161 (defbinding container-propagate-expose () nil
 162   (container container)
 163   (child widget)
 164   (event gdk:expose-event))
 165
 166
 167 (defbinding %container-get-focus-chain () boolean
 168   (container container)
 169   (focusable-widgets (glist widget) :out))
 170
 171 (defun container-focus-chain (container)
 172   (multiple-value-bind (chain-set-p focusable-widgets)
 173       (%container-get-focus-chain container)
 174     (and chain-set-p focusable-widgets)))
 175
 176 (defbinding %container-set-focus-chain () nil
 177   (container container)
 178   (focusable-widgets (glist widget)))
 179
 180 (defbinding %container-unset-focus-chain () nil
 181   (container container))
 182
 183 (defun (setf container-focus-chain) (focusable-widgets container)
 184   (if (null focusable-widgets)
 185       (%container-unset-focus-chain container)
 186     (%container-set-focus-chain container focusable-widgets)))
 187
 188 (defgeneric container-show-recursive (container))
 189
 190 (defmethod container-show-recursive ((container container))
 191   "Recursively shows any child widgets except widgets explicit hidden during construction."
 192   (labels ((recursive-show (widget)
 193              (when (typep widget 'container)
 194                (if (not (user-data-p widget 'show-recursive-p))
 195                    (container-foreach widget #'recursive-show)
 196                  (unset-user-data widget 'show-recursive-p)))
 197              (unless (widget-hidden-p widget)
 198                (widget-show widget))))
 199     (container-foreach container #'recursive-show)))