- (create-check-button "Editable" 'editable)
- (create-check-button "Visible" 'visible)
- (create-check-button "Sensitive" 'sensitive))))
-
-
-
-;; File selecetion dialog
-
-(let ((filesel nil))
- (defun create-file-selection ()
- (unless filesel
- (setq filesel (file-selection-new "file selection dialog"))
- (file-selection-hide-fileop-buttons filesel)
- (setf (window-position filesel) :mouse)
- (signal-connect
- filesel 'destroy #'(lambda () (widget-destroyed filesel)))
- (signal-connect
- (file-selection-ok-button filesel) 'clicked
- #'(lambda ()
- (format
- t "Selected file: ~A~%" (file-selection-filename filesel))
- (widget-destroy filesel)))
- (signal-connect
- (file-selection-cancel-button filesel) 'clicked
- #'widget-destroy :object filesel)
-
- (let ((button (button-new "Hide Fileops")))
- (signal-connect
- button 'clicked
- #'file-selection-hide-fileop-buttons :object filesel)
- (box-pack-start (file-selection-action-area filesel) button nil nil 0)
- (widget-show button))
-
- (let ((button (button-new "Show Fileops")))
- (signal-connect
- button 'clicked
- #'file-selection-show-fileop-buttons :object filesel)
- (box-pack-start (file-selection-action-area filesel) button nil nil 0)
- (widget-show button)))
-
- (if (not (widget-visible-p filesel))
- (widget-show-all filesel)
- (widget-destroy filesel))))
-
-
-
-;;; Handle box
-
-(defun create-handle-box-toolbar ()
- (let ((toolbar (toolbar-new :horizontal :both)))
- (toolbar-append-item
- toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Horizontal toolbar layout"
- :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
-
- (toolbar-append-item
- toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Vertical toolbar layout"
- :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Only show toolbar icons"
- :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
-
- (toolbar-append-item
- toolbar "Text" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Only show toolbar text"
- :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
-
- (toolbar-append-item
- toolbar "Both" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Show toolbar icons and text"
- :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Small" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Use small spaces"
- :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
-
- (toolbar-append-item
- toolbar "Big" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Use big spaces"
- :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Enable tooltips"
- :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
-
- (toolbar-append-item
- toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Disable tooltips"
- :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Show borders"
- :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
-
- (toolbar-append-item
- toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
- :tooltip-text "Hide borders"
- :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
-
- toolbar))
-
-
-(defun handle-box-child-signal (handle-box child action)
- (format t "~S: child ~S ~A~%" handle-box child action))
-
-
-(define-test-window create-handle-box "Handle Box Test"
- (setf (window-allow-grow-p window) t)
- (setf (window-allow-shrink-p window) t)
- (setf (window-auto-shrink-p window) nil)
- (setf (container-border-width window) 20)
- (let ((vbox (vbox-new nil 0)))
- (container-add window vbox)
+ (let ((combo (make-instance 'combo-box-entry
+ :parent main
+ :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
+ :label label :active t :parent main
+ :signal (list 'toggled
+ #'(lambda (button)
+ (setf (slot-value entry slot)
+ (toggle-button-active-p button)))
+ :object t))))
+
+ (create-check-button "Editable" 'editable)
+ (create-check-button "Visible" 'visibility)
+ (create-check-button "Sensitive" 'sensitive)))))
+
+
+;; Expander
+
+(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
+ (make-instance 'v-box
+ :parent dialog :spacing 5 :border-width 5
+ :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
+
+(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
+ (file-chooser-add-filter dialog
+ (make-instance 'file-filter :name "All files" :pattern "*"))
+ (file-chooser-add-filter dialog
+ (make-instance 'file-filter :name "Common Lisp source code"
+ :patterns '("*.lisp" "*.lsp")))
+
+ (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
+ (dialog-add-button dialog "gtk-ok"
+ #'(lambda ()
+ (if (slot-boundp dialog 'filename)
+ (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+ (write-line "No files selected"))
+ (widget-destroy dialog))))
+
+
+;; Font selection dialog
+
+(define-toplevel create-font-selection (window "Font Button" :resizable nil)
+ (make-instance 'h-box
+ :parent window :spacing 8 :border-width 8
+ :child (make-instance 'label :label "Pick a font")
+ :child (make-instance 'font-button
+ :use-font t :title "Font Selection Dialog")))
+
+
+;;; Icon View
+
+#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
+(let ((file-pixbuf nil)
+ (folder-pixbuf nil))
+ (defun load-pixbufs ()
+ (unless file-pixbuf
+ (handler-case
+ (setf
+ file-pixbuf (gdk:pixbuf-load #p"/usr/share/icons/gnome/48x48/filesystems/gnome-fs-regular.png")
+ folder-pixbuf (gdk:pixbuf-load #p"/usr/share/icons/gnome/48x48/filesystems/gnome-fs-directory.png"))
+ (glib:glib-error (condition)
+ (make-instance 'message-dialog
+ :message-type :error :visible t
+ :text "<b>Failed to load an image</b>"
+ :secondary-text (glib:gerror-message condition)
+ :signal (list :close #'widget-destroy :object t))
+ (return-from load-pixbufs nil))))
+ t)
+
+ (defun fill-store (store directory)
+ (list-store-clear store)
+ (let ((dir-listing
+ (mapcar #'namestring
+ (nconc
+ (directory (format nil "~A*" directory))
+ #+clisp(directory (format nil "~A*/" directory))))))
+ (loop
+ for pathname in dir-listing
+ do (let* ((directory-p
+ (char= #\/ (char pathname (1- (length pathname)))))
+ (filename
+ (subseq pathname
+ (length directory)
+ (if directory-p
+ (1- (length pathname))
+ (length pathname)))))
+ (list-store-append store
+ (vector
+ filename
+ (if directory-p folder-pixbuf file-pixbuf)
+ directory-p))))))
+
+ (defun sort-func (store a b)
+ (let ((a-dir-p (tree-model-value store a 'directory-p))
+ (b-dir-p (tree-model-value store b 'directory-p))
+ (a-name (tree-model-value store a 'filename))
+ (b-name (tree-model-value store b 'filename)))
+ (cond
+ ((and a-dir-p (not b-dir-p)) :before)
+ ((and (not a-dir-p) b-dir-p) :after)
+ ((string< a-name b-name) :before)
+ ((string> a-name b-name) :after)
+ (t :equal))))
+
+
+ (defun parent-dir (dir)
+ (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
+ (subseq dir 0 end)))
+
+ (define-toplevel create-icon-view (window "Icon View demo"
+ :default-width 650
+ :default-height 400)
+ (if (not (load-pixbufs))
+ (widget-destroy window)
+ (let* ((directory "/")
+ (store (make-instance 'list-store
+ :column-types '(string gdk:pixbuf boolean)
+ :column-names '(filename pixbuf directory-p)))
+ (icon-view (make-instance 'icon-view
+ :model store :selection-mode :multiple
+ :text-column 0 ;'filename
+ :pixbuf-column 1)) ;'pixbuf))
+ (up (make-instance 'tool-button
+ :stock "gtk-go-up" :is-important t :sensitive nil))
+ (home (make-instance 'tool-button
+ :stock "gtk-home" :is-important t)))
+ (tree-sortable-set-sort-func store :default #'sort-func)
+ (tree-sortable-set-sort-column store :default :ascending)
+ (fill-store store directory)
+
+ (signal-connect icon-view 'item-activated
+ #'(lambda (path)
+ (when (tree-model-value store path 'directory-p)
+ (setq directory
+ (concatenate 'string directory (tree-model-value store path 'filename) "/"))
+ (fill-store store directory)
+ (setf (widget-sensitive-p up) t))))
+
+ (signal-connect up 'clicked
+ #'(lambda ()
+ (unless (string= directory "/")
+ (setq directory (parent-dir directory))
+ (fill-store store directory)
+ (setf
+ (widget-sensitive-p home)
+ (not (string= directory (namestring (truename #p"clg:")))))
+ (setf (widget-sensitive-p up) (not (string= directory "/"))))))
+
+ (signal-connect home 'clicked
+ #'(lambda ()
+ (setq directory (namestring (truename #p"clg:")))
+ (fill-store store directory)
+ (setf (widget-sensitive-p up) t)
+ (setf (widget-sensitive-p home) nil)))
+
+ (make-instance 'v-box
+ :parent window
+ :child (list
+ (make-instance 'toolbar :child up :child home)
+ :fill nil :expand nil)
+ :child (make-instance 'scrolled-window
+ :shadow-type :etched-in :policy :automatic
+ :child icon-view))))))
~mdw / clg / blobdiff