X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e025589b58012e9c10ea518ab8ef5e0faf6ac537..b6bf802c65107c8d25475da5b7e82b4fd1b5311a:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 7aa2e81..2c166d7 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.10 2004/12/05 13:57:10 espen Exp $ +;; $Id: testgtk.lisp,v 1.12 2004/12/20 00:56:11 espen Exp $ ;;; Some of the code in this file are really outdatet, but it is @@ -238,7 +238,8 @@ (define-simple-dialog create-buttons (dialog "Buttons") (if (widget-visible-p button+1) (widget-hide button+1) (widget-show button+1)))) - (table-attach table button column (1+ column) row (1+ row))))) + (table-attach table button column (1+ column) row (1+ row) + :options '(:expand :fill))))) (widget-show-all table))) @@ -302,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)) + + (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))) -;; (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))) - - -; (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 @@ -664,38 +654,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 @@ -1062,25 +1046,25 @@ (defun create-pane-options (paned frame-label label1 label2) (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t :parent frame))) - (table-attach table (create-label label1) 0 1 0 1) + (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) + (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"))) - (table-attach table check-button 0 1 2 3) + (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))) - (table-attach table (create-label label2) 1 2 0 1) + (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill)) (let ((check-button (make-instance 'check-button :label "Resize"))) - (table-attach table check-button 1 2 1 2) + (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"))) - (table-attach table check-button 1 2 2 3) + (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))) @@ -1170,18 +1154,19 @@ (define-toplevel create-rulers (window "Rulers" (widget-events window) '(:pointer-motion-mask :pointer-motion-hint-mask)) - (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))) - (let ((ruler (make-instance 'h-ruler + (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 - :position 0.0d0 :max-size 20.0d0))) - (signal-connect window 'motion-notify-event #'widget-event :object ruler) - (table-attach table ruler 1 2 0 1 :y-options '(:fill))) - (let ((ruler (make-instance 'v-ruler + :position 0.0d0 :max-size 20.0d0)) + (v-ruler (make-instance 'v-ruler :lower 5.0d0 :upper 15.0d0 :position 0.0d0 :max-size 20.0d0))) - (signal-connect window 'motion-notify-event #'widget-event :object ruler) - (table-attach table ruler 0 1 1 2 :x-options '(:fill))))) - + (signal-connect window 'motion-notify-event + #'(lambda (event) + (widget-event h-ruler event) + (widget-event v-ruler event))) + (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand) + (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand))) ;;; Scrolled window @@ -1210,6 +1195,42 @@ (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows" (widget-show-all scrolled-window))) +;;; Size group + +(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil) + (let ((size-group (make-instance 'size-group))) + (flet ((create-frame (label rows) + (let ((table (make-instance 'table + :n-rows (length rows) :n-columns 2 :homogeneous nil + :row-spacing 5 :column-spacing 10 :border-width 5))) + (loop + for row in rows + for i from 0 + do (table-attach table + (create-label (first row) :xalign 0 :yalign 1) + 0 1 i (1+ i) :x-options '(:expand :fill)) + (let ((combo (make-instance 'combo-box + :content (rest row) :active 0))) + (size-group-add-widget size-group combo) + (table-attach table combo 1 2 i (1+ i)))) + (make-instance 'frame :label label :child table)))) + + (make-instance 'v-box + :parent dialog :border-width 5 :spacing 5 :show-all t + :child (create-frame "Color Options" + '(("Foreground" "Red" "Green" "Blue") + ("Background" "Red" "Green" "Blue"))) + :child (create-frame "Line Options" + '(("Dashing" "Solid" "Dashed" "Dotted") + ("Line ends" "Square" "Round" "Arrow"))) + :child (create-check-button "Enable grouping" + #'(lambda (active) + (setf + (size-group-mode size-group) + (if active :horizontal :none))) + t))))) + + ;;; Shapes ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy) @@ -1507,7 +1528,86 @@ (define-simple-dialog create-timeout-test (dialog "Timeout Test") (define-simple-dialog create-text (dialog "Text" :default-width 400 :default-height 400) - (make-instance 'text-view :border-width 10 :parent dialog :visible t)) + (let* ((text-view (make-instance 'text-view + :border-width 10 :visible t :wrap-mode :word)) + (buffer (text-view-buffer text-view)) + (active-tags ())) + + (text-buffer-create-tag buffer "Bold" :weight :bold) + (text-buffer-create-tag buffer "Italic" :style :italic) + (text-buffer-create-tag buffer "Underline" :underline :single) + + (flet ((create-toggle-callback (tag-name) + (let ((tag (text-tag-table-lookup + (text-buffer-tag-table buffer) tag-name))) + #'(lambda (active) + (unless (eq (and (find tag active-tags) t) active) + ;; user activated + (if active + (push tag active-tags) + (setq active-tags (delete tag active-tags))) + (multiple-value-bind (start end) + (text-buffer-get-selection-bounds buffer) + (if active + (text-buffer-apply-tag buffer tag start end) + (text-buffer-remove-tag buffer tag start end)))))))) + + (let* ((actions + (make-instance 'action-group + :action (create-toggle-action + "Bold" "gtk-bold" "Bold" "B" "Bold" nil + (create-toggle-callback "Bold")) + :action (create-toggle-action + "Italic" "gtk-italic" "Italic" "I" "Italic" nil + (create-toggle-callback "Italic")) + :action (create-toggle-action + "Underline" "gtk-underline" "Underline" "U" "Underline" nil + (create-toggle-callback "Underline")))) + (ui (make-instance 'ui-manager))) + + (ui-manager-insert-action-group ui actions) + (ui-manager-add-ui ui + '((:toolbar "ToolBar" + (:toolitem "Bold") + (:toolitem "Italic") + (:toolitem "Underline")))) + + ;; Callback to activate/deactivate toolbar buttons when cursor + ;; is moved + (signal-connect buffer 'mark-set + #'(lambda (location mark) + (declare (ignore mark)) + (text-tag-table-foreach (text-buffer-tag-table buffer) + #'(lambda (tag) + (let ((active + (or + (and + (text-iter-has-tag-p location tag) + (not (text-iter-begins-tag-p location tag))) + (text-iter-ends-tag-p location tag)))) + (unless (eq active (and (find tag active-tags) t)) + (if active + (push tag active-tags) + (setq active-tags (delete tag active-tags))) + (setf + (toggle-action-active-p + (action-group-get-action actions (text-tag-name tag))) + active))))))) + + ;; Callback to apply active tags when a character is inserted + (signal-connect buffer 'insert-text + #'(lambda (iter &rest args) + (declare (ignore args)) + (let ((before (text-buffer-get-iter-at-offset buffer + (1- (text-iter-offset iter))))) + (loop + for tag in active-tags + do (text-buffer-apply-tag buffer tag before iter)))) + :after t) + + (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil) + (container-add dialog text-view))))) + ;;; Toggle buttons @@ -1641,11 +1741,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"))) - - (let ((close-button (first (container-children (dialog-action-area dialog))))) - (tooltips-set-tip tooltips close-button "Push this button to close window" - "ContextHelp/buttons/Close")))) + :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"))))) ;;; UI Manager @@ -1677,7 +1773,7 @@ (defvar *ui-description* (:separator "Sep1") (:toolitem "Logo")))) -(define-simple-dialog create-ui-manager (dialog "UI Manager") +(define-toplevel create-ui-manager (window "UI Manager") (let ((actions (make-instance 'action-group :name "Actions" @@ -1687,10 +1783,10 @@ (define-simple-dialog create-ui-manager (dialog "UI Manager") :action (create-action "ShapeMenu" nil "_Shape") :action (create-action "HelpMenu" nil "_Help") :action (create-action "New" "gtk-new" "_New" "N" "Create a new file") - :action (create-action "Open" "gtk-open" "_Open" "O" "Open a file") + :action (create-action "Open" "gtk-open" "_Open" "O" "Open a file" #'create-file-chooser) :action (create-action "Save" "gtk-save" "_Save" "S" "Save current file") :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file") - :action (create-action "Quit" "gtk-quit" "_Quit" "Q" "Quit") + :action (create-action "Quit" "gtk-quit" "_Quit" "Q" "Quit" (list #'widget-destroy :object window)) :action (create-action "About" nil "_About" "A" "About") :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+") :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "B" "Bold" t) @@ -1708,10 +1804,10 @@ (define-simple-dialog create-ui-manager (dialog "UI Manager") (ui-manager-insert-action-group ui actions) (ui-manager-add-ui ui *ui-description*) - (window-add-accel-group dialog (ui-manager-accel-group ui)) + (window-add-accel-group window (ui-manager-accel-group ui)) (make-instance 'v-box - :parent dialog :show-all t + :parent window :show-all t :child (list (ui-manager-get-widget ui "/MenuBar") :expand nil :fill nil) @@ -1737,7 +1833,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) @@ -1763,6 +1859,7 @@ (defun create-main-window () ("rulers" create-rulers) ;; ("saved position") ("scrolled windows" create-scrolled-windows) + ("size group" create-size-group) ;; ("shapes" create-shapes) ("spinbutton" create-spins) ("statusbar" create-statusbar)