;; 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.7 2004/11/21 17:58:28 espen Exp $
+;; $Id: testgtk.lisp,v 1.11 2004/12/17 00:45:00 espen Exp $
;;; Some of the code in this file are really outdatet, but it is
(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
`(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
- (dialog-add-button ,dialog "Close" #'widget-destroy :object t)
- ,@body))
+ ,@body
+ (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
:child (make-instance class
:border-width 5 :layout-style layout :spacing spacing
; :child-min-width width :child-min-height height
- :child (make-instance 'button :label "OK")
- :child (make-instance 'button :label "Cancel")
- :child (make-instance 'button :label "Help"))))
+ :child (make-instance 'button :label "gtk-ok" :use-stock t)
+ :child (make-instance 'button :label "gtk-cancel" :use-stock t)
+ :child (make-instance 'button :label "gtk-help" :use-stock t))))
(define-toplevel create-button-box (window "Button Boxes")
(make-instance 'v-box
(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)))
(widget-show-all main)))
+;; Expander
+
+(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
+ (make-instance 'v-box
+ :parent dialog :spacing 5 :border-width 5 :show-all t
+ :child (create-label "Expander demo. Click on the triangle for details.")
+ :child (make-instance 'expander
+ :label "Details"
+ :child (create-label "Details can be shown or hidden."))))
+
;; File chooser dialog
(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)))
(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
(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)
;;; Idle test
-;; (define-standard-dialog create-idle-test "Idle Test"
-;; (let* ((container (make-instance 'hbox :parent main-box))
-;; (label (make-instance 'label
-;; :label "count: 0" :xpad 10 :ypad 10 :parent container))
-;; (idle nil)
-;; (count 0))
-;; (declare (fixnum count))
-;; (signal-connect
-;; window 'destroy #'(lambda () (when idle (idle-remove idle))))
+(define-simple-dialog create-idle-test (dialog "Idle Test")
+ (let ((label (make-instance 'label
+ :label "count: 0" :xpad 10 :ypad 10))
+ (idle nil)
+ (count 0))
+ (signal-connect dialog 'destroy
+ #'(lambda () (when idle (idle-remove idle))))
-;; (make-instance 'frame
-;; :label "Label Container" :border-width 5 :parent main-box
-;; :child
-;; (make-instance 'v-box
-;; :children
-;; (create-radio-button-group
-;; '(("Resize-Parent" :parent)
-;; ("Resize-Queue" :queue)
-;; ("Resize-Immediate" :immediate))
-;; 0
-;; '(setf container-resize-mode) container)))
-
-;; (make-instance 'button
-;; :label "start" :can-default t :parent action-area
-;; :signals
-;; (list
-;; (list
-;; 'clicked
-;; #'(lambda ()
-;; (unless idle
-;; (setq
-;; idle
-;; (idle-add
-;; #'(lambda ()
-;; (incf count)
-;; (setf (label-label label) (format nil "count: ~D" count))
-;; t))))))))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10 :show-all t
+ :child label
+ :child (make-instance 'frame
+ :label "Label Container" :border-width 5
+ :child(make-instance 'v-box
+ :children (create-radio-button-group
+ '(("Resize-Parent" :parent)
+ ("Resize-Queue" :queue)
+ ("Resize-Immediate" :immediate))
+ 0
+ #'(lambda (mode)
+ (setf
+ (container-resize-mode (dialog-action-area dialog)) mode))))))
+
+ (dialog-add-button dialog "Start"
+ #'(lambda ()
+ (unless idle
+ (setq idle
+ (idle-add
+ #'(lambda ()
+ (incf count)
+ (setf (label-label label) (format nil "count: ~D" count))
+ t))))))
-;; (make-instance 'button
-;; :label "stop" :can-default t :parent action-area
-;; :signals
-;; (list
-;; (list
-;; 'clicked
-;; #'(lambda ()
-;; (when idle
-;; (idle-remove idle)
-;; (setq idle nil))))))))
+ (dialog-add-button dialog "Stop"
+ #'(lambda ()
+ (when idle
+ (idle-remove idle)
+ (setq idle nil))))))
;;; Timeout test
-;; (define-standard-dialog create-timeout-test "Timeout Test"
-;; (let ((label (make-instance 'label
-;; :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
-;; (timer nil)
-;; (count 0))
-;; (declare (fixnum count))
-;; (signal-connect
-;; window 'destroy #'(lambda () (when timer (timeout-remove timer))))
-
-;; (make-instance 'button
-;; :label "start" :can-default t :parent action-area
-;; :signals
-;; (list
-;; (list
-;; 'clicked
-;; #'(lambda ()
-;; (unless timer
-;; (setq
-;; timer
-;; (timeout-add
-;; 100
-;; #'(lambda ()
-;; (incf count)
-;; (setf (label-label label) (format nil "count: ~D" count))
-;; t))))))))
-
-;; (make-instance 'button
-;; :label "stop" :can-default t :parent action-area
-;; :signals
-;; (list
-;; (list
-;; 'clicked
-;; #'(lambda ()
-;; (when timer
-;; (timeout-remove timer)
-;; (setq timer nil))))))))
-
+(define-simple-dialog create-timeout-test (dialog "Timeout Test")
+ (let ((label (make-instance 'label
+ :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
+ (timer nil)
+ (count 0))
+ (signal-connect dialog 'destroy
+ #'(lambda () (when timer (timeout-remove timer))))
+
+ (dialog-add-button dialog "Start"
+ #'(lambda ()
+ (unless timer
+ (setq timer
+ (timeout-add 100
+ #'(lambda ()
+ (incf count)
+ (setf (label-label label) (format nil "count: ~D" count))
+ t))))))
+
+ (dialog-add-button dialog "Stop"
+ #'(lambda ()
+ (when timer
+ (timeout-remove timer)
+ (setq timer nil))))))
+
+
+;;; Text
+
+(define-simple-dialog create-text (dialog "Text" :default-width 400
+ :default-height 400)
+ (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" "<control>B" "Bold" nil
+ (create-toggle-callback "Bold"))
+ :action (create-toggle-action
+ "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
+ (create-toggle-callback "Italic"))
+ :action (create-toggle-action
+ "Underline" "gtk-underline" "Underline" "<control>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
;;; Tooltips test
-;; (define-standard-dialog create-tooltips "Tooltips"
-;; (setf
-;; (window-allow-grow-p window) t
-;; (window-allow-shrink-p window) nil
-;; (window-auto-shrink-p window) t
-;; (widget-width window) 200
-;; (container-border-width main-box) 10
-;; (box-spacing main-box) 10)
-
-;; (let ((tooltips (tooltips-new)))
-;; (flet ((create-button (label tip-text tip-private)
-;; (let ((button (make-instance 'toggle-button
-;; :label label :parent main-box)))
-;; (tooltips-set-tip tooltips button tip-text tip-private)
-;; button)))
-;; (create-button "button1" "This is button 1" "ContextHelp/button/1")
-;; (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* ((toggle (create-button "Override TipSQuery Label"
-;; "Toggle TipsQuery view" "Hi msw! ;)"))
-;; (box (make-instance 'v-box
-;; :homogeneous nil :spacing 5 :border-width 5
-;; :parent (make-instance 'frame
-;; :label "ToolTips Inspector"
-;; :label-xalign 0.5 :border-width 0
-;; :parent main-box)))
-;; (button (make-instance 'button :label "[?]" :parent box))
-;; (tips-query (make-instance 'tips-query
-;; :caller button :parent box)))
-
-;; (signal-connect
-;; button 'clicked #'tips-query-start-query :object tips-query)
-
-;; (signal-connect
-;; tips-query 'widget-entered
-;; #'(lambda (widget tip-text tip-private)
-;; (declare (ignore widget tip-private))
-;; (when (toggle-button-active-p toggle)
-;; (setf
-;; (label-label tips-query)
-;; (if tip-text
-;; "There is a Tip!"
-;; "There is no Tip!"))
-;; (signal-emit-stop tips-query 'widget-entered))))
-
-;; (signal-connect
-;; tips-query 'widget-selected
-;; #'(lambda (widget tip-text tip-private event)
-;; (declare (ignore tip-text event))
-;; (when widget
-;; (format
-;; t "Help ~S requested for ~S~%"
-;; (or tip-private "None") (type-of widget)))
-;; t))
+(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
+ (let ((tooltips (make-instance 'tooltips)))
+ (flet ((create-button (label tip-text tip-private)
+ (let ((button (make-instance 'toggle-button :label label)))
+ (tooltips-set-tip tooltips button tip-text tip-private)
+ button)))
+ (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")))))
+
+
+;;; UI Manager
+
+(defvar *ui-description*
+ '((:menubar "MenuBar"
+ (:menu "FileMenu"
+ (:menuitem "New")
+ (:menuitem "Open")
+ (:menuitem "Save")
+ (:menuitem "SaveAs")
+ :separator
+ (:menuitem "Quit"))
+ (:menu "PreferencesMenu"
+ (:menu "ColorMenu"
+ (:menuitem "Red")
+ (:menuitem "Green")
+ (:menuitem "Blue"))
+ (:menu "ShapeMenu"
+ (:menuitem "Square")
+ (:menuitem "Rectangle")
+ (:menuitem "Oval"))
+ (:menuitem "Bold"))
+ (:menu "HelpMenu"
+ (:menuitem "About")))
+ (:toolbar "ToolBar"
+ (:toolitem "Open")
+ (:toolitem "Quit")
+ (:separator "Sep1")
+ (:toolitem "Logo"))))
+
+(define-toplevel create-ui-manager (window "UI Manager")
+ (let ((actions
+ (make-instance 'action-group
+ :name "Actions"
+ :action (create-action "FileMenu" nil "_File")
+ :action (create-action "PreferencesMenu" nil "_Preferences")
+ :action (create-action "ColorMenu" nil "_Color")
+ :action (create-action "ShapeMenu" nil "_Shape")
+ :action (create-action "HelpMenu" nil "_Help")
+ :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
+ :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
+ :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
+ :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
+ :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
+ :action (create-action "About" nil "_About" "<control>A" "About")
+ :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
+ :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
+ :actions (create-radio-actions
+ '(("Red" nil "_Red" "<control>R" "Blood")
+ ("Green" nil "_Green" "<control>G" "Grass")
+ ("Blue" nil "_Blue" "<control>B" "Sky"))
+ "Green")
+ :actions (create-radio-actions
+ '(("Square" nil "_Square" "<control>S" "Square")
+ ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
+ ("Oval" nil "_Oval" "<control>O" "Egg")))))
+ (ui (make-instance 'ui-manager)))
+
+ (ui-manager-insert-action-group ui actions)
+ (ui-manager-add-ui ui *ui-description*)
-;; (tooltips-set-tip
-;; tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
-;; (tooltips-set-tip
-;; tooltips close-button "Push this button to close window"
-;; "ContextHelp/buttons/Close")))))
+ (window-add-accel-group window (ui-manager-accel-group ui))
+
+ (make-instance 'v-box
+ :parent window :show-all t
+ :child (list
+ (ui-manager-get-widget ui "/MenuBar")
+ :expand nil :fill nil)
+ :child (list
+ (ui-manager-get-widget ui "/ToolBar")
+ :expand nil :fill nil)
+ :child (make-instance 'label
+ :label "Type <alt> to start"
+ :xalign 0.5 :yalign 0.5
+ :width-request 200 :height-request 200))))
;; ; ("dnd")
("entry" create-entry)
;; ("event watcher")
+ ("enxpander" create-expander)
("file chooser" create-file-chooser)
;; ("font selection")
;; ("handle box" create-handle-box)
("rulers" create-rulers)
;; ("saved position")
("scrolled windows" create-scrolled-windows)
+ ("size group" create-size-group)
;; ("shapes" create-shapes)
("spinbutton" create-spins)
("statusbar" create-statusbar)
-;; ("test idle" create-idle-test)
+ ("test idle" create-idle-test)
;; ("test mainloop")
;; ("test scrolling")
;; ("test selection")
-;; ("test timeout" create-timeout-test)
-;; ("text" #|create-text|#)
+ ("test timeout" create-timeout-test)
+ ("text" create-text)
("toggle buttons" create-toggle-buttons)
("toolbar" create-toolbar)
-;; ("tooltips" create-tooltips)
+ ("tooltips" create-tooltips)
;; ("tree" #|create-tree|#)
+ ("UI manager" create-ui-manager)
))
(main-window (make-instance 'window
:title "testgtk.lisp" :name "main_window"
~mdw / clg / blobdiff