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.4 2001-10-21 23:20:13 espen Exp $
  19
  20 (in-package "GTK")
  21
  22 (defmethod initialize-instance ((container container) &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-check-resize () nil
  53   (container container))
  54
  55 (defbinding (%container-foreach "gtk_container_foreach_full")
  56     (container function) nil
  57   (container container)
  58   (0 unsigned-long)
  59   (*callback-marshal* pointer)
  60   ((register-callback-function function) pointer)
  61   (*destroy-marshal* pointer))
  62
  63 (defun map-container (seqtype func container)
  64   (case seqtype
  65     ((nil)
  66      (%container-foreach container func)
  67      nil)
  68     (list
  69      (let ((list nil))
  70        (%container-foreach
  71         container
  72         #'(lambda (child)
  73             (push (funcall func child) list)))
  74        (nreverse list)))
  75     (t
  76      (let ((seq (make-sequence seqtype (container-num-children container)))
  77            (index 0))
  78        (%container-foreach
  79         container
  80         #'(lambda (child)
  81             (setf (elt seq index) (funcall func child))
  82             (incf index)))
  83        seq))))
  84
  85 (defmacro do-container ((var container &optional (result nil)) &body body)
  86   (let ((continue (make-symbol "CONTINUE")))
  87     `(let ((,continue t))
  88        (%container-foreach
  89         ,container
  90         #'(lambda (,var)
  91             (when ,continue
  92               (setq ,continue nil)
  93               (block nil
  94                 ,@body
  95                 (setq ,continue t)))))
  96        ,result)))
  97
  98 (defbinding %container-get-children () (glist widget)
  99   (container container))
 100
 101 (defmethod container-children ((container container))
 102   (%container-get-children container))
 103
 104 (defmethod (setf container-children) (children (container container))
 105   (dolist (child (container-children container))
 106     (container-remove container child))
 107   (dolist (child children)
 108     (container-add container child))
 109   children)
 110
 111 ;; Should be implemented as a foreign function
 112 (defun container-num-children (container)
 113   (length (container-children container)))
 114
 115 (defbinding container-resize-children () nil
 116   (container container))