X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/33f468b7e5546dfc5ab5db9af8523562314b4931..43e8a182b5a4b41d3b5bb063cecb15d12ae3964b:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 69af8e1..357debb 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.11 2004-12-17 00:45:00 espen Exp $ +;; $Id: testgtk.lisp,v 1.13 2004-12-26 12:01:10 espen Exp $ ;;; Some of the code in this file are really outdatet, but it is @@ -303,91 +303,80 @@ (defun clamp (n min-val max-val) (declare (number n min-val max-val)) (max (min n max-val) min-val)) +(defun set-cursor (spinner drawing-area label) + (let ((cursor + (glib:int-enum + (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE) + 'gdk:cursor-type))) + (setf (label-label label) (string-downcase cursor)) + (setf (widget-cursor drawing-area) cursor))) + +(defun cursor-expose (drawing-area event) + (declare (ignore event)) + (multiple-value-bind (width height) + (drawing-area-get-size drawing-area) + (let* ((window (widget-window drawing-area)) + (style (widget-style drawing-area)) + (white-gc (style-white-gc style)) + (gray-gc (style-bg-gc style :normal)) + (black-gc (style-black-gc style))) + (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2)) + (gdk:draw-rectangle window black-gc t 0 (floor height 2) width + (floor height 2)) + (gdk:draw-rectangle window gray-gc t (floor width 3) + (floor height 3) (floor width 3) + (floor height 3)))) + t) + +(define-simple-dialog create-cursors (dialog "Cursors") + (let ((spinner (make-instance 'spin-button + :adjustment (adjustment-new + 0 0 + (1- (enum-int :last-cursor 'gdk:cursor-type)) + 2 10 0))) + (drawing-area (make-instance 'drawing-area + :width-request 80 :height-request 80 + :events '(:exposure-mask :button-press-mask))) + (label (make-instance 'label :label "XXX"))) + + (signal-connect drawing-area 'expose-event #'cursor-expose :object t) + + (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))) + t)) -;; (defun set-cursor (spinner drawing-area label) -;; (let ((cursor -;; (glib:int-enum -;; (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE) -;; 'gdk:cursor-type))) -;; (setf (label-text label) (string-downcase cursor)) -;; (setf (widget-cursor drawing-area) cursor))) - + (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))) + t)) + + (signal-connect spinner 'changed + #'(lambda () + (set-cursor spinner drawing-area label))) -; (define-standard-dialog create-cursors "Cursors" -; (setf (container-border-width main-box) 10) -; (setf (box-spacing main-box) 5) -; (let* ((hbox (hbox-new nil 0)) -; (label (create-label "Cursor Value : ")) -; (adj (adjustment-new 0 0 152 2 10 0)) -; (spinner (spin-button-new adj 0 0))) -; (setf (container-border-width hbox) 5) -; (box-pack-start main-box hbox nil t 0) -; (setf (misc-xalign label) 0) -; (setf (misc-yalign label) 0.5) -; (box-pack-start hbox label nil t 0) -; (box-pack-start hbox spinner t t 0) - -; (let ((frame (make-frame -; :shadow-type :etched-in -; :label-xalign 0.5 -; :label "Cursor Area" -; :border-width 10 -; :parent main-box -; :visible t)) -; (drawing-area (drawing-area-new))) -; (setf (widget-width drawing-area) 80) -; (setf (widget-height drawing-area) 80) -; (container-add frame drawing-area) -; (signal-connect -; drawing-area 'expose-event -; #'(lambda (event) -; (declare (ignore event)) -; (multiple-value-bind (width height) -; (drawing-area-size drawing-area) -; (let* ((drawable (widget-window drawing-area)) -; (style (widget-style drawing-area)) -; (white-gc (style-get-gc style :white)) -; (gray-gc (style-get-gc style :background :normal)) -; (black-gc (style-get-gc style :black))) -; (gdk:draw-rectangle -; drawable white-gc t 0 0 width (floor height 2)) -; (gdk:draw-rectangle -; drawable black-gc t 0 (floor height 2) width (floor height 2)) -; (gdk:draw-rectangle -; drawable gray-gc t (floor width 3) (floor height 3) -; (floor width 3) (floor height 3)))) -; t)) -; (setf (widget-events drawing-area) '(:exposure :button-press)) -; (signal-connect -; drawing-area 'button-press-event -; #'(lambda (event) -; (when (and -; (eq (gdk:event-type event) :button-press) -; (or -; (= (gdk:event-button event) 1) -; (= (gdk:event-button event) 3))) -; (spin-button-spin -; spinner -; (if (= (gdk:event-button event) 1) -; :step-forward -; :step-backward) -; 0) -; t))) -; (widget-show drawing-area) - -; (let ((label (make-label -; :visible t -; :label "XXX" -; :parent main-box))) -; (setf (box-child-expand-p #|main-box|# label) nil) -; (signal-connect -; spinner 'changed -; #'(lambda () -; (set-cursor spinner drawing-area label))) - -; (widget-realize drawing-area) -; (set-cursor spinner drawing-area label))))) + (make-instance 'v-box + :parent dialog :border-width 10 :spacing 5 :show-all t + :child (list + (make-instance 'h-box + :border-width 5 + :child (list + (make-instance 'label :label "Cursor Value : ") + :expand nil) + :child spinner) + :expand nil) + :child (make-instance 'frame +; :shadow-type :etched-in + :label "Cursor Area" :label-xalign 0.5 :border-width 10 + :child drawing-area) + :child (list label :expand nil)) + (widget-realize drawing-area) + (set-cursor spinner drawing-area label))) ;;; Dialog @@ -477,7 +466,9 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog) (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t) (dialog-add-button dialog "gtk-ok" #'(lambda () - (format t "Selected file: ~A~%" (file-chooser-filename dialog)) + (if (slot-boundp dialog 'filename) + (format t "Selected file: ~A~%" (file-chooser-filename dialog)) + (write-line "No files selected")) (widget-destroy dialog)))) @@ -665,38 +656,32 @@ (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil) ;;; Layout -;; (defun layout-expose (layout event) -;; (with-slots (window x-offset y-offset) layout -;; (with-slots (x y width height) event -;; (let ((imin (truncate (+ x-offset x) 10)) -;; (imax (truncate (+ x-offset x width 9) 10)) -;; (jmin (truncate (+ y-offset y) 10)) -;; (jmax (truncate (+ y-offset y height 9) 10))) -;; (declare (fixnum imin imax jmin jmax)) -;; (gdk:window-clear-area window x y width height) - -;; (let ((window (layout-bin-window layout)) -;; (gc (style-get-gc (widget-style layout) :black))) -;; (do ((i imin (1+ i))) -;; ((= i imax)) -;; (declare (fixnum i)) -;; (do ((j jmin (1+ j))) -;; ((= j jmax)) -;; (declare (fixnum j)) -;; (unless (zerop (mod (+ i j) 2)) -;; (gdk:draw-rectangle -;; window gc t -;; (- (* 10 i) x-offset) (- (* 10 j) y-offset) -;; (1+ (mod i 10)) (1+ (mod j 10)))))))))) -;; t) - +(defun layout-expose (layout event) + (when (eq (gdk:event-window event) (layout-bin-window layout)) + (with-slots (gdk:x gdk:y gdk:width gdk:height) event + (let ((imin (truncate gdk:x 10)) + (imax (truncate (+ gdk:x gdk:width 9) 10)) + (jmin (truncate gdk:y 10)) + (jmax (truncate (+ gdk:y gdk:height 9) 10))) + + (let ((window (layout-bin-window layout)) + (gc (style-black-gc (widget-style layout)))) + (loop + for i from imin below imax + do (loop + for j from jmin below jmax + unless (zerop (mod (+ i j) 2)) + do (gdk:draw-rectangle + window gc t (* 10 i) (* 10 j) + (1+ (mod i 10)) (1+ (mod j 10))))))))) + nil) (define-toplevel create-layout (window "Layout" :default-width 200 :default-height 200) (let ((layout (make-instance 'layout :parent (make-instance 'scrolled-window :parent window) :width 1600 :height 128000 :events '(:exposure-mask) -;; :signal (list 'expose-event #'layout-expose :object t) + :signal (list 'expose-event #'layout-expose :object t) ))) (with-slots (hadjustment vadjustment) layout @@ -1035,64 +1020,40 @@ (define-simple-dialog create-notebook (dialog "Notebook") ;;; Panes (defun toggle-resize (child) - (let* ((paned (widget-parent child)) - (is-child1-p (eq child (paned-child1 paned)))) - (multiple-value-bind (child resize shrink) - (if is-child1-p - (paned-child1 paned) - (paned-child2 paned)) - (container-remove paned child) - (if is-child1-p - (paned-pack1 paned child (not resize) shrink) - (paned-pack2 paned child (not resize) shrink))))) + (setf (paned-child-resize-p child) (not (paned-child-resize-p child)))) (defun toggle-shrink (child) - (let* ((paned (widget-parent child)) - (is-child1-p (eq child (paned-child1 paned)))) - (multiple-value-bind (child resize shrink) - (if is-child1-p - (paned-child1 paned) - (paned-child2 paned)) - (container-remove paned child) - (if is-child1-p - (paned-pack1 paned child resize (not shrink)) - (paned-pack2 paned child resize (not shrink)))))) + (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child)))) (defun create-pane-options (paned frame-label label1 label2) - (let* ((frame (make-instance 'frame :label frame-label :border-width 4)) - (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t - :parent frame))) - + (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t))) (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill)) (let ((check-button (make-instance 'check-button :label "Resize"))) (table-attach table check-button 0 1 1 2 :options '(:expand :fill)) - (signal-connect - check-button 'toggled #'toggle-resize :object (paned-child1 paned))) - (let ((check-button (make-instance 'check-button :label "Shrink"))) + (signal-connect check-button 'toggled + #'toggle-resize :object (paned-child1 paned))) + (let ((check-button (make-instance 'check-button :label "Shrink" :active t))) (table-attach table check-button 0 1 2 3 :options '(:expand :fill)) - (setf (toggle-button-active-p check-button) t) - (signal-connect - check-button 'toggled #'toggle-shrink :object (paned-child1 paned))) + (signal-connect check-button 'toggled + #'toggle-shrink :object (paned-child1 paned))) (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill)) - (let ((check-button (make-instance 'check-button :label "Resize"))) + (let ((check-button (make-instance 'check-button :label "Resize" :active t))) (table-attach table check-button 1 2 1 2 :options '(:expand :fill)) - (setf (toggle-button-active-p check-button) t) - (signal-connect - check-button 'toggled #'toggle-resize :object (paned-child2 paned))) - (let ((check-button (make-instance 'check-button :label "Shrink"))) + (signal-connect check-button 'toggled + #'toggle-resize :object (paned-child2 paned))) + (let ((check-button (make-instance 'check-button :label "Shrink" :active t))) (table-attach table check-button 1 2 2 3 :options '(:expand :fill)) - (setf (toggle-button-active-p check-button) t) - (signal-connect - check-button 'toggled #'toggle-shrink :object (paned-child2 paned))) - frame)) + (signal-connect check-button 'toggled + #'toggle-shrink :object (paned-child2 paned))) + (make-instance 'frame :label frame-label :border-width 4 :child table))) (define-toplevel create-panes (window "Panes") (let* ((hpaned (make-instance 'h-paned :child1 (make-instance 'frame :width-request 60 :height-request 60 :shadow-type :in - :child (make-instance 'buttun :label "Hi there")) + :child (make-instance 'button :label "Hi there")) :child2 (make-instance 'frame :width-request 80 :height-request 60 :shadow-type :in))) @@ -1113,7 +1074,7 @@ (define-toplevel create-panes (window "Panes") ;;; Progress bar - + ;;; Radio buttons @@ -1640,10 +1601,8 @@ (define-simple-dialog create-toggle-buttons (dialog "Toggle Button") ;;; Toolbar test -;; TODO: style properties (define-toplevel create-toolbar (window "Toolbar test" :resizable nil) (let ((toolbar (make-instance 'toolbar :parent window))) -; (setf (toolbar-relief toolbar) :none) ;; Insert a stock item (toolbar-append toolbar "gtk-quit" @@ -1758,7 +1717,7 @@ (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200) (make-instance 'v-box :parent dialog :border-width 10 :spacing 10 :show-all t :child (create-button "button1" "This is button 1" "ContextHelp/button/1") - :child (create-button "button2" "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2"))))) + :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2"))))) ;;; UI Manager @@ -1850,7 +1809,7 @@ (defun create-main-window () ("calendar" create-calendar) ("check buttons" create-check-buttons) ("color selection" create-color-selection) -;; ("cursors" #|create-cursors|#) + ("cursors" create-cursors) ("dialog" create-dialog) ;; ; ("dnd") ("entry" create-entry) @@ -1860,7 +1819,6 @@ (defun create-main-window () ;; ("font selection") ;; ("handle box" create-handle-box) ("image" create-image) -;; ("item factory") ("labels" create-labels) ("layout" create-layout) ("list" create-list) @@ -1905,6 +1863,8 @@ (defun create-main-window () :signal (list 'clicked #'widget-destroy :object main-window)))) + (setf (window-icon main-window) #p"clg:examples;gtk.png") + ;; Main box (make-instance 'v-box :parent main-window