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.7 2002-03-24 12:58:34 espen Exp $
  19
  20 (in-package "GTK")
  21
  22 (defmethod shared-initialize ((container container) names &rest initargs)
  23   (call-next-method)
  24   (dolist (child (get-all initargs :child))
  25     (apply #'container-add container (mklist child))))
  26
  27
  28 (defbinding %container-add () nil
  29   (container container)
  30   (widget widget))
  31
  32 (defun container-add (container widget &rest args)
  33   (%container-add container widget)
  34   (when args
  35     (setf
  36      (slot-value widget 'child-slots)
  37      (apply
  38       #'make-instance
  39       (gethash (class-of container) *container-to-child-class-mappings*)
  40       :parent container :child widget args))))
  41
  42
  43 (defbinding %container-remove () nil
  44   (container container)
  45   (widget widget))
  46
  47 (defun container-remove (container widget)
  48   (%container-remove container widget)
  49   (slot-makunbound widget 'child-slots))
  50
  51
  52 (defbinding %container-child-get-property () nil
  53   (container container)
  54   (child widget)
  55   (property-name string)
  56   (value gvalue))
  57
  58 (defbinding %container-child-set-property () nil
  59   (container container)
  60   (child widget)
  61   (property-name string)
  62   (value gvalue))
  63
  64
  65 (defbinding container-check-resize () nil
  66   (container container))
  67
  68 (defvar *callback-marshal*
  69   (system:foreign-symbol-address "gtk_callback_marshal"))
  70
  71 (defbinding %container-foreach (container callback-id) nil
  72   (container container)
  73   (*callback-marshal* pointer)
  74   (callback-id unsigned-int))
  75
  76 (defun container-foreach (container function)
  77   (let ((callback-id (register-callback-function function)))
  78     (unwind-protect
  79         (%container-foreach container callback-id)
  80       (destroy-user-data callback-id))))
  81
  82 (defun map-container (seqtype func container)
  83   (case seqtype
  84     ((nil)
  85      (%container-foreach container func)
  86      nil)
  87     (list
  88      (let ((list nil))
  89        (container-foreach
  90         container
  91         #'(lambda (child)
  92             (push (funcall func child) list)))
  93        (nreverse list)))
  94     (t
  95      (let ((seq (make-sequence seqtype (container-length container)))
  96            (index 0))
  97        (container-foreach
  98         container
  99         #'(lambda (child)
 100             (setf (elt seq index) (funcall func child))
 101             (incf index)))
 102        seq))))
 103
 104 (defmacro do-container ((var container &optional (result nil)) &body body)
 105   (let ((continue (make-symbol "CONTINUE")))
 106     `(let ((,continue t))
 107        (container-foreach
 108         ,container
 109         #'(lambda (,var)
 110             (when ,continue
 111               (setq ,continue nil)
 112               (block nil
 113                 ,@body
 114                 (setq ,continue t)))))
 115        ,result)))
 116
 117 ;; (defbinding %container-get-children () (glist widget)
 118 ;;   (container container))
 119
 120 (defmethod container-children ((container container))
 121 ;;   (%container-get-children container)
 122   (map-container 'list #'identity container))
 123
 124 (defmethod (setf container-children) (children (container container))
 125   (dolist (child (container-children container))
 126     (container-remove container child))
 127   (dolist (child children)
 128     (container-add container child))
 129   children)
 130
 131 (defun container-length (container)
 132   (let ((n 0))
 133     (container-foreach container
 134      #'(lambda (child)
 135          (declare (ignore child))
 136          (incf n)))
 137     n))
 138
 139 (defbinding container-resize-children () nil
 140   (container container))
 141
 142 (defbinding container-propagate-expose () nil
 143   (container container)
 144   (child widget)
 145   (event gdk:expose-event))
 146
 147
 148 (defbinding %container-get-focus-chain () boolean
 149   (container container)
 150   (focusable-widgets (glist widget) :out))
 151
 152 (defun container-focus-chain (container)
 153   (multiple-value-bind (chain-set-p focusable-widgets)
 154       (%container-get-focus-chain container)
 155     (and chain-set-p focusable-widgets)))
 156
 157 (defbinding %container-set-focus-chain () nil
 158   (container container)
 159   (focusable-widgets (glist widget)))
 160
 161 (defbinding %container-unset-focus-chain () nil
 162   (container container))
 163
 164 (defun (setf container-focus-chain) (focusable-widgets container)
 165   (if (null focusable-widgets)
 166       (%container-unset-focus-chain container)
 167     (%container-set-focus-chain container focusable-widgets)))