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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-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: gtkutils.lisp,v 1.8 2005-04-23 16:48:52 espen Exp $
  24
  25
  26 (in-package "GTK")
  27
  28 (defun create-button (specs &optional callback &key object)
  29   (destructuring-bind (label &rest initargs) (mklist specs)
  30     (let ((button
  31            (apply #'make-instance 'button :label label :visible t initargs)))
  32       (if callback
  33           (signal-connect button 'clicked callback :object object)
  34         (setf (widget-sensitive-p button) nil))
  35       button)))
  36
  37
  38 (defun create-label (label &rest args)
  39   (apply #'make-instance 'label :label label args))
  40
  41
  42 ;; TODO: same syntax as create-button
  43 (defun %create-toggleable-button (class label callback initstate initargs)
  44   (let ((button
  45          (apply #'make-instance class :label label :active initstate :visible t
  46                 initargs)))
  47     (signal-connect
  48      button 'toggled
  49      #'(lambda ()
  50          (funcall (funcallable callback) (toggle-button-active-p button))))
  51     (funcall (funcallable callback) initstate)
  52     button))
  53
  54 (defun create-toggle-button (label callback &optional initstate &rest initargs)
  55   (%create-toggleable-button 'toggle-button label callback initstate initargs))
  56
  57 (defun create-check-button (label callback &optional initstate &rest initargs)
  58   (%create-toggleable-button 'check-button label callback initstate initargs))
  59
  60 (defun adjustment-new (value lower upper step-increment page-increment page-size)
  61   (make-instance 'adjustment
  62    :value value :lower lower :upper upper :step-increment step-increment
  63    :page-increment page-increment :page-size page-size))
  64
  65 (defun make-radio-group (type specs callback &rest initargs)
  66   (let* ((active ())
  67          (widgets
  68           (loop
  69            for spec in specs
  70            as widget = (apply #'make-instance type (append spec initargs))
  71            do (when callback
  72                (apply #'add-activate-callback widget (mklist callback)))
  73               (when (and (not active) (getf spec :active))
  74                 (setq active widget))
  75           collect widget)))
  76
  77     (let ((active (or active (first widgets))))
  78       (loop
  79        for widget in widgets
  80        unless (eq widget active)
  81        do (add-to-radio-group widget active))
  82       (activate-radio-widget active))
  83
  84     widgets))