X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e40badd3f2237757893e7adeef9a825928fcc158..1d2032d45fc8c2603685f5f8f606c066b9418e6e:/gtk/gtkutils.lisp diff --git a/gtk/gtkutils.lisp b/gtk/gtkutils.lisp index cc234a9..59e20d3 100644 --- a/gtk/gtkutils.lisp +++ b/gtk/gtkutils.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2000 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 1999-2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkutils.lisp,v 1.5 2004-12-17 00:34:01 espen Exp $ +;; $Id: gtkutils.lisp,v 1.8 2005-04-23 16:48:52 espen Exp $ (in-package "GTK") @@ -52,95 +57,28 @@ (defun create-toggle-button (label callback &optional initstate &rest initargs) (defun create-check-button (label callback &optional initstate &rest initargs) (%create-toggleable-button 'check-button label callback initstate initargs)) -(defun create-radio-button-group (specs active &optional callback &rest args) - (let ((group nil) - (i 0)) - (mapcar - #'(lambda (spec) - (destructuring-bind - (label &optional object &rest initargs) (mklist spec) - (let ((button - (apply - #'make-instance 'radio-button - :label label :visible t initargs))) - (when group (%radio-button-set-group button group)) - (setq group (%radio-button-get-group button)) - (cond - (callback - (signal-connect - button 'toggled - #'(lambda () - (when (toggle-button-active-p button) - (apply (funcallable callback) object args))))) - (object - (signal-connect - button 'toggled - #'(lambda () - (apply - (funcallable object) - (toggle-button-active-p button) args))))) - (when (= i active) - (setf (toggle-button-active-p button) t)) - (incf i) - button))) - specs))) - - (defun adjustment-new (value lower upper step-increment page-increment page-size) (make-instance 'adjustment :value value :lower lower :upper upper :step-increment step-increment :page-increment page-increment :page-size page-size)) -(defun create-action (name &optional stock-id label accelerator tooltip - callback &rest initargs) - (let ((action (apply #'make-instance 'action - :name (string name) :stock-id stock-id :label label - :tooltip tooltip :accelerator accelerator initargs))) - (when callback - (apply #'signal-connect action 'activate (mklist callback))) - action)) - -(defun create-toggle-action (name &optional stock-id label accelerator - tooltip active callback &rest initargs) - (let ((action (apply #'make-instance 'toggle-action - :name (string name) :stock-id stock-id :label label - :tooltip tooltip :active active :accelerator accelerator - initargs))) - (when callback - (destructuring-bind (function &key object after) (mklist callback) - (signal-connect action 'activate - (if object - #'(lambda (object) - (funcall function object (toggle-action-active-p action))) - #'(lambda () - (funcall function (toggle-action-active-p action)))) - :object object :after after) - ;(funcall callback active) - (when active - (action-activate action)))) - action)) - -(defun create-radio-actions (specs &optional active callback &rest initargs) - (loop - with group = nil - for spec in specs - collect (destructuring-bind (name &optional stock-id label accelerator - tooltip (value name)) - (mklist spec) - (let ((action (apply #'make-instance 'radio-action - :name (string name) :stock-id stock-id - :label label :tooltip tooltip - :accelerator accelerator initargs))) - (when (equal active value) - (setf (toggle-action-active-p action) t) - (when callback - (funcall callback value))) - - (if (not group) - (setq group action) - (radio-action-add-to-group action group)) - (when callback - (signal-connect action 'activate - #'(lambda () - (funcall callback value)))) - action)))) +(defun make-radio-group (type specs callback &rest initargs) + (let* ((active ()) + (widgets + (loop + for spec in specs + as widget = (apply #'make-instance type (append spec initargs)) + do (when callback + (apply #'add-activate-callback widget (mklist callback))) + (when (and (not active) (getf spec :active)) + (setq active widget)) + collect widget))) + + (let ((active (or active (first widgets)))) + (loop + for widget in widgets + unless (eq widget active) + do (add-to-radio-group widget active)) + (activate-radio-widget active)) + + widgets))