-(let ((color-dialog nil))
- (defun create-color-selection ()
- (unless color-dialog
- (setq color-dialog
- (color-selection-dialog-new "color selection dialog"))
-
- (setf (window-position color-dialog) :mouse)
- (signal-connect
- color-dialog 'destroy #'(lambda () (widget-destroyed color-dialog)))
-
- (let ((colorsel (color-selection-dialog-colorsel color-dialog)))
- (setf (color-selection-use-opacity-p colorsel) t)
- (setf (color-selection-policy colorsel) :continuous)
-
-; (signal-connect colorsel 'color-changed #'(lambda () nil))
-
- (let ((button (color-selection-dialog-ok-button color-dialog)))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((color (color-selection-color colorsel)))
- (format t "Selected color: ~A~%" color)
- (setf (color-selection-color colorsel) color))))))
-
- (let ((button (color-selection-dialog-cancel-button color-dialog)))
- (signal-connect
- button 'clicked #'widget-destroy :object color-dialog)))
-
- (if (not (widget-visible-p color-dialog))
- (widget-show-all color-dialog)
- (widget-destroy color-dialog))))
-
-
-
-;;; CTree
-
-(let ((total-pages 0)
- (total-books 0)
- (status-labels)
- (style1)
- (style2)
- (pixmap1)
- (pixmap2)
- (pixmap3))
-
- (defun after-press (ctree &rest data)
- (declare (ignore data))
- (setf
- (label-text (svref status-labels 0))
- (format nil "~D" total-books))
- (setf
- (label-text (svref status-labels 1))
- (format nil "~D" total-pages))
- (setf
- (label-text (svref status-labels 2))
- (format nil "~D" (length (clist-selection ctree))))
- (setf
- (label-text (svref status-labels 3))
- (format nil "~D" (clist-n-rows ctree)))
- nil)
-
- (defun build-recursive (ctree parent current-depth depth books pages)
- (let ((sibling nil))
- (do ((i (+ pages books) (1- i)))
- ((= i books))
- (declare (fixnum i))
- (incf total-pages)
- (setq
- sibling
- (ctree-insert-node
- ctree parent sibling
- (list
- (format nil "Page ~D" (random 100))
- (format nil "Item ~D-~D" current-depth i))
- 5 :pixmap pixmap3 :leaf t))
- (when (and parent (eq (ctree-line-style ctree) :tabbed))
- (setf
- (ctree-row-style ctree sibling)
- (ctree-row-style ctree parent))))
-
- (unless (= current-depth depth)
- (do ((i books (1- i)))
- ((zerop i))
- (incf total-books)
- (setq
- sibling
- (ctree-insert-node
- ctree parent sibling
- (list
- (format nil "Book ~D" (random 100))
- (format nil "Item ~D-~D" current-depth i))
- 5 :closed pixmap1 :opened pixmap2))
-
- (let ((style (style-new))
- (color (case (mod current-depth 3)
- (0 (vector
- (* 10000 (mod current-depth 6))
- 0
- (- 65535 (mod (* i 10000) 65535))))
- (1 (vector
- (* 10000 (mod current-depth 6))
- (- 65535 (mod (* i 10000) 65535))
- 0))
- (t (vector
- (- 65535 (mod (* i 10000) 65535))
- 0
- (* 10000 (mod current-depth 6)))))))
- (setf (style-base style :normal) color)
- (ctree-set-node-data ctree sibling style #'style-unref)
-
- (when (eq (ctree-line-style ctree) :tabbed)
- (setf (ctree-row-style ctree sibling) style)))
-
- (build-recursive
- ctree sibling (1+ current-depth) depth books pages)))))
-
- (defun rebuild-tree (ctree depth books pages)
- (let ((n (* (/ (1- (expt books depth)) (1- books)) (1+ pages))))
- (if (> n 10000)
- (format t "~D total items? Try less~%" n)
- (progn
- (clist-freeze ctree)
- (clist-clear ctree)
- (setq total-books 1)
- (setq total-pages 0)
- (let ((parent
- (ctree-insert-node
- ctree nil nil '("Root") 5
- :closed pixmap1 :opened pixmap2 :expanded t))
- (style (style-new)))
- (setf (style-base style :normal) '#(0 45000 55000))
- (ctree-set-node-data ctree parent style #'style-unref)
-
- (when (eq (ctree-line-style ctree) :tabbed)
- (setf (ctree-row-style ctree parent) style))
-
- (build-recursive ctree parent 1 depth books pages)
- (clist-thaw ctree)
- (after-press ctree))))))
-
- (let ((export-window)
- (export-ctree))
- (defun export-tree (ctree)
- (unless export-window
- (setq export-window (window-new :toplevel))
- (signal-connect
- export-window 'destroy
- #'(lambda ()
- (widget-destroyed export-window)))
-
- (setf (window-title export-window) "Exported ctree")
- (setf (container-border-width export-window) 5)
-
- (let ((vbox (vbox-new nil 0)))
- (container-add export-window vbox)
-
- (let ((button (button-new "Close")))
- (box-pack-end vbox button nil t 0)
- (signal-connect
- button 'clicked #'widget-destroy :object export-window))
-
- (box-pack-end vbox (hseparator-new) nil t 10)
-
- (setq export-ctree (ctree-new '("Tree" "Info")))
- (setf (ctree-line-style export-ctree) :dotted)
-
- (let ((scrolled-window (scrolled-window-new)))
- (container-add scrolled-window export-ctree)
- (setf
- (scrolled-window-scrollbar-policy scrolled-window) :automatic)
- (box-pack vbox scrolled-window)
- (setf (clist-selection-mode export-ctree) :extended)
- (setf (clist-column-width export-ctree 0) 200)
- (setf (clist-column-width export-ctree 1) 200)
- (setf (widget-width export-ctree) 300)
- (setf (widget-height export-ctree) 200))))
-
- (unless (widget-visible-p export-window)
- (widget-show-all export-window))
-
- (clist-clear export-ctree)
- (let ((node (ctree-nth-node ctree (clist-focus-row ctree))))
- (when node
- (let ((tree-list
- (list (ctree-map-to-list ctree node #'(lambda (node) node)))))
- (ctree-insert-from-list
- export-ctree nil tree-list
- #'(lambda (export-ctree-node ctree-node)
- (multiple-value-bind
- (text spacing pixmap-closed bitmap-closed pixmap-opened
- bitmap-opened leaf expanded)
- (ctree-node-info ctree ctree-node)
- (ctree-set-node-info
- export-ctree export-ctree-node text spacing
- :closed (list pixmap-closed bitmap-closed)
- :opened (list pixmap-opened bitmap-opened)
- :leaf leaf :expanded expanded))
- (unless (eq (ctree-cell-type ctree ctree-node 1) :empty)
- (setf
- (ctree-cell-text export-ctree export-ctree-node 1)
- (ctree-cell-text ctree ctree-node 1))))))))))
-
-
- (define-test-window create-ctree "CTree"
- (let ((vbox (vbox-new nil 0))
- (ctree (ctree-new '("Tree" "Info"))))
-
- (container-add window vbox)
-
- (let ((hbox (hbox-new nil 5)))
- (setf (container-border-width hbox) 5)
- (box-pack-start vbox hbox nil t 0)
-
- (let ((spin1 (spin-button-new (adjustment-new 4 1 10 1 5 0) 0 0))
- (spin2 (spin-button-new (adjustment-new 3 1 20 1 5 0) 0 0))
- (spin3 (spin-button-new (adjustment-new 5 1 20 1 5 0) 0 0)))
-
- (box-pack-start hbox (label-new "Depth :") nil t 0)
- (box-pack-start hbox spin1 nil t 5)
- (box-pack-start hbox (label-new "Books :") nil t 0)
- (box-pack-start hbox spin2 nil t 5)
- (box-pack-start hbox (label-new "Pages :") nil t 0)
- (box-pack-start hbox spin3 nil t 5)
-
- (let ((button (button-new "Rebuild Tree")))
- (box-pack-start hbox button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((depth (spin-button-value-as-int spin1))
- (books (spin-button-value-as-int spin2))
- (pages (spin-button-value-as-int spin3)))
- (rebuild-tree ctree depth books pages))))))
-
- (let ((button (button-new "Close")))
- (box-pack-end hbox button t t 0)
- (signal-connect button 'clicked #'widget-destroy :object window)))
-
- (let ((scrolled-window (scrolled-window-new)))
- (setf (container-border-width scrolled-window) 5)
- (setf (scrolled-window-hscrollbar-policy scrolled-window) :automatic)
- (setf (scrolled-window-vscrollbar-policy scrolled-window) :always)
- (box-pack-start vbox scrolled-window t t 0)
-
- (container-add scrolled-window ctree)
- (setf (clist-column-auto-resize-p ctree 0) t)
- (setf (clist-column-width ctree 1) 200)
- (setf (clist-selection-mode ctree) :extended)
- (setf (ctree-line-style ctree) :dotted))
-
- (signal-connect
- ctree 'click-column
- #'(lambda (column)
- (cond
- ((/= column (clist-sort-column ctree))
- (setf (clist-sort-column ctree) column))
- ((eq (clist-sort-type ctree) :ascending)
- (setf (clist-sort-type ctree) :descending))
- (t (setf (clist-sort-type ctree) :ascending)))
- (ctree-sort-recursive ctree)))
-
- (signal-connect
- ctree 'button-press-event #'after-press :object t :after t)
- (signal-connect
- ctree 'button-release-event #'after-press :object t :after t)
- (signal-connect
- ctree 'tree-move #'after-press :object t :after t)
- (signal-connect
- ctree 'end-selection #'after-press :object t :after t)
- (signal-connect
- ctree 'toggle-focus-row #'after-press :object t :after t)
- (signal-connect
- ctree 'select-all #'after-press :object t :after t)
- (signal-connect
- ctree 'unselect-all #'after-press :object t :after t)
- (signal-connect
- ctree 'scroll-vertical #'after-press :object t :after t)
-
- (let ((bbox (hbox-new nil 5)))
- (setf (container-border-width bbox) 5)
- (box-pack-start vbox bbox nil t 0)
-
- (let ((mbox (vbox-new t 5)))
- (box-pack bbox mbox :expand nil)
- (box-pack mbox (label-new "Row Height :") :expand nil :fill nil)
- (box-pack mbox (label-new "Indent :") :expand nil :fill nil)
- (box-pack mbox (label-new "Spacing :") :expand nil :fill nil))
-
- (let ((mbox (vbox-new t 5)))
- (box-pack bbox mbox :expand nil)
-
- (let* ((adjustment (adjustment-new 20 12 100 1 10 0))
- (spinner (spin-button-new adjustment 0 0)))
- (box-pack mbox spinner :expand nil :fill nil :padding 5)
- (flet ((set-row-height ()
- (setf
- (clist-row-height ctree)
- (spin-button-value-as-int spinner))))
- (signal-connect adjustment 'value-changed #'set-row-height)
- (set-row-height)))
-
- (let* ((adjustment (adjustment-new 20 0 60 1 10 0))
- (spinner (spin-button-new adjustment 0 0)))
- (box-pack mbox spinner :expand nil :fill nil :padding 5)
- (flet ((set-indent ()
- (setf
- (ctree-indent ctree)
- (spin-button-value-as-int spinner))))
- (signal-connect adjustment 'value-changed #'set-indent)
- (set-indent)))
-
- (let* ((adjustment (adjustment-new 5 0 60 1 10 0))
- (spinner (spin-button-new adjustment 0 0)))
- (box-pack mbox spinner :expand nil :fill nil :padding 5)
- (flet ((set-spacing ()
- (setf
- (ctree-spacing ctree)
- (spin-button-value-as-int spinner))))
- (signal-connect adjustment 'value-changed #'set-spacing)
- (set-spacing))))
-
-
- (let ((mbox (vbox-new t 5)))
- (box-pack bbox mbox :expand nil)
-
- (let ((hbox (hbox-new nil 5)))
- (box-pack mbox hbox :expand nil :fill nil)
-
- (let ((button (button-new "Expand All")))
- (box-pack hbox button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (ctree-expand-recursive ctree nil)
- (after-press ctree))))
-
- (let ((button (button-new "Collapse All")))
- (box-pack hbox button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (ctree-collapse-recursive ctree nil)
- (after-press ctree))))
-
- (let ((button (button-new "Change Style")))
- (box-pack hbox button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((node (ctree-nth-node
- ctree (or (clist-focus-row ctree) 0))))
- (when node
- (unless style1
- (let ((color1 '#(0 56000 0))
- (color2 '#(32000 0 56000)))
- (setq style1 (style-new))
- (setf (style-base style1 :normal) color1)
- (setf (style-fg style1 :selected) color2)
-
- (setq style2 (style-new))
- (setf (style-base style2 :selected) color2)
- (setf (style-base style2 :normal) color2)
- (setf (style-fg style2 :normal) color1)
- (setf
- (style-font style2)
- "-*-courier-medium-*-*-*-*-300-*-*-*-*-*-*")))
- (setf (ctree-cell-style ctree node 1) style1)
- (setf (ctree-cell-style ctree node 0) style2)
-
- (when (ctree-node-child node)
- (setf
- (ctree-row-style ctree (ctree-node-child node))
- style2)))))))
-
- (let ((button (button-new "Export Tree")))
- (box-pack hbox button)
- (signal-connect button 'clicked #'export-tree :object ctree)))
-
- (let ((hbox (hbox-new nil 5)))
- (box-pack mbox hbox :expand nil :fill nil)
-
- (let ((button (button-new "Select All")))
- (box-pack hbox button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (ctree-select-recursive ctree nil)
- (after-press ctree))))
-
- (let ((button (button-new "Unselect All")))
- (box-pack hbox button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (ctree-unselect-recursive ctree nil)
- (after-press ctree))))
-
- (let ((button (button-new "Remove Selection")))
- (box-pack hbox button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (clist-freeze ctree)
- (let ((selection-mode (clist-selection-mode ctree)))
- (labels
- ((remove-selection ()
- (let ((node (first (ctree-selection ctree))))
- (when node
-
- (ctree-apply-post-recursive
- ctree node
- #'(lambda (node)
- (if (ctree-node-leaf-p node)
- (decf total-pages)
- (decf total-books))))
-
- (ctree-remove-node ctree node)
- (unless (eq selection-mode :browse)
- (remove-selection))))))
- (remove-selection))
-
- (when (and
- (eq selection-mode :extended)
- (not (clist-selection ctree))
- (clist-focus-row ctree))
- (ctree-select
- ctree
- (ctree-nth-node ctree (clist-focus-row ctree)))))
- (clist-thaw ctree)
- (after-press ctree))))
-
- (let ((button (check-button-new "Reorderable")))
- (box-pack hbox button :expand nil)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (setf
- (clist-reorderable-p ctree)
- (toggle-button-active-p button))))
- (setf (toggle-button-active-p button) t)))
-
- (let ((hbox (hbox-new nil 5)))
- (box-pack mbox hbox :expand nil :fill nil)
-
- (flet
- ((set-line-style (line-style)
- (let ((current-line-style (ctree-line-style ctree)))
- (when (or
- (and
- (eq current-line-style :tabbed)
- (not (eq line-style :tabbed)))
- (and
- (not (eq current-line-style :tabbed))
- (eq line-style :tabbed)))
- (ctree-apply-pre-recursive
- ctree nil
- #'(lambda (node)
- (let
- ((style
- (cond
- ((eq (ctree-line-style ctree) :tabbed) nil)
- ((not (ctree-node-leaf-p node))
- (ctree-node-data ctree node))
- ((ctree-node-parent node)
- (ctree-node-data
- ctree (ctree-node-parent node))))))
- (setf (ctree-row-style ctree node) style))))
- (setf (ctree-line-style ctree) line-style)))))
-
- (let ((option-menu
- (build-option-menu
- `(("No lines" ,#'(lambda () (set-line-style :none)))
- ("Solid" ,#'(lambda () (set-line-style :solid)))
- ("Dotted" ,#'(lambda () (set-line-style :dotted)))
- ("Tabbed" ,#'(lambda () (set-line-style :tabbed))))
- 2)))
- (box-pack hbox option-menu :expand nil)))
-
- (let ((option-menu
- (build-option-menu
- `(("None"
- ,#'(lambda ()
- (setf (ctree-expander-style ctree) :none)))
- ("Square"
- ,#'(lambda ()
- (setf (ctree-expander-style ctree) :square)))
- ("Triangle"
- ,#'(lambda ()
- (setf (ctree-expander-style ctree) :triangle)))
- ("Circular"
- ,#'(lambda ()
- (setf (ctree-expander-style ctree) :circular))))
- 1)))
- (box-pack hbox option-menu :expand nil))
-
- (let ((option-menu
- (build-option-menu
- `(("Left"
- ,#'(lambda ()
- (setf
- (clist-column-justification ctree 0) :left)))
- ("Right"
- ,#'(lambda ()
- (setf
- (clist-column-justification ctree 0) :right))))
- 0)))
- (box-pack hbox option-menu :expand nil))
-
- (flet ((set-sel-mode (mode)
- (setf (clist-selection-mode ctree) mode)
- (after-press ctree)))
- (let ((option-menu
- (build-option-menu
- `(("Single" ,#'(lambda () (set-sel-mode :single)))
- ("Browse" ,#'(lambda () (set-sel-mode :browse)))
- ("Multiple" ,#'(lambda () (set-sel-mode :multiple)))
- ("Extended" ,#'(lambda () (set-sel-mode :extended))))
- 3)))
- (box-pack hbox option-menu :expand nil))))))
-
- (let ((frame (frame-new)))
- (setf (container-border-width frame) 0)
- (setf (frame-shadow-type frame) :out)
- (box-pack vbox frame :expand nil)
-
- (let ((hbox (hbox-new t 2)))
- (setf (container-border-width hbox) 2)
- (container-add frame hbox)
-
- (setq
- status-labels
- (map 'vector
- #'(lambda (text)
- (let ((frame (frame-new))
- (hbox2 (hbox-new nil 0)))
- (setf (frame-shadow-type frame) :in)
- (box-pack hbox frame :expand nil)
- (setf (container-border-width hbox2) 2)
- (container-add frame hbox2)
- (box-pack hbox2 (label-new text) :expand nil)
- (let ((label (label-new "")))
- (box-pack-end hbox2 label nil t 5)
- label)))
- '("Books :" "Pages :" "Selected :" "Visible :")))))
-
- (widget-realize window)
- (let ((gdk:window (widget-window window)))
- (setq pixmap1 (multiple-value-list
- (gdk:pixmap-create book-closed-xpm :window gdk:window)))
- (setq pixmap2 (multiple-value-list
- (gdk:pixmap-create book-open-xpm :window gdk:window)))
- (setq pixmap3 (multiple-value-list
- (gdk:pixmap-create mini-page-xpm :window gdk:window))))
- (setf (widget-height ctree) 300)
-
- (rebuild-tree ctree 4 3 5))))