X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/1047e159d403df191a35ed684e3c80517fbf3807..62f128081bd450f55d7e4ffd6602fb518f8ea304:/gtk/gtkutils.lisp diff --git a/gtk/gtkutils.lisp b/gtk/gtkutils.lisp index 84a948f..1166f15 100644 --- a/gtk/gtkutils.lisp +++ b/gtk/gtkutils.lisp @@ -15,38 +15,26 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtkutils.lisp,v 1.2 2004-10-31 12:05:52 espen Exp $ +;; $Id: gtkutils.lisp,v 1.6 2005-01-06 21:06:54 espen Exp $ (in-package "GTK") - -(defun v-box-new (&optional homogeneous (spacing 0)) - (make-instance 'v-box :homogeneous homogeneous :spacing spacing)) - -(defun create-button (specs &optional callback &rest args) +(defun create-button (specs &optional callback &key object) (destructuring-bind (label &rest initargs) (mklist specs) (let ((button (apply #'make-instance 'button :label label :visible t initargs))) (if callback - (signal-connect - button 'clicked - #'(lambda () - (apply (funcallable callback) args))) + (signal-connect button 'clicked callback :object object) (setf (widget-sensitive-p button) nil)) button))) -(defun button-new (label &optional callback) - (let ((button (make-instance 'button :label label))) - (when callback - (signal-connect button 'clicked callback)) - button)) -(defun label-new (label) - (make-instance 'label :label label)) +(defun create-label (label &rest args) + (apply #'make-instance 'label :label label args)) - +;; TODO: same syntax as create-button (defun %create-toggleable-button (class label callback initstate initargs) (let ((button (apply #'make-instance class :label label :active initstate :visible t @@ -64,65 +52,85 @@ (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 create-option-menu (specs active &optional callback &rest initargs) - (let ((menu (make-instance 'menu)) - (group nil) - (i 0)) - (dolist (spec specs) - (destructuring-bind (label &optional item-callback) (mklist spec) - (let ((menu-item - (apply - #'make-instance 'radio-menu-item - :label label :active (= i active) initargs))) - (when group (%radio-menu-item-set-group menu-item group)) - (setq group (%radio-menu-item-get-group menu-item)) - (cond - (callback - (signal-connect menu-item 'activated callback :object t)) - (item-callback - (signal-connect menu-item 'toggled item-callback :object t))) - (incf i) - (menu-shell-append menu menu-item)))) - - (make-instance 'option-menu :history active :menu menu))) - -;; (defun sf (n) -;; (coerce n 'single-float)) - (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 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)) + (signal-emit active 'clicked)) + + widgets)) + + +;;;; The follwing code will probably be removed soon + +(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))))