;; 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.4 2004-11-06 16:36:34 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
(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)))
(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-text label) (string-downcase cursor))
+ 'gdk:cursor-type)))
+ (setf (label-label 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 (label-new "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)))))
+(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)))
+
+ (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
;; (editable-insert-text entry "great " 6)
;; (editable-delete-text entry 6 12)
- (let ((combo (make-instance 'combo
+ (let ((combo (make-instance 'combo-box-entry
:parent main
- :popdown-strings '("item0"
- "item1 item1"
- "item2 item2 item2"
- "item3 item3 item3 item3"
- "item4 item4 item4 item4 item4"
- "item5 item5 item5 item5 item5 item5"
- "item6 item6 item6 item6 item6"
- "item7 item7 item7 item7"
- "item8 item8 item8"
- "item9 item9"))))
- (with-slots (entry) combo
- (setf (editable-text entry) "hello world")
- (editable-select-region entry 0)))
+ :content '("item0"
+ "item1 item1"
+ "item2 item2 item2"
+ "item3 item3 item3 item3"
+ "item4 item4 item4 item4 item4"
+ "item5 item5 item5 item5 item5 item5"
+ "item6 item6 item6 item6 item6"
+ "item7 item7 item7 item7"
+ "item8 item8 item8"
+ "item9 item9"))))
+ (with-slots (child) combo
+ (setf (editable-text child) "hello world")
+ (editable-select-region child 0)))
(flet ((create-check-button (label slot)
(make-instance 'check-button
(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
(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))))
;; (let ((v-box (v-box-new nil 0)))
;; (container-add window v-box)
-;; (container-add v-box (label-new "Above"))
+;; (container-add v-box (create-label "Above"))
;; (container-add v-box (hseparator-new))
;; (let ((hbox (hbox-new nil 10)))
;; handle-box2 'child-detached
;; #'(lambda (child)
;; (handle-box-child-signal handle-box child "detached")))
-;; (container-add handle-box2 (label-new "Foo!")))))
+;; (container-add handle-box2 (create-label "Foo!")))))
;; (container-add v-box (hseparator-new))
-;; (container-add v-box (label-new "Below"))))
+;; (container-add v-box (create-label "Below"))))
;;; Image
;;; 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
;;; 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 (label-new "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
(setf (menu-item-right-justified-p menu-item) t)
(menu-shell-append menubar menu-item))
- (let ((box2 (make-instance 'v-box
- :spacing 10 :border-width 10 :parent main))
- (menu (create-menu 1 nil)))
-
-; (setf (menu-accel-group menu) accel-group)
-
- (let ((menu-item (make-instance 'check-menu-item
- :label "Accelerate Me")))
- (menu-shell-append menu menu-item)
-;; (widget-add-accelerator
-;; menu-item 'activate accel-group "F1" '() '(:visible :signal-visible))
- )
-
- (let ((menu-item (make-instance 'check-menu-item
- :label "Accelerator Locked")))
- (menu-shell-append menu menu-item)
-;; (widget-add-accelerator
-;; menu-item 'activate accel-group "F2" '() '(:visible :locked))
- )
-
- (let ((menu-item (make-instance 'check-menu-item
- :label "Accelerator Frozen")))
- (menu-shell-append menu menu-item)
-;; (widget-add-accelerator
-;; menu-item 'activate accel-group "F2" '() '(:visible))
-;; (widget-add-accelerator
-;; menu-item 'activate accel-group "F3" '() '(:visible))
-;; (widget-lock-accelerators menuitem)
- )
+ (make-instance 'v-box
+ :spacing 10 :border-width 10 :parent main
+ :child (make-instance 'combo-box
+ :active 3
+ :content (loop
+ for i from 1 to 5
+ collect (format nil "Item ~D" i))))
- (make-instance 'option-menu :parent box2 :menu menu :history 3)
- (widget-show-all main))))
+ (widget-show-all main)))
;;; Notebook
:child-args '(:expand nil)
:child (make-instance 'label :label "Notebook Style: ")
:child (let ((scrollable-p nil))
- (create-option-menu
- `(("Standard"
- ,#'(lambda (menu-item)
- (declare (ignore menu-item))
- (setf (notebook-show-tabs-p notebook) t)
- (when scrollable-p
- (setq scrollable-p nil)
- (setf (notebook-scrollable-p notebook) nil)
- (loop repeat 10
- do (notebook-remove-page notebook 5)))))
- ("No tabs"
- ,#'(lambda (menu-item)
- (declare (ignore menu-item))
- (setf (notebook-show-tabs-p notebook) nil)
- (when scrollable-p
- (setq scrollable-p nil)
- (setf (notebook-scrollable-p notebook) nil)
- (loop repeat 10
- do (notebook-remove-page notebook 5)))))
- ("Scrollable"
- ,#'(lambda (menu-item)
- (declare (ignore menu-item))
- (unless scrollable-p
- (setq scrollable-p t)
- (setf (notebook-show-tabs-p notebook) t)
- (setf (notebook-scrollable-p notebook) t)
- (loop for i from 6 to 15
- do (create-notebook-page notebook i))))))
- 0))
+ ;; option menu is deprecated, we should use combo-box
+ (make-instance 'combo-box
+ :content '("Standard" "No tabs" "Scrollable") :active 0
+ :signal (list 'changed
+ #'(lambda (combo-box)
+ (case (combo-box-active combo-box)
+ (0
+ (setf (notebook-show-tabs-p notebook) t)
+ (when scrollable-p
+ (setq scrollable-p nil)
+ (setf (notebook-scrollable-p notebook) nil)
+ (loop repeat 10
+ do (notebook-remove-page notebook 5))))
+ (1
+ (setf (notebook-show-tabs-p notebook) nil)
+ (when scrollable-p
+ (setq scrollable-p nil)
+ (setf (notebook-scrollable-p notebook) nil)
+ (loop repeat 10
+ do (notebook-remove-page notebook 5))))
+ (2
+ (unless scrollable-p
+ (setq scrollable-p t)
+ (setf (notebook-show-tabs-p notebook) t)
+ (setf (notebook-scrollable-p notebook) t)
+ (loop for i from 6 to 15
+ do (create-notebook-page notebook i))))))
+ :object t)))
:child (make-instance 'button
:label "Show all Pages"
:signal (list 'clicked
;;; 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)))
-
- (table-attach table (label-new label1) 0 1 0 1)
+ (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)
- (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)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
-
- (table-attach table (label-new label2) 1 2 0 1)
- (let ((check-button (make-instance 'check-button :label "Resize")))
- (table-attach table check-button 1 2 1 2)
- (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)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
- frame))
+ (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" :active t)))
+ (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
+ (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" :active t)))
+ (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
+ (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))
+ (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 (button-new "Hi there"))
+ :child (make-instance 'button :label "Hi there"))
:child2 (make-instance 'frame
:width-request 80 :height-request 60
:shadow-type :in)))
;;; Progress bar
-
+
;;; Radio buttons
(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
;;; 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"
;;; 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 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
+
+(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))))
("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|#)
+ ("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)
("image" create-image)
-;; ("item factory")
("labels" create-labels)
("layout" create-layout)
-;; ("list" create-list)
+ ("list" create-list)
("menus" create-menus)
;; ("modal window")
("notebook" create-notebook)
("panes" create-panes)
-;; ("preview color")
-;; ("preview gray")
;; ("progress bar" #|create-progress-bar|#)
("radio buttons" create-radio-buttons)
("range controls" create-range-controls)
("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"
: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
~mdw / clg / blobdiff