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