mdw@git.distorted.org.uk Git - 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.6 2001-11-20 18:25:53 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 (defbinding (%container-foreach "gtk_container_foreach_full")
  69     (container function) nil
  70   (container container)
  71   (0 unsigned-long)
  72   (*callback-marshal* pointer)
  73   ((register-callback-function function) pointer)
  74   (*destroy-marshal* pointer))
  75
  76 (defun map-container (seqtype func container)
  77   (case seqtype
  78     ((nil)
  79      (%container-foreach container func)
  80      nil)
  81     (list
  82      (let ((list nil))
  83        (%container-foreach
  84         container
  85         #'(lambda (child)
  86             (push (funcall func child) list)))
  87        (nreverse list)))
  88     (t
  89      (let ((seq (make-sequence seqtype (container-num-children container)))
  90            (index 0))
  91        (%container-foreach
  92         container
  93         #'(lambda (child)
  94             (setf (elt seq index) (funcall func child))
  95             (incf index)))
  96        seq))))
  97
  98 (defmacro do-container ((var container &optional (result nil)) &body body)
  99   (let ((continue (make-symbol "CONTINUE")))
 100     `(let ((,continue t))
 101        (%container-foreach
 102         ,container
 103         #'(lambda (,var)
 104             (when ,continue
 105               (setq ,continue nil)
 106               (block nil
 107                 ,@body
 108                 (setq ,continue t)))))
 109        ,result)))
 110
 111 (defbinding %container-get-children () (glist widget)
 112   (container container))
 113
 114 (defmethod container-children ((container container))
 115   (%container-get-children container))
 116
 117 (defmethod (setf container-children) (children (container container))
 118   (dolist (child (container-children container))
 119     (container-remove container child))
 120   (dolist (child children)
 121     (container-add container child))
 122   children)
 123
 124 ;; Should be implemented as a foreign function
 125 (defun container-num-children (container)
 126   (length (container-children container)))
 127
 128 (defbinding container-resize-children () nil
 129   (container container))