chiark - git - mdw - clg/blob - gtk/gtkcontainer.lisp

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