X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/704a1de420dbf0458a2e88427edfe43f7eaf4015..d9a443c989d6582b59c0ac6077aaa2c3ce87855b:/examples/testgtk.lisp diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index 4947e76..fa01312 100644 --- a/examples/testgtk.lisp +++ b/examples/testgtk.lisp @@ -15,7 +15,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: testgtk.lisp,v 1.3 2004-10-31 12:10:54 espen Exp $ +;; $Id: testgtk.lisp,v 1.7 2004-11-21 17:58:28 espen Exp $ ;;; Some of the code in this file are really outdatet, but it is @@ -303,20 +303,20 @@ (defun clamp (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 (symbol-name cursor))) -; (setf (widget-cursor drawing-area) cursor))) +;; (defun set-cursor (spinner drawing-area label) +;; (let ((cursor +;; (glib:int-enum +;; (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE) +;; 'gdk:cursor-type))) +;; (setf (label-text label) (string-downcase cursor)) +;; (setf (widget-cursor drawing-area) cursor))) ; (define-standard-dialog create-cursors "Cursors" ; (setf (container-border-width main-box) 10) ; (setf (box-spacing main-box) 5) ; (let* ((hbox (hbox-new nil 0)) -; (label (label-new "Cursor Value : ")) +; (label (create-label "Cursor Value : ")) ; (adj (adjustment-new 0 0 152 2 10 0)) ; (spinner (spin-button-new adj 0 0))) ; (setf (container-border-width hbox) 5) @@ -428,21 +428,21 @@ (define-simple-dialog create-entry (dialog "Entry") ;; (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 @@ -553,7 +553,7 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-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))) @@ -592,10 +592,10 @@ (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog) ;; 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 @@ -713,100 +713,95 @@ (define-toplevel create-layout (window "Layout" :default-width 200 ;;; 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 @@ -854,38 +849,15 @@ (define-simple-dialog create-menus (dialog "Menus" :default-width 200) (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))) + (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)))) -; (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 'option-menu :parent box2 :menu menu :history 3) - (widget-show-all main)))) + (widget-show-all main))) ;;; Notebook @@ -994,35 +966,34 @@ (define-simple-dialog create-notebook (dialog "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 @@ -1081,7 +1052,7 @@ (defun create-pane-options (paned frame-label label1 label2) (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t :parent frame))) - (table-attach table (label-new label1) 0 1 0 1) + (table-attach table (create-label label1) 0 1 0 1) (let ((check-button (make-instance 'check-button :label "Resize"))) (table-attach table check-button 0 1 1 2) (signal-connect @@ -1092,7 +1063,7 @@ (defun create-pane-options (paned frame-label label1 label2) (signal-connect check-button 'toggled #'toggle-shrink :object (paned-child1 paned))) - (table-attach table (label-new label2) 1 2 0 1) + (table-attach table (create-label 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) @@ -1110,7 +1081,7 @@ (define-toplevel create-panes (window "Panes") :child1 (make-instance 'frame :width-request 60 :height-request 60 :shadow-type :in - :child (button-new "Hi there")) + :child (make-instance 'buttun :label "Hi there")) :child2 (make-instance 'frame :width-request 80 :height-request 60 :shadow-type :in))) @@ -1336,7 +1307,7 @@ (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil) :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 31.0 1.0 5.0 0.0) :etched-in) + (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)))) @@ -1413,48 +1384,43 @@ (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil) :padding 5 :expand nil)))) (widget-show-all main))) -;;; Statusbar - -;; (define-test-window create-statusbar "Statusbar" -;; (let ((statusbar (make-instance 'statusbar)) -;; (statusbar-counter 0) -;; (close-button -;; (create-button '("close" :can-default t) #'widget-destroy window))) -;; (signal-connect -;; statusbar 'text-popped -;; #'(lambda (context-id text) -;; (declare (ignore context-id)) -;; (format nil "Popped: ~A~%" text))) - -;; (make-instance 'v-box -;; :parent window -;; :children -;; (list -;; (make-instance 'v-box -;; :border-width 10 :spacing 10 -;; :children -;; (list -;; (create-button -;; "push something" -;; #'(lambda () -;; (statusbar-push -;; statusbar 1 -;; (format nil "something ~D" (incf statusbar-counter))))) -;; (create-button "pop" #'statusbar-pop statusbar 1) -;; (create-button "steal #4" #'statusbar-remove statusbar 1 4) -;; (create-button "dump stack") -;; (create-button "test contexts"))) -;; (list (make-instance 'hseparator) :expand nil) -;; (list -;; (make-instance 'v-box -;; :border-width 10 -;; :children (list (list close-button :expand nil))) -;; :expand nil) -;; statusbar)) - -;; (widget-grab-default close-button))) +;;; Statusbar +(define-toplevel create-statusbar (window "Statusbar") + (let ((statusbar (make-instance 'statusbar :has-resize-grip t)) + (close-button (create-button '("close" :can-default t) + #'widget-destroy :object window)) + (counter 0)) + + (signal-connect statusbar 'text-popped + #'(lambda (context-id text) + (declare (ignore context-id)) + (format nil "Popped: ~A~%" text))) + + (make-instance 'v-box + :parent window + :child (make-instance 'v-box + :border-width 10 :spacing 10 + :child (create-button "push something" + #'(lambda () + (statusbar-push statusbar 1 + (format nil "something ~D" (incf counter))))) + :child (create-button "pop" + #'(lambda () + (statusbar-pop statusbar 1))) + :child (create-button "steal #4" + #'(lambda () + (statusbar-remove statusbar 1 4))) + :child (create-button "dump stack") + :child (create-button "test contexts")) + :child (list (make-instance 'h-separator) :expand nil) + :child (list + (make-instance 'v-box :border-width 10 :child close-button) + :expand nil) + :child (list statusbar :expand nil)) + + (widget-grab-focus close-button))) ;;; Idle test @@ -1747,9 +1713,7 @@ (defun create-main-window () ("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") @@ -1762,13 +1726,11 @@ (defun create-main-window () ;; ("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) @@ -1779,7 +1741,7 @@ (defun create-main-window () ("scrolled windows" create-scrolled-windows) ;; ("shapes" create-shapes) ("spinbutton" create-spins) -;; ("statusbar" create-statusbar) + ("statusbar" create-statusbar) ;; ("test idle" create-idle-test) ;; ("test mainloop") ;; ("test scrolling")