Renamed ASDF systems {gtk,gdk,glib} to clgtk2-{gtk,gdk,glib}

[cl-gtk2.git] / gtk / gtk.demo.lisp

diff --git a/gtk/gtk.demo.lisp b/gtk/gtk.demo.lisp
index 7282b5c..32410e7 100644 (file)
--- a/gtk/gtk.demo.lisp
+++ b/gtk/gtk.demo.lisp
@@ -1,5 +1,5 @@
 (defpackage :gtk-demo
-  (:use :cl :gtk :gdk :gobject :anaphora :iter)
+  (:use :cl :gtk :gdk :gobject :iter)
   (:export #:test
            #:test-entry
            #:table-packing
@@ -12,7 +12,6 @@
            #:demo-code-editor
            #:test-treeview-list
            #:test-combo-box
-           #:test-toolbar
            #:test-ui-manager
            #:test-color-button
            #:test-color-selection
@@ -22,11 +21,12 @@
            #:test-calendar
            #:test-box-child-property
            #:test-builder
-           #:demo-text-editor))
+           #:demo-text-editor
+           #:demo-class-browser))
 
 (in-package :gtk-demo)
 
-(defparameter *src-location* (asdf:component-pathname (asdf:find-system :gtk)))
+(defparameter *src-location* (asdf:component-pathname (asdf:find-system :clgtk2-gtk)))
 
 (defun test ()
   (within-main-loop
@@ -392,8 +392,9 @@
             (for action = (make-instance 'action :name name :stock-id stock-id))
             (g-signal-connect action "activate" fn)
             (action-group-add-action action-group action))
-      (awhen (ui-manager-widget ui-manager "/toolbar1")
-        (container-add window it))
+      (let ((widget (ui-manager-widget ui-manager "/toolbar1")))
+        (when widget
+          (container-add window widget)))
       (widget-show window))))
 
 (defun test-color-button ()
@@ -455,7 +456,15 @@
       (iter (for i from 0 to 5)
             (for page = (make-instance 'label :label (format nil "Label for page ~A" i)))
             (for tab-label = (make-instance 'label :label (format nil "Tab ~A" i)))
-            (for tab-button = (make-instance 'button :use-stock t :label "gtk-close" :relief :none))
+            (for tab-button = (make-instance 'button
+                                             :image (make-instance 'image :stock "gtk-close" :icon-size 1)
+                                             :relief :none))
+            (g-signal-connect tab-button "clicked"
+                              (let ((page page))
+                                (lambda (button)
+                                  (declare (ignore button))
+                                  (format t "Removing page ~A~%" page)
+                                  (notebook-remove-page notebook page))))
             (for tab-hbox = (make-instance 'h-box))
             (box-pack-start tab-hbox tab-label)
             (box-pack-start tab-hbox tab-button)
@@ -536,8 +545,9 @@
 
 (defun demo-text-editor ()
   (within-main-loop
-    (let* ((builder (aprog1 (make-instance 'builder)
-                      (builder-add-from-file it (namestring (merge-pathnames "demo/text-editor.ui" *src-location*)))))
+    (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"))
@@ -628,4 +638,53 @@
                                                   ("eval" ,#'cb-eval)))
         (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (leave-gtk-main)))
         (g-signal-connect (text-view-buffer text-view) "changed" (lambda (b) (declare (ignore b)) (setf modified-p t) (set-properties)))
-        (widget-show window)))))
\ No newline at end of file
+        (widget-show window)))))
+
+(defun demo-class-browser ()
+  (let ((output *standard-output*))
+    (with-main-loop
+        (let* ((window (make-instance 'gtk-window
+                                      :window-position :center
+                                      :title "Class Browser"
+                                      :default-width 400
+                                      :default-height 600))
+               (search-entry (make-instance 'entry))
+               (search-button (make-instance 'button :label "Search"))
+               (scroll (make-instance 'scrolled-window
+                                      :hscrollbar-policy :automatic
+                                      :vscrollbar-policy :automatic))
+               (slots-model (make-instance 'array-list-store))
+               (slots-list (make-instance 'tree-view :model slots-model)))
+          (let ((v-box (make-instance 'v-box))
+                (search-box (make-instance 'h-box)))
+            (container-add window v-box)
+            (box-pack-start v-box search-box :expand nil)
+            (box-pack-start search-box search-entry)
+            (box-pack-start search-box search-button :expand nil)
+            (box-pack-start v-box scroll)
+            (container-add scroll slots-list))
+          (store-add-column slots-model "gchararray"
+                            (lambda (slot)
+                              (format nil "~S" (closer-mop:slot-definition-name slot))))
+          (let ((col (make-instance 'tree-view-column :title "Slot name"))
+                (cr (make-instance 'cell-renderer-text)))
+            (tree-view-column-pack-start col cr)
+            (tree-view-column-add-attribute col cr "text" 0)
+            (tree-view-append-column slots-list col))
+          (labels ((display-class-slots (class)
+                     (format output "Displaying ~A~%" class)
+                     (loop
+                        repeat (store-items-count slots-model)
+                        do (store-remove-item slots-model (store-item slots-model 0)))
+                     (closer-mop:finalize-inheritance class)
+                     (loop
+                        for slot in (closer-mop:class-slots class)
+                        do (store-add-item slots-model slot)))
+                   (on-search-clicked (button)
+                     (declare (ignore button))
+                     (with-gtk-message-error-handler
+                         (let* ((class-name (read-from-string (entry-text search-entry)))
+                                (class (find-class class-name)))
+                           (display-class-slots class)))))
+            (g-signal-connect search-button "clicked" #'on-search-clicked))
+          (widget-show window)))))