X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/6490e9f11d83ff0c9ddb4423e9d884f10cb9168b..031b10c59e6010b802d5fba1b679636d4614becc:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index f9cec23..b3826ed 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -15,7 +15,7 @@ ;; 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: testgtk.lisp,v 1.17 2005/02/22 23:14:04 espen Exp $ +;; $Id: testgtk.lisp,v 1.24 2005/03/06 17:12:22 espen Exp $ ;(use-package "GTK") @@ -327,7 +327,7 @@ 2 10 0))) (drawing-area (make-instance 'drawing-area :width-request 80 :height-request 80 - :events '(:exposure-mask :button-press-mask))) + :events '(:exposure :button-press))) (label (make-instance 'label :label "XXX"))) (signal-connect drawing-area 'expose-event #'cursor-expose :object t) @@ -335,15 +335,15 @@ (signal-connect drawing-area 'button-press-event #'(lambda (event) (case (gdk:event-button event) - (1 (spin-button-spin spinner :step-forward 0.0)) - (3 (spin-button-spin spinner :step-backward 0.0))) + (1 (spin-button-spin spinner :step-forward)) + (3 (spin-button-spin spinner :step-backward))) t)) (signal-connect drawing-area 'scroll-event #'(lambda (event) (case (gdk:event-direction event) - (:up (spin-button-spin spinner :step-forward 0.0)) - (:down (spin-button-spin spinner :step-backward 0.0))) + (:up (spin-button-spin spinner :step-forward)) + (:down (spin-button-spin spinner :step-backward))) t)) (signal-connect spinner 'changed @@ -452,6 +452,12 @@ ;; File chooser dialog (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog) + (file-chooser-add-filter dialog + (make-instance 'file-filter :name "All files" :pattern "*")) + (file-chooser-add-filter dialog + (make-instance 'file-filter :name "Common Lisp source code" + :patterns '("*.lisp" "*.lsp"))) + (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t) (dialog-add-button dialog "gtk-ok" #'(lambda () @@ -461,6 +467,15 @@ (widget-destroy dialog)))) +;; Font selection dialog + +(define-toplevel create-font-selection (window "Font Button" :resizable nil) + (make-instance 'h-box + :parent window :spacing 8 :border-width 8 + :child (make-instance 'label :label "Pick a font") + :child (make-instance 'font-button + :use-font t :title "Font Selection Dialog"))) + ;;; Handle box @@ -486,7 +501,7 @@ ;;; Image -(define-toplevel create-image (window "Image") +(define-toplevel create-image (window "Image" :resizable nil) (make-instance 'image :file #p"clg:examples;gtk.png" :parent window)) @@ -565,7 +580,7 @@ This one is underlined (こんにちは) in quite a funky fashion" :default-height 200) (let ((layout (make-instance 'layout :parent (make-instance 'scrolled-window :parent window) - :width 1600 :height 128000 :events '(:exposure-mask) + :width 1600 :height 128000 :events '(:exposure) :signal (list 'expose-event #'layout-expose :object t)))) (with-slots (hadjustment vadjustment) layout @@ -1039,13 +1054,7 @@ This one is underlined (こんにちは) in quite a funky fashion" (define-toplevel create-rulers (window "Rulers" :default-width 300 :default-height 300 -;; :events '(:pointer-motion-mask -;; :pointer-motion-hint-mask) - ) - (setf - (widget-events window) - '(:pointer-motion-mask :pointer-motion-hint-mask)) - + :events '(:pointer-motion :pointer-motion-hint)) (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)) (h-ruler (make-instance 'h-ruler :metric :centimeters :lower 100.0d0 :upper 0.0d0 @@ -1125,86 +1134,78 @@ This one is underlined (こんにちは) in quite a funky fashion" ;;; Shapes -;; (defun shape-create-icon (xpm-file x y px py type root-window destroy) -;; (let* ((window -;; (make-instance 'window -;; :type type :x x :y y -;; :events '(:button-motion :pointer-motion-hint :button-press))) -;; (fixed -;; (make-instance 'fixed -;; :parent window :width 100 :height 100))) +(defun create-shape-icon (xpm-file x y px py type root-window destroy) + (let ((window + (make-instance 'window + :type type :default-width 100 :default-height 100 + :events '(:button-motion :pointer-motion-hint :button-press) + :signal (list 'destroy destroy)))) -;; (widget-realize window) -;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file) -;; (let ((pixmap (pixmap-new source mask)) -;; (x-offset 0) -;; (y-offset 0)) -;; (declare (fixnum x-offset y-offset)) -;; (fixed-put fixed pixmap px py) -;; (widget-shape-combine-mask window mask px py) + (widget-realize window) + (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file) + (let ((fixed (make-instance 'fixed :parent window))) + (fixed-put fixed (create-image-widget source mask) px py)) + (widget-shape-combine-mask window mask px py)) -;; (signal-connect window 'button-press-event -;; #'(lambda (event) -;; (when (typep event 'gdk:button-press-event) -;; (setq x-offset (truncate (gdk:event-x event))) -;; (setq y-offset (truncate (gdk:event-y event))) -;; (grab-add window) -;; (gdk:pointer-grab -;; (widget-window window) t -;; '(:button-release :button-motion :pointer-motion-hint) -;; nil nil 0)) -;; t)) - -;; (signal-connect window 'button-release-event -;; #'(lambda (event) -;; (declare (ignore event)) -;; (grab-remove window) -;; (gdk:pointer-ungrab 0) -;; t)) + (let ((x-offset 0) + (y-offset 0)) + (declare (fixnum x-offset y-offset)) + (signal-connect window 'button-press-event + #'(lambda (event) + (when (typep event 'gdk:button-press-event) + (setq x-offset (truncate (gdk:event-x event))) + (setq y-offset (truncate (gdk:event-y event))) + (grab-add window) + (gdk:pointer-grab (widget-window window) + :events '(:button-release :button-motion :pointer-motion-hint) + :owner-events t :time event)))) + + (signal-connect window 'button-release-event + #'(lambda (event) + (grab-remove window) + (gdk:pointer-ungrab event))) -;; (signal-connect window 'motion-notify-event -;; #'(lambda (event) -;; (declare (ignore event)) -;; (multiple-value-bind (win xp yp mask) -;; (gdk:window-get-pointer root-window) -;; (declare (ignore mask win) (fixnum xp yp)) -;; (widget-set-uposition -;; window :x (- xp x-offset) :y (- yp y-offset))) -;; t)) -;; (signal-connect window 'destroy destroy))) + (signal-connect window 'motion-notify-event + #'(lambda (event) + (declare (ignore event)) + (multiple-value-bind (win xp yp mask) + (gdk:window-get-pointer root-window) + (declare (ignore mask win) (fixnum xp yp)) + (window-move window (- xp x-offset) (- yp y-offset)))))) -;; (widget-show-all window) -;; window)) - - -;; (let ((modeller nil) -;; (sheets nil) -;; (rings nil)) -;; (defun create-shapes () -;; (let ((root-window (gdk:get-root-window))) -;; (if (not modeller) -;; (setq -;; modeller -;; (shape-create-icon -;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window -;; #'(lambda () (widget-destroyed modeller)))) -;; (widget-destroy modeller)) - -;; (if (not sheets) -;; (setq -;; sheets -;; (shape-create-icon -;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window -;; #'(lambda () (widget-destroyed sheets)))) -;; (widget-destroy sheets)) - -;; (if (not rings) -;; (setq -;; rings -;; (shape-create-icon -;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window -;; #'(lambda () (widget-destroyed rings)))) -;; (widget-destroy rings))))) + (window-move window x y) + (widget-show-all window) + window)) + + +(let ((modeller nil) + (sheets nil) + (rings nil)) + (defun create-shapes () + (let ((root-window (gdk:get-root-window))) + (if (not modeller) + (setq + modeller + (create-shape-icon + "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window + #'(lambda () (setq modeller nil)))) + (widget-destroy modeller)) + + (if (not sheets) + (setq + sheets + (create-shape-icon + "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window + #'(lambda () (setq sheets nil)))) + (widget-destroy sheets)) + + (if (not rings) + (setq + rings + (create-shape-icon + "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window + #'(lambda () (setq rings nil)))) + (widget-destroy rings))))) @@ -1222,17 +1223,20 @@ This one is underlined (こんにちは) in quite a funky fashion" :label label :xalign 0.0 :yalign 0.5) :child (make-instance 'spin-button :adjustment adjustment :wrap t)))) - (make-instance 'frame - :label "Not accelerated" :parent main - :child (make-instance 'h-box - :border-width 10 - :child-args '(:padding 5) - :child (create-date-spinner "Day : " - (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out) - :child (create-date-spinner "Month : " - (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in) - :child (create-date-spinner "Year : " - (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in)))) + (multiple-value-bind (sec min hour date month year day daylight-p zone) + (get-decoded-time) + (declare (ignore sec min hour day daylight-p zone)) + (make-instance 'frame + :label "Not accelerated" :parent main + :child (make-instance 'h-box + :border-width 10 + :child-args '(:padding 5) + :child (create-date-spinner "Day : " + (adjustment-new date 1 31 1 5 0) :out) + :child (create-date-spinner "Month : " + (adjustment-new month 1 12 1 5 0) :etched-in) + :child (create-date-spinner "Year : " + (adjustment-new year 0 2100 1 100 0) :in))))) (let ((spinner1 (make-instance 'spin-button :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0) @@ -1716,7 +1720,7 @@ This one is underlined (こんにちは) in quite a funky fashion" ;; ("event watcher") ("enxpander" create-expander) ("file chooser" create-file-chooser) -;; ("font selection") + ("font selection" create-font-selection) ("handle box" create-handle-box) ("image" create-image) ("labels" create-labels) @@ -1735,7 +1739,7 @@ This one is underlined (こんにちは) in quite a funky fashion" ;; ("saved position") ("scrolled windows" create-scrolled-windows) ("size group" create-size-group) -;; ("shapes" create-shapes) + ("shapes" create-shapes) ("spinbutton" create-spins) ("statusbar" create-statusbar) ("test idle" create-idle-test) @@ -1774,6 +1778,13 @@ This one is underlined (こんにちは) in quite a funky fashion" :child-args '(:expand nil) :child (list (make-instance 'label :label (gtk-version)) :fill nil) :child (list (make-instance 'label :label "clg CVS version") :fill nil) + :child (list (make-instance 'label + :label #-cmu(format nil "~A (~A)" + (lisp-implementation-type) + (lisp-implementation-version)) + ;; The version string in CMUCL is far too long + #+cmu(lisp-implementation-type)) + :fill nil) :child (list scrolled-window :expand t) :child (make-instance 'h-separator) :child (make-instance 'v-box