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.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)))