;; 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.5 2004-11-08 14:16:12 espen Exp $
+;; $Id: testgtk.lisp,v 1.10 2004-12-05 13:57:10 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
(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
;;; List
-;; (define-standard-dialog create-list "List"
-;; (let ((scrolled-window (scrolled-window-new))
-;; (list (list-new)))
-;; (setf (container-border-width scrolled-window) 5)
-;; (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
-;; (box-pack-start main-box scrolled-window t t 0)
-;; (setf (widget-height scrolled-window) 300)
-
-;; (setf (list-selection-mode list) :extended)
-;; (scrolled-window-add-with-viewport scrolled-window list)
-;; (setf
-;; (container-focus-vadjustment list)
-;; (scrolled-window-vadjustment scrolled-window))
-;; (setf
-;; (container-focus-hadjustment list)
-;; (scrolled-window-hadjustment scrolled-window))
-
-;; (with-open-file (file "clg:examples;gtktypes.lisp")
-;; (labels ((read-file ()
-;; (let ((line (read-line file nil nil)))
-;; (when line
-;; (container-add list (list-item-new line))
-;; (read-file)))))
-;; (read-file)))
-
-;; (let ((hbox (hbox-new t 5)))
-;; (setf (container-border-width hbox) 5)
-;; (box-pack-start main-box hbox nil t 0)
-
-;; (let ((button (button-new "Insert Row"))
-;; (i 0))
-;; (box-pack-start hbox button t t 0)
-;; (signal-connect
-;; button 'clicked
-;; #'(lambda ()
-;; (let ((item
-;; (list-item-new (format nil "added item ~A" (incf i)))))
-;; (widget-show item)
-;; (container-add list item)))))
-
-;; (let ((button (button-new "Clear List")))
-;; (box-pack-start hbox button t t 0)
-;; (signal-connect
-;; button 'clicked #'(lambda () (list-clear-items list 0 -1))))
+(define-simple-dialog create-list (dialog "List" :default-height 400)
+ (let* ((store (make-instance 'list-store
+ :column-types '(string int boolean)
+ :column-names '(:foo :bar :baz)
+ :initial-content '(#("First" 12321 nil)
+ (:foo "Yeah" :baz t))))
+ (tree (make-instance 'tree-view :model store)))
-;; (let ((button (button-new "Remove Selection")))
-;; (box-pack-start hbox button t t 0)
-;; (signal-connect
-;; button 'clicked
-;; #'(lambda ()
-;; (let ((selection (list-selection list)))
-;; (if (eq (list-selection-mode list) :extended)
-;; (let ((item (or
-;; (container-focus-child list)
-;; (first selection))))
-;; (when item
-;; (let* ((children (container-children list))
-;; (sel-row
-;; (or
-;; (find-if
-;; #'(lambda (item)
-;; (eq (widget-state item) :selected))
-;; (member item children))
-;; (find-if
-;; #'(lambda (item)
-;; (eq (widget-state item) :selected))
-;; (member item (reverse children))))))
-;; (list-remove-items list selection)
-;; (when sel-row
-;; (list-select-child list sel-row)))))
-;; (list-remove-items list selection)))))
-;; (box-pack-start hbox button t t 0)))
-
-;; (let ((cbox (hbox-new nil 0)))
-;; (box-pack-start main-box cbox nil t 0)
-
-;; (let ((hbox (hbox-new nil 5))
-;; (option-menu
-;; (create-option-menu
-;; `(("Single"
-;; ,#'(lambda () (setf (list-selection-mode list) :single)))
-;; ("Browse"
-;; ,#'(lambda () (setf (list-selection-mode list) :browse)))
-;; ("Multiple"
-;; ,#'(lambda () (setf (list-selection-mode list) :multiple)))
-;; ("Extended"
-;; ,#'(lambda () (setf (list-selection-mode list) :extended))))
-;; 3)))
-
-;; (setf (container-border-width hbox) 5)
-;; (box-pack-start cbox hbox t nil 0)
-;; (box-pack-start hbox (create-label "Selection Mode :") nil t 0)
-;; (box-pack-start hbox option-menu nil t 0)))))
+ (loop
+ with iter = (make-instance 'tree-iter)
+ for i from 1 to 1000
+ do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
+
+ (let ((column (make-instance 'tree-view-column :title "Column 1"))
+ (cell (make-instance 'cell-renderer-text)))
+ (cell-layout-pack column cell :expand t)
+ (cell-layout-add-attribute column cell 'text (column-index store :foo))
+ (tree-view-append-column tree column))
+
+ (let ((column (make-instance 'tree-view-column :title "Column 2"))
+ (cell (make-instance 'cell-renderer-text :background "orange")))
+ (cell-layout-pack column cell :expand t)
+ (cell-layout-add-attribute column cell 'text (column-index store :bar))
+ (tree-view-append-column tree column))
+
+ (let ((column (make-instance 'tree-view-column :title "Column 3"))
+ (cell (make-instance 'cell-renderer-text)))
+ (cell-layout-pack column cell :expand t)
+ (cell-layout-add-attribute column cell 'text (column-index store :baz))
+ (tree-view-append-column tree column))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10 :show-all t
+ :child (list
+ (make-instance 'h-box
+ :spacing 10
+ :child (make-instance 'button
+ :label "Remove Selection"
+ :signal (list 'clicked
+ #'(lambda ()
+ (let ((references
+ (mapcar
+ #'(lambda (path)
+ (make-instance 'tree-row-reference :model store :path path))
+ (tree-selection-get-selected-rows
+ (tree-view-selection tree)))))
+ (mapc
+ #'(lambda (reference)
+ (list-store-remove store reference))
+ references))))))
+ :expand nil)
+ :child (list
+ (make-instance 'h-box
+ :spacing 10
+ :child (make-instance 'check-button
+ :label "Show Headers" :active t
+ :signal (list 'toggled
+ #'(lambda (button)
+ (setf
+ (tree-view-headers-visible-p tree)
+ (toggle-button-active-p button)))
+ :object t))
+ :child (make-instance 'check-button
+ :label "Reorderable" :active nil
+ :signal (list 'toggled
+ #'(lambda (button)
+ (setf
+ (tree-view-reorderable-p tree)
+ (toggle-button-active-p button)))
+ :object t))
+ :child (list
+ (make-instance 'h-box
+ :child (make-instance 'label :label "Selection Mode: ")
+ :child (make-instance 'combo-box
+ :content '("Single" "Browse" "Multiple")
+ :active 0
+ :signal (list 'changed
+ #'(lambda (combo-box)
+ (setf
+ (tree-selection-mode
+ (tree-view-selection tree))
+ (svref
+ #(:single :browse :multiple)
+ (combo-box-active combo-box))))
+ :object t)))
+ :expand nil))
+ :expand nil)
+ :child (make-instance 'scrolled-window
+ :child tree :hscrollbar-policy :automatic))))
;; Menus
;;; 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)
+ (make-instance 'text-view :border-width 10 :parent dialog :visible t))
;;; 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")))
+
+ (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"))))
+
+
+;;; 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-simple-dialog create-ui-manager (dialog "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")
+ :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")
+ :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 dialog (ui-manager-accel-group ui))
+
+ (make-instance 'v-box
+ :parent dialog :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))))
("buttons" create-buttons)
("calendar" create-calendar)
("check buttons" create-check-buttons)
-;; ("clist" #|create-clist|#)
("color selection" create-color-selection)
-;; ("ctree" #|create-ctree|#)
;; ("cursors" #|create-cursors|#)
("dialog" create-dialog)
;; ; ("dnd")
("entry" create-entry)
;; ("event watcher")
+ ("enxpander" create-expander)
("file chooser" create-file-chooser)
;; ("font selection")
;; ("handle box" create-handle-box)
;; ("item factory")
("labels" create-labels)
("layout" create-layout)
-;; ("list" create-list)
+ ("list" create-list)
("menus" create-menus)
;; ("modal window")
("notebook" create-notebook)
;; ("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