;; 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.16 2005/01/12 14:03:04 espen Exp $
+;; $Id: testgtk.lisp,v 1.24 2005/03/06 17:12:22 espen Exp $
;(use-package "GTK")
`(let ((,window nil))
(defun ,name ()
(unless ,window
- (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
+ (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
,@body)
(if (not (widget-visible-p ,window))
- (widget-show-all ,window)
+ (widget-show ,window)
(widget-hide ,window)))))
`(let ((,dialog nil))
(defun ,name ()
(unless ,dialog
- (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
+ (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
,@body)
(define-toplevel create-button-box (window "Button Boxes")
(make-instance 'v-box
- :parent window :border-width 10 :spacing 10 :show-all t
+ :parent window :border-width 10 :spacing 10
:child (make-instance 'frame
:label "Horizontal Button Boxes"
:child (make-instance 'v-box
(widget-hide button+1)
(widget-show button+1))))
(table-attach table button column (1+ column) row (1+ row)
- :options '(:expand :fill)))))
- (widget-show-all table)))
+ :options '(:expand :fill)))))))
;; Calenadar
(define-simple-dialog create-calendar (dialog "Calendar")
(make-instance 'v-box
- :parent dialog :border-width 10 :show-all t
+ :parent dialog :border-width 10
:child (make-instance 'calendar)))
(define-simple-dialog create-check-buttons (dialog "Check Buttons")
(make-instance 'v-box
- :border-width 10 :spacing 10 :parent dialog :show-all t
+ :border-width 10 :spacing 10 :parent dialog
:children (loop
for n from 1 to 3
collect (make-instance 'check-button
(define-dialog create-color-selection (dialog "Color selection dialog"
'color-selection-dialog
- :allow-grow nil :allow-shrink nil)
- (with-slots (action-area colorsel) dialog
-;; This seg faults for some unknown reason
-;; (let ((button (make-instance 'check-button :label "Show Palette")))
-;; (dialog-add-action-widget dialog button
-;; #'(lambda ()
-;; (setf
-;; (color-selection-has-palette-p colorsel)
-;; (toggle-button-active-p button)))))
-
- (container-add action-area
- (create-check-button "Show Opacity"
- #'(lambda (state)
- (setf (color-selection-has-opacity-control-p colorsel) state))))
-
- (container-add action-area
- (create-check-button "Show Palette"
- #'(lambda (state)
- (setf (color-selection-has-palette-p colorsel) state))))
+ :allow-grow nil :allow-shrink nil
+ :show-children nil)
+ (with-slots (colorsel) dialog
+ (let ((button (make-instance 'check-button :label "Show Opacity")))
+ (dialog-add-action-widget dialog button
+ #'(lambda ()
+ (setf
+ (color-selection-has-opacity-control-p colorsel)
+ (toggle-button-active-p button)))))
+
+ (let ((button (make-instance 'check-button :label "Show Palette")))
+ (dialog-add-action-widget dialog button
+ #'(lambda ()
+ (setf
+ (color-selection-has-palette-p colorsel)
+ (toggle-button-active-p button)))))
(signal-connect dialog :ok
#'(lambda ()
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)
(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
(set-cursor spinner drawing-area label)))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 5 :show-all t
+ :parent dialog :border-width 10 :spacing 5
:child (list
(make-instance 'h-box
:border-width 5
: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))
(create-check-button "Editable" 'editable)
(create-check-button "Visible" 'visibility)
- (create-check-button "Sensitive" 'sensitive)))
- (widget-show-all main)))
+ (create-check-button "Sensitive" 'sensitive)))))
;; Expander
(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
(make-instance 'v-box
- :parent dialog :spacing 5 :border-width 5 :show-all t
+ :parent dialog :spacing 5 :border-width 5
:child (create-label "Expander demo. Click on the triangle for details.")
:child (make-instance 'expander
:label "Details"
;; 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 ()
(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
;;; 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))
: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)
- )))
+ :width 1600 :height 128000 :events '(:exposure)
+ :signal (list 'expose-event #'layout-expose :object t))))
(with-slots (hadjustment vadjustment) layout
(setf
(dotimes (i 16)
(dotimes (j 16)
(let ((text (format nil "Button ~D, ~D" i j)))
- (make-instance (if (not (zerop (mod (+ i j) 2)))
- 'button
- 'label)
- :label text :parent (list layout :x (* j 100) :y (* i 100))))))
+ (layout-put layout
+ (make-instance (if (not (zerop (mod (+ i j) 2)))
+ 'button
+ 'label)
+ :label text :visible t)
+ (* j 100) (* i 100)))))
(loop
for i from 16 below 1280
do (let ((text (format nil "Button ~D, ~D" i 0)))
- (make-instance (if (not (zerop (mod i 2)))
- 'button
- 'label)
- :label text :parent (list layout :x 0 :y (* i 100)))))))
+ (layout-put layout
+ (make-instance (if (not (zerop (mod i 2)))
+ 'button
+ 'label)
+ :label text :visible t)
+ 0 (* i 100))))))
(tree-view-append-column tree column))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child (list
(make-instance 'h-box
:spacing 10
:signal (list 'clicked #'(lambda () (widget-hide page)))))
(let ((label-box (make-instance 'h-box
- :show-all t
+ :show-children t
:child-args '(:expand nil)
:child (make-instance 'image :pixbuf book-closed)
:child (make-instance 'label :label title)))
(menu-box (make-instance 'h-box
- :show-all t
+ :show-children t
:child-args '(:expand nil)
:child (make-instance 'image :pixbuf book-closed)
:child (make-instance 'label :label title))))
t))))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child progress
:child activity-mode-button)
(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:children (make-radio-group 'radio-button
'((:label "button1") (:label "button2") (:label "button3"))
nil)))
(define-simple-dialog create-range-controls (dialog "Range controls")
(let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child (make-instance 'h-scale
:width-request 150 :adjustment adjustment :inverted t
:update-policy :delayed :digits 1 :draw-value t)
(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
(make-instance 'frame :label label :child table))))
(make-instance 'v-box
- :parent dialog :border-width 5 :spacing 5 :show-all t
+ :parent dialog :border-width 5 :spacing 5
:child (create-frame "Color Options"
'(("Foreground" "Red" "Green" "Blue")
("Background" "Red" "Green" "Blue")))
;;; 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)))))
: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)
#'(lambda () (when idle (idle-remove idle))))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child label
:child (make-instance 'frame
:label "Label Container" :border-width 5
(setq active-tags (delete tag active-tags)))
(multiple-value-bind (non-zero-p start end)
(text-buffer-get-selection-bounds buffer)
+ (declare (ignore non-zero-p))
(if active
(text-buffer-apply-tag buffer tag start end)
(text-buffer-remove-tag buffer tag start end))))))))
(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
(make-instance 'v-box
- :border-width 10 :spacing 10 :parent dialog :show-all t
+ :border-width 10 :spacing 10 :parent dialog
:children (loop
for n from 1 to 3
collect (make-instance 'toggle-button
(tooltips-set-tip tooltips button tip-text tip-private)
button)))
(make-instance 'v-box
- :parent dialog :border-width 10 :spacing 10 :show-all t
+ :parent dialog :border-width 10 :spacing 10
:child (create-button "button1" "This is button 1" "ContextHelp/button/1")
: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")))))
(window-add-accel-group window (ui-manager-accel-group ui))
(make-instance 'v-box
- :parent window :show-all t
+ :parent window
:child (list
(ui-manager-get-widget ui "/MenuBar")
:expand nil :fill nil)
;; ("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)
;; ("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)
: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
~mdw / clg / blobdiff