X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=gtk%2Fgtk.demo.lisp;h=3899649506c5f7426d30c97ff6e2106773e5184e;hb=bd6107b4baeadf2e895ac82f8c977ca3c0c5ad3a;hp=fa7b74afd9cdc027670a74b5420328e2b8d6da3f;hpb=a7c9287064776dc0f4680db2d80d094b70a1c549;p=cl-gtk2.git diff --git a/gtk/gtk.demo.lisp b/gtk/gtk.demo.lisp index fa7b74a..3899649 100644 --- a/gtk/gtk.demo.lisp +++ b/gtk/gtk.demo.lisp @@ -1,12 +1,13 @@ (defpackage :gtk-demo (:use :cl :gtk :gdk :gobject :iter) - (:export #:test + (:export #:demo-all + #:test #:test-entry #:table-packing #:test-pixbuf #:test-image #:test-progress-bar - #:test-status-bar + #:test-statusbar #:test-scale-button #:test-text-view #:demo-code-editor @@ -24,13 +25,17 @@ #:demo-text-editor #:demo-class-browser #:demo-treeview-tree - #:test-custom-window)) + #:test-custom-window + #:test-assistant + #:test-entry-completion + #:test-ui-markup)) (in-package :gtk-demo) (defparameter *src-location* (asdf:component-pathname (asdf:find-system :cl-gtk2-gtk))) (defun test () + "A simple test of 'on-expose' event" (within-main-loop (let ((window (make-instance 'gtk-window :type :toplevel :app-paintable t)) x y) @@ -60,6 +65,7 @@ (push :pointer-motion-mask (gdk-window-events (widget-window window)))))) (defun test-entry () + "Testing GtkTextEntry" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing entry" :border-width 10)) (box (make-instance 'v-box)) @@ -101,6 +107,7 @@ (widget-show window)))) (defun table-packing () + "Simple test of packing widgets into GtkTable" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Table packing" :border-width 20)) (table (make-instance 'table :n-rows 2 :n-columns 2 :homogeneous t)) @@ -116,6 +123,7 @@ (widget-show window)))) (defun test-pixbuf () + "(not completed)" (within-main-loop (let* ((window (make-instance 'gtk-window :title "Test pixbuf" :request-width 600 :request-height 240)) (vbox (make-instance 'v-box)) @@ -131,6 +139,7 @@ (widget-show window)))) (defun test-image () + "Using GtkImage with stock icon" (within-main-loop (let* ((window (make-instance 'gtk-window :title "Test images")) (image (make-instance 'image :icon-name "applications-development" :icon-size 6))) @@ -139,6 +148,7 @@ (widget-show window)))) (defun test-progress-bar () + "Testing progress-bar" (within-main-loop (let* ((window (make-instance 'gtk-window :title "Test progress bar")) (v-box (make-instance 'v-box)) @@ -159,13 +169,14 @@ (coerce (read-from-string (entry-text entry)) 'real)))) (widget-show window)))) -(defun test-status-bar () +(defun test-statusbar () + "Test of GtkStatusbar" (within-main-loop (let* ((window (make-instance 'gtk-window :title "Text status bar")) (v-box (make-instance 'v-box)) (h-box (make-instance 'h-box)) (label (make-instance 'label :label "Test of status bar" :xalign 0.5 :yalign 0.5)) - (status-bar (make-instance 'statusbar :has-resize-grip t)) + (statusbar (make-instance 'statusbar :has-resize-grip t)) (button-push (make-instance 'button :label "Push")) (button-pop (make-instance 'button :label "Pop")) (entry (make-instance 'entry)) @@ -177,10 +188,10 @@ (leave-gtk-main))) (g-signal-connect button-push "clicked" (lambda (b) (declare (ignore b)) - (status-bar-push status-bar "lisp-prog" (entry-text entry)))) + (statusbar-push statusbar "lisp-prog" (entry-text entry)))) (g-signal-connect button-pop "clicked" (lambda (b) (declare (ignore b)) - (status-bar-pop status-bar "lisp-prog"))) + (statusbar-pop statusbar "lisp-prog"))) (g-signal-connect icon "activate" (lambda (i) (declare (ignore i)) (let ((message-dialog (make-instance 'message-dialog @@ -194,11 +205,12 @@ (box-pack-start h-box button-push :expand nil) (box-pack-start h-box button-pop :expand nil) (box-pack-start v-box label) - (box-pack-start v-box status-bar :expand nil) + (box-pack-start v-box statusbar :expand nil) (widget-show window) (setf (status-icon-screen icon) (gtk-window-screen window))))) (defun test-scale-button () + "Test of scale button with icons" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing scale button")) (button (make-instance 'scale-button :icons (list "media-seek-backward" "media-seek-forward" "media-playback-stop" "media-playback-start") :adjustment (make-instance 'adjustment :lower -40 :upper 50 :value 20)))) @@ -207,6 +219,7 @@ (widget-show window)))) (defun test-text-view () + "Test of GtkTextView" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Testing text view" :width-request 400 :height-request 300)) (button (make-instance 'button :label "Do")) @@ -264,6 +277,7 @@ (widget-show window)))) (defun demo-code-editor () + "(unfinished)" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Code editor" :width-request 400 :height-request 400 :window-position :center)) (scrolled (make-instance 'scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic)) @@ -281,6 +295,7 @@ (defstruct tvi title value) (defun test-treeview-list () + "Test of treeview with CL-GTK2-GTK:ARRAY-LIST-STORE" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (list)")) (model (make-instance 'array-list-store)) @@ -335,6 +350,7 @@ (widget-show window)))) (defun test-combo-box () + "Testing GtkComboBox" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (list)")) (model (make-instance 'array-list-store)) @@ -378,6 +394,7 @@ (widget-show window)))) (defun test-ui-manager () + "Testing GtkUIManager" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "UI Manager" :default-width 200 :default-height 100 :window-position :center)) (ui-manager (make-instance 'ui-manager)) @@ -415,6 +432,7 @@ (widget-show window)))) (defun test-color-button () + "Test of GtkColorButton" (within-main-loop (let ((window (make-instance 'gtk-window :title "Color button" :type :toplevel :window-position :center :width-request 100 :height-request 100)) (button (make-instance 'color-button :title "Color button"))) @@ -426,6 +444,7 @@ (widget-show window)))) (defun test-color-selection () + "Test of GtkColorSelection" (within-main-loop (let ((window (make-instance 'gtk-window :title "Color selection" :type :toplevel :window-position :center)) (selection (make-instance 'color-selection :has-opacity-control t))) @@ -435,6 +454,7 @@ (widget-show window)))) (defun test-file-chooser () + "Test of GtkFileChooser" (within-main-loop (let ((window (make-instance 'gtk-window :title "file chooser" :type :toplevel :window-position :center :default-width 100 :default-height 100)) (v-box (make-instance 'v-box)) @@ -456,6 +476,7 @@ (widget-show window)))) (defun test-font-chooser () + "GtkFontChooser" (within-main-loop (let ((window (make-instance 'gtk-window :title "fonts" :type :toplevel :window-position :center :default-width 100 :default-height 100)) (v-box (make-instance 'v-box)) @@ -467,6 +488,7 @@ (widget-show window)))) (defun test-notebook () + "Test GtkNotebook" (within-main-loop (let ((window (make-instance 'gtk-window :title "Notebook" :type :toplevel :window-position :center :default-width 100 :default-height 100)) (expander (make-instance 'expander :expanded t :label "notebook")) @@ -499,6 +521,7 @@ "!")) (defun test-calendar () + "Test of GtkCalendar" (within-main-loop (let ((window (make-instance 'gtk-window :title "Calendar" :type :toplevel :window-position :center :default-width 100 :default-height 100)) (calendar (make-instance 'calendar :detail-function #'calendar-detail))) @@ -511,6 +534,7 @@ (widget-show window)))) (defun test-box-child-property () + "Test of child-property usage" (within-main-loop (let ((window (make-instance 'gtk-window :title "Text box child property" :type :toplevel :window-position :center :width-request 200 :height-request 200)) (box (make-instance 'h-box)) @@ -522,6 +546,7 @@ (widget-show window)))) (defun test-builder () + "Test of GtkBuilder" (within-main-loop (let ((builder (make-instance 'builder))) (builder-add-from-file builder (namestring (merge-pathnames "demo/demo1.ui" *src-location*))) @@ -532,9 +557,9 @@ #+nil(print (current-event)) (setf (text-buffer-text (text-view-buffer text-view)) (format nil "Clicked ~A times~%" (incf c))) - (status-bar-pop (builder-get-object builder "statusbar1") + (statusbar-pop (builder-get-object builder "statusbar1") "times") - (status-bar-push (builder-get-object builder "statusbar1") + (statusbar-push (builder-get-object builder "statusbar1") "times" (format nil "~A times" c)))) ("quit_cb" ,(lambda (&rest args) @@ -550,7 +575,7 @@ (dialog-run d) (object-destroy d))))))) (g-signal-connect (builder-get-object builder "window1") "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main))) - (status-bar-push (builder-get-object builder "statusbar1") "times" "0 times") + (statusbar-push (builder-get-object builder "statusbar1") "times" "0 times") (widget-show (builder-get-object builder "window1"))))) (defun read-text-file (file-name) @@ -563,19 +588,20 @@ do (write-string line str))))) (defun demo-text-editor () + "More advanced example: text editor with ability to evaluate lisp expressions" (within-main-loop (let* ((builder (let ((builder (make-instance 'builder))) (builder-add-from-file builder (namestring (merge-pathnames "demo/text-editor.ui" *src-location*))) builder)) (window (builder-get-object builder "window1")) (text-view (builder-get-object builder "textview1")) - (status-bar (builder-get-object builder "statusbar1")) + (statusbar (builder-get-object builder "statusbar1")) (file-name nil) (modified-p t)) - (status-bar-push status-bar "filename" "Untitled *") + (statusbar-push statusbar "filename" "Untitled *") (labels ((set-properties () - (status-bar-pop status-bar "filename") - (status-bar-push status-bar "filename" (format nil "~A~:[~; *~]" (or file-name "Untitled") modified-p))) + (statusbar-pop statusbar "filename") + (statusbar-push statusbar "filename" (format nil "~A~:[~; *~]" (or file-name "Untitled") modified-p))) (new (&rest args) (declare (ignore args)) (setf file-name nil modified-p t @@ -612,7 +638,7 @@ (save)) (object-destroy d)))) (cut (&rest args) (declare (ignore args)) - (text-buffer-cut-clipboard (text-view-buffer text-view) (get-clipboard "CLIPBOARD"))) + (text-buffer-cut-clipboard (text-view-buffer text-view) (get-clipboard "CLIPBOARD") t)) (copy (&rest args) (declare (ignore args)) (text-buffer-copy-clipboard (text-view-buffer text-view) (get-clipboard "CLIPBOARD"))) (paste (&rest args) (declare (ignore args)) @@ -660,6 +686,7 @@ (widget-show window))))) (defun demo-class-browser () + "Show slots of a given class" (let ((output *standard-output*)) (with-main-loop (let* ((window (make-instance 'gtk-window @@ -717,6 +744,7 @@ node)) (defun demo-treeview-tree () + "Advanced demo: show s-expression tree structure" (within-main-loop (let* ((window (make-instance 'gtk-window :type :toplevel :title "Treeview (tree)")) (model (make-instance 'tree-lisp-store)) @@ -793,6 +821,141 @@ (format nil "Now is: ~A~%" (get-internal-run-time)))) (defun test-custom-window () + "Simple test of non-GObject subclass of GtkWindow" (within-main-loop (let ((w (make-instance 'custom-window))) (widget-show w)))) + +(defun test-assistant () + "Simple test of GtkAssistant wizard" + (let ((output *standard-output*)) + (within-main-loop + (let ((d (make-instance 'assistant :title "Username wizard")) + (p-1 (make-instance 'h-box)) + (entry (make-instance 'entry)) + (p-2 (make-instance 'label :label "Click Apply to close this wizard"))) + (box-pack-start p-1 (make-instance 'label :label "Enter your name:") :expand nil) + (box-pack-start p-1 entry) + (assistant-append-page d p-1) + (assistant-append-page d p-2) + (setf (assistant-child-title d p-1) "Username wizard" + (assistant-child-title d p-2) "Username wizard" + (assistant-child-complete d p-1) nil + (assistant-child-complete d p-2) t + (assistant-child-page-type d p-1) :intro + (assistant-child-page-type d p-2) :confirm + (assistant-forward-page-function d) (lambda (i) + (format output "(assistant-forward-page-function ~A)~%" i) + (ecase i + (0 1) + (1 -1)))) + (connect-signal entry "notify::text" (lambda (object pspec) + (declare (ignore object pspec)) + (setf (assistant-child-complete d p-1) + (plusp (length (entry-text entry)))))) + (let ((w (make-instance 'label :label "A label in action area"))) + (widget-show w) + (assistant-add-action-widget d w)) + (connect-signal d "cancel" (lambda (assistant) + (declare (ignore assistant)) + (object-destroy d) + (format output "Canceled~%"))) + (connect-signal d "close" (lambda (assistant) + (declare (ignore assistant)) + (object-destroy d) + (format output "Thank you, ~A~%" (entry-text entry)))) + (connect-signal d "prepare" (lambda (assistant page-widget) + (declare (ignore assistant page-widget)) + (format output "Assistant ~A has ~A pages and is on ~Ath page~%" + d (assistant-n-pages d) (assistant-current-page d)))) + (widget-show d))))) + +(defun test-entry-completion () + "Not working example of GtkEntryCompletion" + (within-main-loop + (let* ((w (make-instance 'gtk-window)) + (model (make-instance 'tree-lisp-store))) + (tree-lisp-store-add-column model "gchararray" #'identity) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Monday") 0) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Tuesday") 0) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Wednesday") 0) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Thursday") 0) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Friday") 0) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Saturday") 0) + (tree-node-insert-at (tree-lisp-store-root model) (make-tree-node :item "Sunday") 0) + (let* ((completion (make-instance 'entry-completion :model model :text-column 0)) + (e (make-instance 'entry :completion completion))) + (setf (entry-completion-text-column completion) 0) + (container-add w e)) + (widget-show w)))) + +(defun demo-all () + (within-main-loop + (let* ((window (make-instance 'gtk-window + :title "cl-gtk2-gtk demo" + :window-position :center + :default-width 500 + :default-height 500)) + (scrolled (make-instance 'scrolled-window + :hscrollbar-policy :automatic + :vscrollbar-policy :automatic)) + (viewport (make-instance 'viewport)) + (v-box-buttons (make-instance 'v-box)) + (v-box-top (make-instance 'v-box))) + (container-add window v-box-top) + (box-pack-start v-box-top (make-instance 'label :label "These are the demos of cl-gtk2-gtk:") :expand nil) + (box-pack-start v-box-top scrolled) + (container-add scrolled viewport) + (container-add viewport v-box-buttons) + (iter (for s in-package :gtk-demo :external-only t) + (for fn = (fdefinition s)) + (unless fn (next-iteration)) + (when (eq s 'gtk-demo:demo-all) (next-iteration)) + (for docstring = (documentation fn t)) + (for description = (format nil "~A~@[~%~A~]" (string-downcase (symbol-name s)) docstring)) + (for label = (make-instance 'label :label description :justify :center)) + (for button = (make-instance 'button)) + (container-add button label) + (connect-signal button "clicked" + (let ((fn fn)) + (lambda (b) + (declare (ignore b)) + (funcall fn)))) + (box-pack-start v-box-buttons button :expand nil)) + (widget-show window)))) + +(defun test-ui-markup () + (within-main-loop + (let ((label (make-instance 'label :label "Hello!"))) + (let-ui (gtk-window :type :toplevel + :position :center + :title "Hello, world!" + :default-width 300 + :default-height 400 + :var w + (v-box + (:expr label) :expand nil + (scrolled-window + :hscrollbar-policy :automatic + :vscrollbar-policy :automatic + :shadow-type :etched-in + (text-view :var tv)) + (h-box + (label :label "Insert:") :expand nil + (entry :var entry) + (button :label "gtk-ok" :use-stock t :var btn) :expand nil) + :expand nil + (label :label "Table packing") + :expand nil + (table + :n-columns 2 + :n-rows 2 + (label :label "2 x 1") :left 0 :right 2 :top 0 :bottom 1 + (label :label "1 x 1") :left 0 :right 1 :top 1 :bottom 2 + (label :label "1 x 1") :left 1 :right 2 :top 1 :bottom 2))) + (connect-signal btn "clicked" + (lambda (b) + (declare (ignore b)) + (text-buffer-insert (text-view-buffer tv) + (entry-text entry)))) + (widget-show w)))))