-;; Common Lisp bindings for GTK+ v2.0
-;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
+;; Common Lisp bindings for GTK+ v2.x
+;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2 of the License, or (at your option) any later version.
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: testgtk.lisp,v 1.1 2000-08-14 16:44:26 espen Exp $
+;; Parts of this file are direct translations of code from 'testgtk.c'
+;; distributed with the Gtk+ library, and thus covered by the GNU
+;; Lesser General Public License and copyright Peter Mattis, Spencer
+;; Kimball, Josh MacDonald and others. To be safe the entire file
+;; should probably be considered as being GPL'ed.
-(use-package "GTK")
+;; $Id: testgtk.lisp,v 1.44 2008-12-09 19:37:19 espen Exp $
-(defmacro define-test-window (name title &body body)
- `(let ((window nil))
+#+sbcl(require :gtk)
+#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
+
+(defpackage "TESTGTK"
+ (:use "COMMON-LISP" "CLG"))
+
+(in-package "TESTGTK")
+
+(defmacro define-toplevel (name (window title &rest initargs) &body body)
+ `(let ((,window nil))
(defun ,name ()
- (unless window
- (setq window (window-new :toplevel))
- (signal-connect
- window 'destroy #'(lambda () (widget-destroyed window)))
- (setf (window-title window) ,title)
- (setf (container-border-width window) 0)
+ (unless ,window
+ (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
+ (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
,@body)
- (if (not (widget-visible-p window))
- (widget-show-all window)
- (widget-destroy window)))))
-
+ (when ,window
+ (if (not (widget-visible-p ,window))
+ (widget-show ,window)
+ (widget-hide ,window))))))
+
-(defmacro define-test-dialog (name title &body body)
- `(let ((window nil))
+(defmacro define-dialog (name (dialog title &optional (class 'dialog)
+ &rest initargs)
+ &body body)
+ `(let ((,dialog nil))
(defun ,name ()
- (unless window
- (setq window (dialog-new))
- (signal-connect
- window 'destroy #'(lambda () (widget-destroyed window)))
- (setf (window-title window) ,title)
- (setf (container-border-width window) 0)
- (let ((main-box (vbox-new nil 0))
- (action-area (dialog-action-area window)))
- (box-pack-start (dialog-vbox window) main-box t t 0)
- ,@body))
+ (unless ,dialog
+ (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
+ (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
+ ,@body)
- (if (not (widget-visible-p window))
- (widget-show-all window)
- (widget-destroy window)))))
-
-
-(defmacro define-standard-dialog (name title &body body)
- `(define-test-dialog ,name ,title
- (let ((close-button (button-new "close")))
- (signal-connect close-button 'clicked #'widget-destroy :object window)
- (setf (widget-can-default-p close-button) t)
- (box-pack-start action-area close-button t t 0)
- (widget-grab-default close-button)
- ,@body)))
-
-
-(defun build-option-menu (items history)
- (let ((option-menu (option-menu-new))
- (menu (menu-new)))
- (labels ((create-menu (items i group)
- (when items
- (let* ((item (first items))
- (menu-item (radio-menu-item-new group (first item))))
- (signal-connect
- menu-item 'activate
- #'(lambda ()
- (when (widget-mapped-p menu-item)
- (funcall (second item)))))
-
- (menu-append menu menu-item)
- (when (= i history)
- (setf (check-menu-item-active-p menu-item) t))
- (widget-show menu-item)
- (create-menu
- (rest items) (1+ i) (radio-menu-item-group menu-item))))))
- (create-menu items 0 nil))
- (setf (option-menu-menu option-menu) menu)
- (setf (option-menu-history option-menu) history)
- option-menu))
+ (when ,dialog
+ (if (not (widget-visible-p ,dialog))
+ (widget-show ,dialog)
+ (widget-hide ,dialog))))))
+
+
+(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
+ `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
+ ,@body
+ (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
;;; Pixmaps used in some of the tests
(defvar gtk-mini-xpm
- '("15 20 17 1"
+ #("15 20 17 1"
" c None"
". c #14121F"
"+ c #278828"
" >= "))
(defvar book-closed-xpm
- '("16 16 6 1"
+ #("16 16 6 1"
" c None s None"
". c black"
"X c red"
" "))
(defvar mini-page-xpm
- '("16 16 4 1"
+ #("16 16 4 1"
" c None s None"
". c black"
"X c white"
" "))
(defvar book-open-xpm
- '("16 16 4 1"
+ #("16 16 4 1"
" c None s None"
". c black"
"X c #808080"
;;; Button box
-(defun create-bbox (class title spacing child-w child-h layout)
- (let* ((frame (make-instance 'frame :title title))
- (bbox (make-instance 'class
- :border-width 5
- :layout layout
- :spacing spacing
- :childrent
- (list
- (make-instance 'button :label "OK")
- (make-instance 'button :label "Cancel")
- (make-instance 'button :label "Help"))
- :parent frame)))
- (setf (button-box-child-size bbox) (vector child-w child-h))
- frame))
-
-
-(define-test-window create-button-box "Button Boxes"
- (setf (container-border-width window) 10)
- (let ((main-box (vbox-new nil 0)))
- (let ((frame (frame-new "Horizontal Button Boxes"))
- (box (vbox-new nil 0)))
- (container-add window main-box)
- (box-pack-start main-box frame t t 10)
- (setf (container-border-width box) 10)
- (container-add frame box)
- (box-pack-start
- box (create-bbox #'hbutton-box-new "Spread" 40 85 20 :spread) t t 0)
- (box-pack-start
- box (create-bbox #'hbutton-box-new "Edge" 40 85 20 :edge) t t 0)
- (box-pack-start
- box (create-bbox #'hbutton-box-new "Start" 40 85 20 :start) t t 0)
- (box-pack-start
- box (create-bbox #'hbutton-box-new "End" 40 85 20 :end) t t 0))
-
- (let ((frame (frame-new "Vertical Button Boxes"))
- (box (hbox-new nil 0)))
- (box-pack-start main-box frame t t 10)
- (setf (container-border-width box) 10)
- (container-add frame box)
- (box-pack-start
- box (create-bbox #'vbutton-box-new "Spread" 30 85 20 :spread) t t 5)
- (box-pack-start
- box (create-bbox #'vbutton-box-new "Edge" 30 85 20 :edge) t t 5)
- (box-pack-start
- box (create-bbox #'vbutton-box-new "Start" 30 85 20 :start) t t 5)
- (box-pack-start
- box (create-bbox #'vbutton-box-new "End" 30 85 20 :end) t t 5))))
-
-
-
-(define-standard-dialog create-buttons "Buttons"
- (let ((table (table-new 3 3 nil))
- (buttons `((,(button-new "button1") 0 1 0 1)
- (,(button-new "button2") 1 2 1 2)
- (,(button-new "button3") 2 3 2 3)
- (,(button-new "button4") 0 1 2 3)
- (,(button-new "button5") 2 3 0 1)
- (,(button-new "button6") 1 2 2 3)
- (,(button-new "button7") 1 2 0 1)
- (,(button-new "button8") 2 3 1 2)
- (,(button-new "button9") 0 1 1 2))))
- (setf (table-row-spacings table) 5)
- (setf (table-column-spacings table) 5)
- (setf (container-border-width table) 10)
- (box-pack-start main-box table t t 0)
- (do ((tmp buttons (rest tmp)))
- ((endp tmp))
- (let ((button (first tmp))
- (widget (or (first (second tmp))
- (first (first buttons)))))
- (signal-connect (first button) 'clicked
- #'(lambda ()
- (if (widget-visible-p widget)
- (widget-hide widget)
- (widget-show widget))))
- (apply #'table-attach table button)))))
+(defun create-bbox-in-frame (class frame-label spacing width height layout)
+ (declare (ignore width height))
+ (make-instance 'frame
+ :label frame-label
+ :child (make-instance class
+ :border-width 5 :layout-style layout :spacing spacing
+ :child (make-instance 'button :stock "gtk-ok")
+ :child (make-instance 'button :stock "gtk-cancel")
+ :child (make-instance 'button :stock "gtk-help"))))
+
+(define-toplevel create-button-box (window "Button Boxes")
+ (make-instance 'v-box
+ :parent window :border-width 10 :spacing 10
+ :child (make-instance 'frame
+ :label "Horizontal Button Boxes"
+ :child (make-instance 'v-box
+ :border-width 10 :spacing 10
+ :children (mapcar
+ #'(lambda (args)
+ (apply #'create-bbox-in-frame
+ 'h-button-box args))
+ '(("Spread" 40 85 20 :spread)
+ ("Edge" 40 85 20 :edge)
+ ("Start" 40 85 20 :start)
+ ("End" 40 85 20 :end)))))
+ :child (make-instance 'frame
+ :label "Vertical Button Boxes"
+ :child (make-instance 'h-box
+ :border-width 10 :spacing 10
+ :children (mapcar
+ #'(lambda (args)
+ (apply #'create-bbox-in-frame
+ 'v-button-box args))
+ '(("Spread" 30 85 20 :spread)
+ ("Edge" 30 85 20 :edge)
+ ("Start" 30 85 20 :start)
+ ("End" 30 85 20 :end)))))))
+
+
+;; Buttons
+
+(define-simple-dialog create-buttons (dialog "Buttons")
+ (let ((table (make-instance 'table
+ :n-rows 3 :n-columns 3 :homogeneous nil
+ :row-spacing 5 :column-spacing 5 :border-width 10
+ :parent dialog))
+ (buttons (loop
+ for n from 1 to 10
+ collect (make-instance 'button
+ :label (format nil "button~D" (1+ n))))))
+
+ (dotimes (column 3)
+ (dotimes (row 3)
+ (let ((button (nth (+ (* 3 row) column) buttons))
+ (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
+ (signal-connect button 'clicked
+ #'(lambda ()
+ (if (widget-visible-p button+1)
+ (widget-hide button+1)
+ (widget-show button+1))))
+ (table-attach table button column (1+ column) row (1+ row)
+ :options '(:expand :fill)))))))
;; Calenadar
-(define-standard-dialog create-calendar "Calendar"
- (setf (container-border-width main-box) 10)
- (box-pack-start main-box (calendar-new) t t 0))
-
+(define-simple-dialog create-calendar (dialog "Calendar")
+ (make-instance 'v-box
+ :parent dialog :border-width 10
+ :child (make-instance 'calendar)))
;;; Check buttons
-(define-standard-dialog create-check-buttons "GtkCheckButton"
- (setf (container-border-width main-box) 10)
- (setf (box-spacing main-box) 10)
- (box-pack-start main-box (check-button-new "button1") t t 0)
- (box-pack-start main-box (check-button-new "button2") t t 0)
- (box-pack-start main-box (check-button-new "button3") t t 0))
-
-
-
-;;; CList
-
-(let ((style1 nil)
- (style2 nil)
- (style3 nil))
- (defun insert-row-clist (clist)
- (let* ((text '("This" "is" "an" "inserted" "row"
- "This" "is" "an" "inserted" "row"
- "This" "is" "an" "inserted" "row"
- "This" "is" "an" "inserted" "row"))
- (row
- (if (clist-focus-row clist)
- (clist-insert clist (clist-focus-row clist) text)
- (clist-prepend clist text))))
-
- (unless style1
- (let ((color1 '#(0 56000 0))
- (color2 '#(32000 0 56000)))
- (setq style1 (style-copy (widget-style clist)))
- (setf
- (style-base style1 :normal) color1
- (style-base style1 :selected) color2)
-
- (setq style2 (style-copy (widget-style clist)))
- (setf
- (style-fg style2 :normal) color1
- (style-fg style2 :selected) color2)
-
- (setq style3 (style-copy (widget-style clist)))
- (setf
- (style-fg style3 :normal) color1
- (style-base style3 :normal) color2
- (style-font style3) "-*-courier-medium-*-*-*-*-120-*-*-*-*-*-*")))
-
- (setf (clist-cell-style clist row 3) style1)
- (setf (clist-cell-style clist row 4) style2)
- (setf (clist-cell-style clist row 0) style3))))
-
-
-(define-standard-dialog create-clist "clist"
- (let* ((titles '("auto resize" "not resizeable" "max width 100"
- "min width 50" "hide column" "Title 5" "Title 6"
- "Title 7" "Title 8" "Title 9" "Title 10"
- "Title 11" "Title 12" "Title 13" "Title 14"
- "Title 15" "Title 16" "Title 17" "Title 18"
- "Title 19"))
- (clist (clist-new titles))
- (scrolled-window (scrolled-window-new nil nil)))
-
- (setf (container-border-width scrolled-window) 5)
- (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
- (container-add scrolled-window clist)
-
- (signal-connect
- clist 'click-column
- #'(lambda (column)
- (cond
- ((= column 4)
- (setf (clist-column-visible-p clist column) nil))
- ((= column (clist-sort-column clist))
- (if (eq (clist-sort-type clist) :ascending)
- (setf (clist-sort-type clist) :descending)
- (setf (clist-sort-type clist) :ascending)))
- (t
- (setf (clist-sort-column clist) column)))
- (clist-sort clist)))
-
- (let ((box2 (hbox-new nil 5)))
- (setf (container-border-width box2) 5)
- (box-pack-start main-box box2 nil nil 0)
-
- (let ((button (button-new "Insert Row")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked #'insert-row-clist :object clist))
-
- (let ((button (button-new "Add 1,000 Rows With Pixmaps")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (multiple-value-bind (pixmap mask)
- (gdk:pixmap-create gtk-mini-xpm)
- (let ((texts (do ((i 4 (1+ i))
- (texts '(nil "Center" "Right")))
- ((= i (length titles)) (reverse texts))
- (push (format nil "Column ~D" i) texts))))
- (clist-freeze clist)
- (dotimes (i 1000)
- (let ((row
- (clist-append
- clist
- (cons (format nil "CListRow ~D" (random 1000))
- texts))))
- (clist-set-cell-pixtext
- clist row 3 "gtk+" 5 (list pixmap mask))))
- (clist-thaw clist))))))
-
- (let ((button (button-new "Add 10,000 Rows")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((texts (do ((i 3 (1+ i))
- (texts '("Center" "Right")))
- ((= i (length titles)) (reverse texts))
- (push (format nil "Column ~D" i) texts))))
- (clist-freeze clist)
- (dotimes (i 10000)
- (clist-append
- clist (cons (format nil "CListRow ~D" (random 1000)) texts)))
- (clist-thaw clist))))))
-
-
- (let ((box2 (hbox-new nil 5)))
- (setf (container-border-width box2) 5)
- (box-pack-start main-box box2 nil nil 0)
-
- (let ((button (button-new "Clear List")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (clist-clear clist))))
-
- (let ((button (button-new "Remove Selection")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (clist-freeze clist)
- (let ((selection-mode (clist-selection-mode clist)))
- (labels ((remove-selection ()
- (let ((selection (clist-selection clist)))
- (when selection
- (clist-remove clist (first selection))
- (unless (eq selection-mode :browse)
- (remove-selection))))))
- (remove-selection))
-
- (when (and
- (eq selection-mode :extended)
- (not (clist-selection clist))
- (clist-focus-row clist))
- (clist-select-row clist (clist-focus-row clist))))
- (clist-thaw clist))))
-
- (let ((button (button-new "Undo Selection")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked #'clist-undo-selection :object clist))
-
- (let ((button (button-new "Warning Test")))
- (box-pack-start box2 button t t 0)
- (signal-connect button 'clicked #'(lambda ()))))
-
-
- (let ((box2 (hbox-new nil 5)))
- (setf (container-border-width box2) 5)
- (box-pack-start main-box box2 nil nil 0)
-
- (let ((button (check-button-new "Show Title Buttons")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (if (toggle-button-active-p button)
- (clist-column-titles-show clist)
- (clist-column-titles-hide clist))))
- (setf (toggle-button-active-p button) t))
-
- (let ((button (check-button-new "Reorderable")))
- (box-pack-start box2 button nil t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (setf
- (clist-reorderable-p clist) (toggle-button-active-p button))))
- (setf (toggle-button-active-p button) t))
-
- (box-pack-start box2 (label-new "Selection Mode : ") nil t 0)
- (let ((option-menu
- (build-option-menu
- `(("Single"
- ,#'(lambda () (setf (clist-selection-mode clist) :single)))
- ("Browse"
- ,#'(lambda () (setf (clist-selection-mode clist) :browse)))
- ("Multiple"
- ,#'(lambda () (setf (clist-selection-mode clist) :multiple)))
- ("Extended"
- ,#'(lambda () (setf (clist-selection-mode clist) :extended))))
- 3)))
- (box-pack-start box2 option-menu nil t 0)))
-
- (box-pack-start main-box scrolled-window t t 0)
- (setf (clist-row-height clist) 18)
- (setf (widget-height clist) 300)
-
- (dotimes (i (length titles))
- (setf (clist-column-width clist i) 80))
-
- (setf (clist-column-auto-resize-p clist 0) t)
- (setf (clist-column-resizeable-p clist 1) nil)
- (setf (clist-column-max-width clist 2) 100)
- (setf (clist-column-min-width clist 3) 50)
- (setf (clist-selection-mode clist) :extended)
- (setf (clist-column-justification clist 1) :right)
- (setf (clist-column-justification clist 2) :center)
-
- (let ((style (style-new))
- (texts (do ((i 3 (1+ i))
- (texts '("Center" "Right")))
- ((= i (length titles)) (reverse texts))
- (push (format nil "Column ~D" i) texts))))
- (setf
- (style-font style) "-adobe-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*"
- (style-fg style :normal) '#(56000 0 0)
- (style-base style :normal) '#(0 56000 32000))
-
- (dotimes (i 10)
- (clist-append clist (cons (format nil "CListRow ~D" i) texts))
- (if (= (mod i 4) 2)
- (setf (clist-row-style clist i) style)
- (setf (clist-cell-style clist i (mod i 4)) style))))))
+(define-simple-dialog create-check-buttons (dialog "Check Buttons")
+ (make-instance 'v-box
+ :border-width 10 :spacing 10 :parent dialog
+ :children (loop
+ for n from 1 to 3
+ collect (make-instance 'check-button
+ :label (format nil "Button~D" n)))))
;;; Color selection
-(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))))
+(define-dialog create-color-selection (dialog "Color selection dialog"
+ 'color-selection-dialog
+ :allow-grow nil :allow-shrink nil
+ :show-children nil)
+ (with-slots (colorsel) dialog
+ (let ((button (make-instance 'check-button :label "Show Opacity")))
+ (dialog-add-action-widget dialog button
+ #'(lambda ()
+ (setf
+ (color-selection-has-opacity-control-p colorsel)
+ (toggle-button-active-p button)))))
+
+ (let ((button (make-instance 'check-button :label "Show Palette")))
+ (dialog-add-action-widget dialog button
+ #'(lambda ()
+ (setf
+ (color-selection-has-palette-p colorsel)
+ (toggle-button-active-p button)))))
+
+ (signal-connect dialog :ok
+ #'(lambda ()
+ (let ((color (color-selection-current-color colorsel)))
+ (format t "Selected color: ~A~%" color)
+ (setf (color-selection-current-color colorsel) color)
+ (widget-hide dialog))))
+ (signal-connect dialog :cancel #'widget-destroy :object t)))
-;;; Cursors
+;;; Cursors (Note: using the drawing function in Gdk is considered
+;;; deprecated in clg, new code should use Cairo instead)
(defun clamp (n min-val max-val)
(declare (number n min-val max-val))
(defun set-cursor (spinner drawing-area label)
(let ((cursor
- (gforeign:int-enum
+ (gffi: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)))
-
-
-(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 : "))
- (adj (adjustment-new 0 0 152 2 10 0))
- (spinner (spin-button-new adj 0 0)))
- (setf (container-border-width hbox) 5)
- (box-pack-start main-box hbox nil t 0)
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack-start hbox label nil t 0)
- (box-pack-start hbox spinner t t 0)
-
- (let ((frame (make-frame
- :shadow-type :etched-in
- :label-xalign 0.5
- :label "Cursor Area"
- :border-width 10
- :parent main-box
- :visible t))
- (drawing-area (drawing-area-new)))
- (setf (widget-width drawing-area) 80)
- (setf (widget-height drawing-area) 80)
- (container-add frame drawing-area)
- (signal-connect
- drawing-area 'expose-event
- #'(lambda (event)
- (declare (ignore event))
- (multiple-value-bind (width height)
- (drawing-area-size drawing-area)
- (let* ((drawable (widget-window drawing-area))
- (style (widget-style drawing-area))
- (white-gc (style-get-gc style :white))
- (gray-gc (style-get-gc style :background :normal))
- (black-gc (style-get-gc style :black)))
- (gdk:draw-rectangle
- drawable white-gc t 0 0 width (floor height 2))
- (gdk:draw-rectangle
- drawable black-gc t 0 (floor height 2) width (floor height 2))
- (gdk:draw-rectangle
- drawable gray-gc t (floor width 3) (floor height 3)
- (floor width 3) (floor height 3))))
- t))
- (setf (widget-events drawing-area) '(:exposure :button-press))
- (signal-connect
- drawing-area 'button-press-event
- #'(lambda (event)
- (when (and
- (eq (gdk:event-type event) :button-press)
- (or
- (= (gdk:event-button event) 1)
- (= (gdk:event-button event) 3)))
- (spin-button-spin
- spinner
- (if (= (gdk:event-button event) 1)
- :step-forward
- :step-backward)
- 0)
- t)))
- (widget-show drawing-area)
-
- (let ((label (make-label
- :visible t
- :label "XXX"
- :parent main-box)))
- (setf (box-child-expand-p #|main-box|# label) nil)
- (signal-connect
- spinner 'changed
- #'(lambda ()
- (set-cursor spinner drawing-area label)))
-
- (widget-realize drawing-area)
- (set-cursor spinner drawing-area label)))))
+ 'gdk:cursor-type)))
+ (setf (label-label label) (string-downcase cursor))
+ (widget-set-cursor drawing-area cursor)))
+
+(defun cursor-expose (drawing-area event)
+ (declare (ignore event))
+ (multiple-value-bind (width height)
+ (widget-get-size-allocation drawing-area)
+ (let* ((window (widget-window drawing-area))
+ (style (widget-style drawing-area))
+ (white-gc (style-white-gc style))
+ (gray-gc (style-bg-gc style :normal))
+ (black-gc (style-black-gc style)))
+ (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
+ (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
+ (floor height 2))
+ (gdk:draw-rectangle window gray-gc t (floor width 3)
+ (floor height 3) (floor width 3)
+ (floor height 3))))
+ t)
+(define-simple-dialog create-cursors (dialog "Cursors")
+ (let ((spinner (make-instance 'spin-button
+ :adjustment (adjustment-new
+ 0 0
+ (1- (gffi:enum-int :last-cursor 'gdk:cursor-type))
+ 2 10 0)))
+ (drawing-area (make-instance 'drawing-area
+ :width-request 80 :height-request 80
+ :events '(:exposure :button-press)))
+ (label (make-instance 'label :label "XXX")))
+
+ (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
+
+ (signal-connect drawing-area 'button-press-event
+ #'(lambda (event)
+ (case (gdk:event-button event)
+ (1 (spin-button-spin spinner :step-forward))
+ (3 (spin-button-spin spinner :step-backward)))
+ t))
+
+ (signal-connect drawing-area 'scroll-event
+ #'(lambda (event)
+ (case (gdk:event-direction event)
+ (:up (spin-button-spin spinner :step-forward))
+ (:down (spin-button-spin spinner :step-backward)))
+ t))
+
+ (signal-connect spinner 'changed
+ #'(lambda ()
+ (set-cursor spinner drawing-area label)))
+
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 5
+ :child (list
+ (make-instance 'h-box
+ :border-width 5
+ :child (list
+ (make-instance 'label :label "Cursor Value : ")
+ :expand nil)
+ :child spinner)
+ :expand nil)
+ :child (make-instance 'frame
+ :label "Cursor Area" :label-xalign 0.5 :border-width 10
+ :child drawing-area)
+ :child (list label :expand nil))
+
+ (widget-realize drawing-area)
+ (set-cursor spinner drawing-area label)))
;;; Dialog
-(define-test-dialog create-dialog "Dialog"
- (setf (widget-width window) 200)
- (setf (widget-height window) 110)
-
- (let ((button (button-new "OK")))
- (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-grab-default button)
- (widget-show button))
-
- (let ((button (button-new "Toggle"))
- (label nil))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (if (not label)
- (progn
- (setq label (label-new "Dialog Test"))
- (signal-connect label 'destroy #'widget-destroy :object label)
- (setf (misc-xpad label) 10)
- (setf (misc-ypad label) 10)
- (box-pack-start main-box label t t 0)
- (widget-show label))
- (progn
- (widget-destroy label)
- (setq label nil)))))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-grab-default button)
- (widget-show button)))
+(let ((dialog nil))
+ (defun create-dialog ()
+ (unless dialog
+ (setq dialog (make-instance 'dialog
+ :title "Dialog" :default-width 200
+ :button "Toggle"
+ :button (list "gtk-ok" #'widget-destroy :object t)
+ :signal (list 'destroy
+ #'(lambda ()
+ (setq dialog nil)))))
+
+ (let ((label (make-instance 'label
+ :label "Dialog Test" :xpad 10 :ypad 10 :visible t
+ :parent dialog)))
+ (signal-connect dialog "Toggle"
+ #'(lambda ()
+ (if (widget-visible-p label)
+ (widget-hide label)
+ (widget-show label))))))
+ (if (widget-visible-p dialog)
+ (widget-hide dialog)
+ (widget-show dialog))))
;; Entry
-(define-standard-dialog create-entry "Entry"
- (setf (container-border-width main-box) 10)
- (setf (box-spacing main-box) 10)
- (let ((entry (make-instance 'entry
- :test "hello world"
- :visible t
- :parent (list main-box :fill t :expand t))))
- (entry-select-region entry 0 5)
-
- (let ((combo (make-instance 'combo
- :visible t
- :parent (list main-box :expand t :fill t))))
- (setf
- (combo-popdown-strings combo)
- '("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"))
- (editable-select-region entry 0 5))
-
- (let ((check-button (check-button-new "Editable")))
- (box-pack-start main-box check-button nil t 0)
- (signal-connect
- check-button 'toggled
- #'(lambda ()
- (setf
- (editable-editable-p entry)
- (toggle-button-active-p check-button))))
- (setf (toggle-button-active-p check-button) t)
- (widget-show check-button))
-
- (let ((check-button (check-button-new "Visible")))
- (box-pack-start main-box check-button nil t 0)
- (signal-connect
- check-button 'toggled
- #'(lambda ()
- (setf
- (entry-visible-p entry)
- (toggle-button-active-p check-button))))
- (setf (toggle-button-active-p check-button) t)
- (widget-show check-button))
-
- (let ((check-button (check-button-new "Sensitive")))
- (box-pack-start main-box check-button nil t 0)
- (signal-connect
- check-button 'toggled
- #'(lambda ()
- (setf
- (widget-sensitive-p entry)
- (toggle-button-active-p check-button))))
- (setf (toggle-button-active-p check-button) t)
- (widget-show check-button))))
-
-
-
-;; 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))))
-
-
+(define-simple-dialog create-entry (dialog "Entry")
+ (let ((main (make-instance 'v-box
+ :border-width 10 :spacing 10 :parent dialog)))
-;;; Handle box
-
-(defun create-handle-box-toolbar ()
- (let ((toolbar (toolbar-new :horizontal :both)))
- (toolbar-append-item
- toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Horizontal toolbar layout"
- :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
-
- (toolbar-append-item
- toolbar "Vertical" (pixmap-new "cl-gtk:src;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 "cl-gtk:src;test.xpm")
- :tooltip-text "Only show toolbar icons"
- :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
-
- (toolbar-append-item
- toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Only show toolbar text"
- :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
-
- (toolbar-append-item
- toolbar "Both" (pixmap-new "cl-gtk:src;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 "cl-gtk:src;test.xpm")
- :tooltip-text "Use small spaces"
- :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
-
- (toolbar-append-item
- toolbar "Big" (pixmap-new "cl-gtk:src;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 "cl-gtk:src;test.xpm")
- :tooltip-text "Enable tooltips"
- :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
-
- (toolbar-append-item
- toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Disable tooltips"
- :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Show borders"
- :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
-
- (toolbar-append-item
- toolbar "Borderless" (pixmap-new "cl-gtk:src;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 ((entry (make-instance 'entry :text "hello world" :parent main)))
+ (editable-select-region entry 0 5) ; this has no effect when
+ ; entry is editable
+;; (editable-insert-text entry "great " 6)
+;; (editable-delete-text entry 6 12)
+
+ (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
+
+#+(or cmu sbcl)
+(defun get-directory-listing (directory)
+ (let ((dir #+cmu(unix:open-dir directory)
+ #+sbcl(sb-posix:opendir directory)))
+ (unwind-protect
+ (loop
+ as filename = #+cmu(unix:read-dir dir)
+ #+sbcl(let ((dirent (sb-posix:readdir dir)))
+ (unless (sb-grovel::foreign-nullp dirent)
+ (sb-posix:dirent-name dirent)))
+ while filename
+ collect (let* ((pathname (format nil "~A~A" directory filename))
+ (directory-p
+ #+cmu(eq (unix:unix-file-kind pathname) :directory)
+ #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
+ (list filename directory-p)))
+ #+cmu(unix:close-dir dir)
+ #+sbcl(sb-posix:closedir dir))))
+
+#+clisp
+(defun get-directory-listing (directory)
+ (nconc
+ (mapcar #'(lambda (entry)
+ (let ((pathname (namestring (first entry))))
+ (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
+ (directory (format nil "~A*" directory) :full t))
+ (mapcar #'(lambda (entry)
+ (let ((pathname (namestring entry)))
+ (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
+
+ (directory (format nil "~A*/" directory)))))
+
+
+#?(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"clg:examples;gnome-fs-regular.png")
+ folder-pixbuf (gdk:pixbuf-load #p"clg:examples;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 :ok #'widget-destroy :object t))
+ (return-from load-pixbufs nil))))
+ t)
+
+ (defun fill-store (store directory)
+ (list-store-clear store)
+ (loop
+ for (filename directory-p) in (get-directory-listing directory)
+ unless (or (string= filename ".") (string= filename ".."))
+ do (list-store-insert store 0
+ (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 'filename
+ :pixbuf-column '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))))))
- (container-add vbox (label-new "Above"))
- (container-add vbox (hseparator-new))
- (let ((hbox (hbox-new nil 10)))
- (container-add vbox hbox)
-
- (let ((handle-box (handle-box-new)))
- (box-pack-start hbox handle-box nil nil 0)
- (signal-connect
- handle-box 'child-attached
- #'(lambda (child)
- (handle-box-child-signal handle-box child "attached")))
- (signal-connect
- handle-box 'child-detached
- #'(lambda (child)
- (handle-box-child-signal handle-box child "detached")))
- (container-add handle-box (create-handle-box-toolbar)))
-
- (let ((handle-box (handle-box-new)))
- (box-pack-start hbox handle-box nil nil 0)
- (signal-connect
- handle-box 'child-attached
- #'(lambda (child)
- (handle-box-child-signal handle-box child "attached")))
- (signal-connect
- handle-box 'child-detached
- #'(lambda (child)
- (handle-box-child-signal handle-box child "detached")))
-
- (let ((handle-box2 (handle-box-new)))
- (container-add handle-box handle-box2)
- (signal-connect
- handle-box2 'child-attached
- #'(lambda (child)
- (handle-box-child-signal handle-box child "attached")))
- (signal-connect
- handle-box2 'child-detached
- #'(lambda (child)
- (handle-box-child-signal handle-box child "detached")))
- (container-add handle-box2 (label-new "Foo!")))))
-
- (container-add vbox (hseparator-new))
- (container-add vbox (label-new "Below"))))
+;;; Image
+(define-toplevel create-image (window "Image" :resizable nil)
+ (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
;;; Labels
-(define-test-window create-labels "Labels"
- (setf (container-border-width window) 5)
- (let ((hbox (hbox-new nil 5)))
- (container-add window hbox)
- (let ((vbox (vbox-new nil 5)))
- (box-pack-start hbox vbox nil nil 0)
-
- (let ((frame (frame-new "Normal Label")))
- (container-add frame (label-new "This is a Normal label"))
- (box-pack-start vbox frame nil nil 0))
-
- (let ((frame (frame-new "Multi-line Label")))
- (container-add frame (label-new
+(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
+ (flet ((create-label-in-frame (frame-label label-text &rest args)
+ (make-instance 'frame
+ :label frame-label
+ :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
+ (make-instance 'h-box
+ :spacing 5 :parent window
+ :child-args '(:fill nil :expand nil)
+ :child (make-instance 'v-box
+ :spacing 5 :child-args '(:fill nil :expand nil)
+ :child (create-label-in-frame "Normal Label" "This is a Normal label")
+ :child (create-label-in-frame "Multi-line Label"
"This is a Multi-line label.
Second line
-Third line"))
- (box-pack-start vbox frame nil nil 0))
-
- (let ((frame (frame-new "Left Justified Label"))
- (label (label-new
+Third line")
+ :child (create-label-in-frame "Left Justified Label"
"This is a Left-Justified
Multi-line.
-Third line")))
- (setf (label-justify label) :left)
- (container-add frame label)
- (box-pack-start vbox frame nil nil 0))
-
- (let ((frame (frame-new "Right Justified Label"))
- (label (label-new
+Third line"
+ :justify :left)
+ :child (create-label-in-frame "Right Justified Label"
"This is a Right-Justified
Multi-line.
-Third line")))
- (setf (label-justify label) :right)
- (container-add frame label)
- (box-pack-start vbox frame nil nil 0)))
-
- (let ((vbox (vbox-new nil 5)))
- (box-pack-start hbox vbox nil nil 0)
-
- (let ((frame (frame-new "Line wrapped label"))
- (label (label-new
+Third line"
+ :justify :right))
+ :child (make-instance 'v-box
+ :spacing 5 :child-args '(:fill nil :expand nil)
+ :child (create-label-in-frame "Line wrapped label"
"This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.
- It supports multiple paragraphs correctly, and correctly adds many extra spaces. ")))
- (setf (label-wrap-p label) t)
- (container-add frame label)
- (box-pack-start vbox frame nil nil 0))
-
- (let ((frame (frame-new "Filled, wrapped label"))
- (label (label-new
+ It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
+ :wrap t)
+
+ :child (create-label-in-frame "Filled, wrapped label"
"This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a seneance to prove my point. Here is another sentence. Here comes the sun, do de do de do.
This is a new paragraph.
- This is another newer, longer, better paragraph. It is coming to an end, unfortunately.")))
- (setf (label-justify label) :fill)
- (setf (label-wrap-p label) t)
- (container-add frame label)
- (box-pack-start vbox frame nil nil 0))
-
- (let ((frame (frame-new "Underlined label"))
- (label (label-new
+ This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
+ :justify :fill :wrap t)
+
+ :child (create-label-in-frame "Underlined label"
"This label is underlined!
-This one is underlined in ÆüËܸì¤ÎÆþÍÑquite a funky fashion")))
- (setf (label-justify label) :left)
- (setf (label-pattern label) "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")
- (container-add frame label)
- (box-pack-start vbox frame nil nil 0)))))
-
-
-
-;;; Layout
-
-(defun layout-expose-handler (layout event)
- (multiple-value-bind (x-offset y-offset)
- (layout-offset layout)
- (declare (fixnum x-offset y-offset))
- (multiple-value-bind (area-x area-y area-width area-height)
- (gdk:event-area event)
- (declare (fixnum area-x area-y area-width area-height))
- (let ((imin (truncate (+ x-offset area-x) 10))
- (imax (truncate (+ x-offset area-x area-width 9) 10))
- (jmin (truncate (+ y-offset area-y) 10))
- (jmax (truncate (+ y-offset area-y area-height 9) 10)))
- (declare (fixnum imin imax jmin jmax))
- (gdk:window-clear-area
- (widget-window layout) area-x area-y area-width area-height)
+This one is underlined in quite a funky fashion"
+ :justify :left
+ :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
- (let ((window (layout-bin-window layout))
- (gc (style-get-gc (widget-style layout) :black)))
- (do ((i imin (1+ i)))
- ((= i imax))
- (declare (fixnum i))
- (do ((j jmin (1+ j)))
- ((= j jmax))
- (declare (fixnum j))
- (unless (zerop (mod (+ i j) 2))
- (gdk:draw-rectangle
- window gc t
- (- (* 10 i) x-offset) (- (* 10 j) y-offset)
- (1+ (mod i 10)) (1+ (mod j 10))))))))))
- t)
+;;; Layout (Note: using the drawing function in Gdk is considered
+;;; deprecated in clg, new code should use Cairo instead)
-(define-test-window create-layout "Layout"
- (setf (widget-width window) 200)
- (setf (widget-height window) 200)
- (let ((scrolled (scrolled-window-new))
- (layout (layout-new)))
- (container-add window scrolled)
- (container-add scrolled layout)
- (setf (adjustment-step-increment (layout-hadjustment layout)) 10.0)
- (setf (adjustment-step-increment (layout-vadjustment layout)) 10.0)
- (setf (widget-events layout) '(:exposure))
- (signal-connect layout 'expose-event #'layout-expose-handler :object t)
- (setf (layout-size layout) '#(1600 128000))
+(defun layout-expose (layout event)
+ (when (eq (gdk:event-window event) (layout-bin-window layout))
+ (with-slots (gdk:x gdk:y gdk:width gdk:height) event
+ (let ((imin (truncate gdk:x 10))
+ (imax (truncate (+ gdk:x gdk:width 9) 10))
+ (jmin (truncate gdk:y 10))
+ (jmax (truncate (+ gdk:y gdk:height 9) 10)))
+
+ (let ((window (layout-bin-window layout))
+ (gc (style-black-gc (widget-style layout))))
+ (loop
+ for i from imin below imax
+ do (loop
+ for j from jmin below jmax
+ unless (zerop (mod (+ i j) 2))
+ do (gdk:draw-rectangle
+ window gc t (* 10 i) (* 10 j)
+ (1+ (mod i 10)) (1+ (mod j 10)))))))))
+ nil)
+
+(define-toplevel create-layout (window "Layout" :default-width 200
+ :default-height 200)
+ (let ((layout (make-instance 'layout
+ :parent (make-instance 'scrolled-window :parent window)
+ :width 1600 :height 128000 :events '(:exposure)
+ :signal (list 'expose-event #'layout-expose :object t))))
+
+ (with-slots (hadjustment vadjustment) layout
+ (setf
+ (adjustment-step-increment hadjustment) 10.0
+ (adjustment-step-increment vadjustment) 10.0))
(dotimes (i 16)
(dotimes (j 16)
- (let* ((text (format nil "Button ~D, ~D" i j))
- (button (if (not (zerop (mod (+ i j) 2)))
- (button-new text)
- (label-new text))))
- (layout-put layout button (* j 100) (* i 100)))))
-
- (do ((i 16 (1+ i)))
- ((= i 1280))
- (declare (fixnum i))
- (let* ((text (format nil "Button ~D, ~D" i 0))
- (button (if (not (zerop (mod i 2)))
- (button-new text)
- (label-new text))))
- (layout-put layout button 0 (* i 100))))))
-
+ (let ((text (format nil "Button ~D, ~D" i j)))
+ (layout-put layout
+ (make-instance (if (not (zerop (mod (+ i j) 2)))
+ 'button
+ 'label)
+ :label text :visible t)
+ (* j 100) (* i 100)))))
+
+ (loop
+ for i from 16 below 1280
+ do (let ((text (format nil "Button ~D, ~D" i 0)))
+ (layout-put layout
+ (make-instance (if (not (zerop (mod i 2)))
+ 'button
+ 'label)
+ :label text :visible t)
+ 0 (* i 100))))))
+
;;; 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))
+(define-simple-dialog create-list (dialog "List" :default-height 400)
+ (let* ((store (make-instance 'list-store
+ :column-types '(string integer boolean)
+ :column-names '(:foo :bar :baz)
+ :initial-content '(#("First" 12321 nil)
+ (:foo "Yeah" :baz t))))
+ (tree (make-instance 'tree-view :model store)))
+
+ (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))
- (with-open-file (file "cl-gtk:src;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))))
-
- (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
- (build-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)))))
-
+ (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 (tree-model-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 (tree-model-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 (tree-model-column-index store :baz))
+ (tree-view-append-column tree column))
+
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10
+ :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
(defun create-menu (depth tearoff)
(unless (zerop depth)
- (let ((menu (menu-new)))
+ (let ((menu (make-instance 'menu)))
(when tearoff
- (let ((menuitem (tearoff-menu-item-new)))
- (menu-append menu menuitem)
- (widget-show menuitem)
- ))
+ (let ((menu-item (make-instance 'tearoff-menu-item)))
+ (menu-shell-append menu menu-item)))
(let ((group nil))
(dotimes (i 5)
- (let ((menuitem
- (radio-menu-item-new
- group (format nil "item ~2D - ~D" depth (1+ i)))))
- (setq group (radio-menu-item-group menuitem)) ; ough!
+ (let ((menu-item
+ (make-instance 'radio-menu-item
+ :label (format nil "item ~2D - ~D" depth (1+ i)))))
+ (if group
+ (add-to-radio-group menu-item group)
+ (setq group menu-item))
(unless (zerop (mod depth 2))
- (setf (check-menu-item-toggle-indicator-p menuitem) t))
- (menu-append menu menuitem)
- (widget-show menuitem)
+ (setf (check-menu-item-active-p menu-item) t))
+ (menu-shell-append menu menu-item)
(when (= i 3)
- (setf (widget-sensitive-p menuitem) nil))
- (setf (menu-item-submenu menuitem) (create-menu (1- depth) t)))))
- menu)))
-
-
-(define-standard-dialog create-menus "Menus"
- (setf (box-spacing main-box) 0)
- (setf (container-border-width main-box) 0)
- (widget-show main-box)
- (let ((accel-group (accel-group-new))
- (menubar (menu-bar-new)))
- (accel-group-attach accel-group window)
- (box-pack-start main-box menubar nil t 0)
- (widget-show menubar)
-
- (let ((menuitem (menu-item-new (format nil "test~%line2"))))
- (setf (menu-item-submenu menuitem) (create-menu 2 t))
- (menu-bar-append menubar menuitem)
- (widget-show menuitem))
-
- (let ((menuitem (menu-item-new "foo")))
- (setf (menu-item-submenu menuitem) (create-menu 3 t))
- (menu-bar-append menubar menuitem)
- (widget-show menuitem))
-
- (let ((menuitem (menu-item-new "bar")))
- (setf (menu-item-submenu menuitem) (create-menu 4 t))
- (menu-item-right-justify menuitem)
- (menu-bar-append menubar menuitem)
- (widget-show menuitem))
-
- (let ((box2 (vbox-new nil 10))
- (menu (create-menu 1 nil)))
- (setf (container-border-width box2) 10)
- (box-pack-start main-box box2 t t 0)
- (widget-show box2)
+ (setf (widget-sensitive-p menu-item) nil))
+ (let ((submenu (create-menu (1- depth) t)))
+ (when submenu
+ (setf (menu-item-submenu menu-item) submenu))))))
+ menu)))
+
+
+(define-simple-dialog create-menus (dialog "Menus" :default-width 200)
+ (let* ((main (make-instance 'v-box :parent dialog))
+; (accel-group (make-instance 'accel-group))
+ (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
+; (window-add-accel-group dialog accel-group)
+
+ (let ((menu-item (make-instance 'menu-item
+ :label (format nil "test~%line2"))))
+ (setf (menu-item-submenu menu-item) (create-menu 2 t))
+ (menu-shell-append menubar menu-item))
+
+ (let ((menu-item (make-instance 'menu-item :label "foo")))
+ (setf (menu-item-submenu menu-item) (create-menu 3 t))
+ (menu-shell-append menubar menu-item))
+
+ (let ((menu-item (make-instance 'menu-item :label "bar")))
+ (setf (menu-item-submenu menu-item) (create-menu 4 t))
+ (setf (menu-item-right-justified-p menu-item) t)
+ (menu-shell-append menubar menu-item))
+
+ (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 ((menuitem (check-menu-item-new "Accelerate Me")))
- (menu-append menu menuitem)
- (widget-show menuitem)
- (widget-add-accelerator
- menuitem 'activate accel-group "F1" 0 '(:visible :signal-visible)))
-
- (let ((menuitem (check-menu-item-new "Accelerator Locked")))
- (menu-append menu menuitem)
- (widget-show menuitem)
- (widget-add-accelerator
- menuitem 'activate accel-group "F2" 0 '(:visible :locked)))
-
- (let ((menuitem (check-menu-item-new "Accelerator Frozen")))
- (menu-append menu menuitem)
- (widget-show menuitem)
- (widget-add-accelerator
- menuitem 'activate accel-group "F2" 0 '(:visible))
- (widget-add-accelerator
- menuitem 'activate accel-group "F3" 0 '(:visible))
- (widget-lock-accelerators menuitem))
-
- (let ((optionmenu (option-menu-new)))
- (setf (option-menu-menu optionmenu) menu)
- (setf (option-menu-history optionmenu) 3)
- (box-pack-start box2 optionmenu t t 0)
- (widget-show optionmenu)))))
+ (widget-show-all main)))
;;; Notebook
-(define-standard-dialog create-notebook "Notebook"
- (multiple-value-bind (book-open book-open-mask)
- (gdk:pixmap-create book-open-xpm)
- (multiple-value-bind (book-closed book-closed-mask)
- (gdk:pixmap-create book-closed-xpm)
-
- (labels
- ((create-pages (notebook i end)
- (when (<= i end)
- (let* ((title (format nil "Page ~D" i))
- (child (frame-new title))
- (vbox (vbox-new t 0))
- (hbox (hbox-new t 0)))
- (setf (container-border-width child) 10)
- (setf (container-border-width vbox) 10)
- (container-add child vbox)
- (box-pack-start vbox hbox nil t 5)
-
- (let ((button (check-button-new "Fill Tab")))
- (box-pack-start hbox button t t 5)
- (setf (toggle-button-active-p button) t)
- (signal-connect
- button 'toggled
- #'(lambda ()
- (multiple-value-bind (expand fill pack-type)
- (notebook-query-tab-label-packing notebook child)
- (declare (ignore fill))
- (notebook-set-tab-label-packing
- notebook child expand
- (toggle-button-active-p button) pack-type)))))
-
- (let ((button (check-button-new "Expand Tab")))
- (box-pack-start hbox button t t 5)
- (signal-connect
- button 'toggled
- #'(lambda ()
- (multiple-value-bind (expand fill pack-type)
- (notebook-query-tab-label-packing notebook child)
- (declare (ignore expand))
- (notebook-set-tab-label-packing
- notebook child (toggle-button-active-p button)
- fill pack-type)))))
-
- (let ((button (check-button-new "Pack end")))
- (box-pack-start hbox button t t 5)
- (signal-connect
- button 'toggled
- #'(lambda ()
- (multiple-value-bind (expand fill pack-type)
- (notebook-query-tab-label-packing notebook child)
- (declare (ignore pack-type))
- (notebook-set-tab-label-packing
- notebook child expand fill
- (if (toggle-button-active-p button)
- :end
- :start))))))
-
- (let ((button (button-new "Hide Page")))
- (box-pack-start vbox button nil nil 5)
- (signal-connect
- button 'clicked #'(lambda () (widget-hide child))))
-
- (widget-show-all child)
-
- (let ((label-box (hbox-new nil 0))
- (menu-box (hbox-new nil 0)))
- (box-pack-start
- label-box (pixmap-new (list book-closed book-closed-mask))
- nil t 0)
- (box-pack-start label-box (label-new title) nil t 0)
- (widget-show-all label-box)
- (box-pack-start
- menu-box (pixmap-new (list book-closed book-closed-mask))
- nil t 0)
- (box-pack-start menu-box (label-new title) nil t 0)
- (widget-show-all menu-box)
- (notebook-append-page notebook child label-box menu-box)))
-
- (create-pages notebook (1+ i) end))))
-
-
- (setf (container-border-width main-box) 0)
- (setf (box-spacing main-box) 0)
-
- (let ((notebook (notebook-new)))
- (signal-connect
- notebook 'switch-page
- #'(lambda (pointer page)
- (declare (ignore pointer))
- (let ((old-page (notebook-current-page-num notebook)))
- (unless (eq page old-page)
- (setf
- (pixmap-pixmap
- (first
- (container-children
- (notebook-tab-label notebook page))))
- (list book-open book-open-mask))
- (setf
- (pixmap-pixmap
- (first
- (container-children
- (notebook-menu-label notebook page))))
- (list book-open book-open-mask))
-
- (when old-page
- (setf
- (pixmap-pixmap
- (first
- (container-children
- (notebook-tab-label notebook old-page))))
- (list book-closed book-closed-mask))
- (setf
- (pixmap-pixmap
- (first
- (container-children
- (notebook-menu-label notebook old-page))))
- (list book-closed book-closed-mask)))))))
-
- (setf (notebook-tab-pos notebook) :top)
- (box-pack-start main-box notebook t t 0)
- (setf (container-border-width notebook) 10)
-
- (widget-realize notebook)
- (create-pages notebook 1 5)
+(defun create-notebook-page (notebook page-num book-closed)
+ (let* ((title (format nil "Page ~D" page-num))
+ (page (make-instance 'frame :label title :border-width 10))
+ (v-box (make-instance 'v-box
+ :homogeneous t :border-width 10 :parent page)))
+
+ (make-instance 'h-box
+ :parent (list v-box :fill nil :padding 5) :homogeneous t
+ :child-args '(:padding 5)
+ :child (make-instance 'check-button
+ :label "Fill Tab" :active t
+ :signal (list 'toggled
+ #'(lambda (button)
+ (setf
+ (notebook-child-tab-fill-p page)
+ (toggle-button-active-p button)))
+ :object t))
+ :child (make-instance 'check-button
+ :label "Expand Tab"
+ :signal (list 'toggled
+ #'(lambda (button)
+ (setf
+ (notebook-child-tab-expand-p page)
+ (toggle-button-active-p button)))
+ :object t))
+ :child (make-instance 'check-button
+ :label "Pack end"
+ :signal (list 'toggled
+ #'(lambda (button)
+ (setf
+ (notebook-child-tab-pack page)
+ (if (toggle-button-active-p button)
+ :end
+ :start)))
+ :object t))
+ :child (make-instance 'button
+ :label "Hide page"
+ :signal (list 'clicked #'(lambda () (widget-hide page)))))
+
+
+ (let ((label-box (make-instance 'h-box
+ :show-children t
+ :child-args '(:expand nil)
+ :child (make-instance 'image :pixbuf book-closed)
+ :child (make-instance 'label :label title)))
+ (menu-box (make-instance 'h-box
+ :show-children t
+ :child-args '(:expand nil)
+ :child (make-instance 'image :pixbuf book-closed)
+ :child (make-instance 'label :label title))))
+
+ (notebook-append notebook page label-box menu-box))))
- (box-pack-start main-box (hseparator-new) nil t 10)
-
- (let ((box2 (hbox-new nil 5)))
- (setf (container-border-width box2) 10)
- (box-pack-start main-box box2 nil t 0)
-
- (let ((button (check-button-new "popup menu")))
- (box-pack-start box2 button t nil 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (if (toggle-button-active-p button)
- (notebook-popup-enable notebook)
- (notebook-popup-disable notebook)))))
-
- (let ((button (check-button-new "homogeneous tabs")))
- (box-pack-start box2 button t nil 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (setf
- (notebook-homogeneous-p notebook)
- (toggle-button-active-p button))))))
+(define-simple-dialog create-notebook (dialog "Notebook")
+ (let ((main (make-instance 'v-box :parent dialog)))
+ (let ((book-open (make-instance 'gdk:pixbuf :source book-open-xpm))
+ (book-closed (make-instance 'gdk:pixbuf :source book-closed-xpm))
+ (notebook (make-instance 'notebook
+ :border-width 10 :tab-pos :top :parent main)))
+
+ (flet ((set-image (page func pixbuf)
+ (setf
+ (image-pixbuf
+ (first (container-children (funcall func notebook page))))
+ pixbuf)))
+ (signal-connect notebook 'switch-page
+ #'(lambda (pointer page)
+ (declare (ignore pointer))
+ (set-image page #'notebook-menu-label book-open)
+ (set-image page #'notebook-tab-label book-open)
+ (when (slot-boundp notebook 'current-page)
+ (let ((curpage (notebook-current-page notebook)))
+ (set-image curpage #'notebook-menu-label book-closed)
+ (set-image curpage #'notebook-tab-label book-closed))))))
+ (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
+
+ (make-instance 'h-separator :parent (list main :expand nil :padding 10))
- (let ((box2 (hbox-new nil 5)))
- (setf (container-border-width box2) 10)
- (box-pack-start main-box box2 nil t 0)
-
- (box-pack-start box2 (label-new "Notebook Style : ") nil t 0)
-
- (let* ((scrollable-p nil)
- (option-menu
- (build-option-menu
- `(("Standard"
- ,#'(lambda ()
- (setf (notebook-show-tabs-p notebook) t)
- (when scrollable-p
- (setq scrollable-p nil)
- (setf (notebook-scrollable-p notebook) nil)
- (dotimes (n 10)
- (notebook-remove-page notebook 5)))))
- ("No tabs"
- ,#'(lambda ()
- (setf (notebook-show-tabs-p notebook) nil)
- (when scrollable-p
- (setq scrollable-p nil)
- (setf (notebook-scrollable-p notebook) nil)
- (dotimes (n 10)
- (notebook-remove-page notebook 5)))))
- ("Scrollable"
- ,#'(lambda ()
- (unless scrollable-p
- (setq scrollable-p t)
- (setf (notebook-show-tabs-p notebook) t)
- (setf (notebook-scrollable-p notebook) t)
- (create-pages notebook 6 15)))))
- 0)))
- (box-pack-start box2 option-menu nil t 0))
-
- (let ((button (button-new "Show all Pages")))
- (box-pack-start box2 button nil t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (container-foreach notebook #'widget-show)))))
-
- (let ((box2 (hbox-new nil 5)))
- (setf (container-border-width box2) 10)
- (box-pack-start main-box box2 nil t 0)
-
- (let ((button (button-new "prev")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (notebook-prev-page notebook))))
-
- (let ((button (button-new "next")))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (notebook-next-page notebook))))
-
- (let ((button (button-new "rotate"))
- (tab-pos 2))
- (box-pack-start box2 button t t 0)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (setq tab-pos (mod (1+ tab-pos) 4))
- (setf (notebook-tab-pos notebook) tab-pos))))))))))
+ (make-instance 'h-box
+ :spacing 5 :border-width 10
+ :parent (list main :expand nil)
+ :child-args '(:fill nil)
+ :child (make-instance 'check-button
+ :label "Popup menu"
+ :signal (list 'clicked
+ #'(lambda (button)
+ (if (toggle-button-active-p button)
+ (notebook-popup-enable notebook)
+ (notebook-popup-disable notebook)))
+ :object t))
+ :child (make-instance 'check-button
+ :label "Homogeneous tabs"
+ :signal (list 'clicked
+ #'(lambda (button)
+ (setf
+ (notebook-homogeneous-p notebook)
+ (toggle-button-active-p button)))
+ :object t)))
+
+ (make-instance 'h-box
+ :spacing 5 :border-width 10
+ :parent (list main :expand nil)
+ :child-args '(:expand nil)
+ :child (make-instance 'label :label "Notebook Style: ")
+ :child (let ((scrollable-p nil))
+ (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 book-closed))))))
+ :object t)))
+ :child (make-instance 'button
+ :label "Show all Pages"
+ :signal (list 'clicked
+ #'(lambda ()
+ (map-container nil #'widget-show notebook)))))
+
+ (make-instance 'h-box
+ :spacing 5 :border-width 10
+ :parent (list main :expand nil)
+ :child (make-instance 'button
+ :label "Prev"
+ :signal (list 'clicked #'notebook-prev-page :object notebook))
+ :child (make-instance 'button
+ :label "Next"
+ :signal (list 'clicked #'notebook-next-page :object notebook))
+ :child (make-instance 'button
+ :label "Rotate"
+ :signal (let ((tab-pos 0))
+ (list 'clicked
+ #'(lambda ()
+ (setq tab-pos (mod (1+ tab-pos) 4))
+ (setf
+ (notebook-tab-pos notebook)
+ (svref #(:top :right :bottom :left) tab-pos))))))))
+ (widget-show-all main)))
;;; Panes
(defun toggle-resize (child)
- (let* ((paned (widget-parent child))
- (is-child1-p (eq child (paned-child1 paned))))
- (multiple-value-bind (child resize shrink)
- (if is-child1-p
- (paned-child1 paned)
- (paned-child2 paned))
- (widget-ref child)
- (container-remove paned child)
- (if is-child1-p
- (paned-pack1 paned child (not resize) shrink)
- (paned-pack2 paned child (not resize) shrink))
- (widget-unref child))))
+ (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
(defun toggle-shrink (child)
- (let* ((paned (widget-parent child))
- (is-child1-p (eq child (paned-child1 paned))))
- (multiple-value-bind (child resize shrink)
- (if is-child1-p
- (paned-child1 paned)
- (paned-child2 paned))
- (widget-ref child)
- (container-remove paned child)
- (if is-child1-p
- (paned-pack1 paned child resize (not shrink))
- (paned-pack2 paned child resize (not shrink)))
- (widget-unref child))))
+ (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
(defun create-pane-options (paned frame-label label1 label2)
- (let ((frame (frame-new frame-label))
- (table (table-new 3 2 t)))
- (setf (container-border-width frame) 4)
- (container-add frame table)
-
- (table-attach table (label-new label1) 0 1 0 1)
-
- (let ((check-button (check-button-new "Resize")))
- (table-attach table check-button 0 1 1 2)
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
-
- (let ((check-button (check-button-new "Shrink")))
- (table-attach table check-button 0 1 2 3)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
-
- (table-attach table (label-new label2) 1 2 0 1)
-
- (let ((check-button (check-button-new "Resize")))
- (table-attach table check-button 1 2 1 2)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
-
- (let ((check-button (check-button-new "Shrink")))
- (table-attach table check-button 1 2 2 3)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
-
- frame))
-
-(define-test-window create-panes "Panes"
- (let ((vbox (vbox-new nil 0))
- (vpaned (vpaned-new))
- (hpaned (hpaned-new)))
- (container-add window vbox)
- (box-pack-start vbox vpaned t t 0)
- (setf (container-border-width vpaned) 5)
-
- (paned-add1 vpaned hpaned)
-
- (let ((frame (frame-new nil)))
- (setf (frame-shadow-type frame) :in)
- (setf (widget-width frame) 60)
- (setf (widget-height frame) 60)
- (paned-add1 hpaned frame)
- (container-add frame (button-new "Hi there")))
-
- (let ((frame (frame-new nil)))
- (setf (frame-shadow-type frame) :in)
- (setf (widget-width frame) 80)
- (setf (widget-height frame) 60)
- (paned-add2 hpaned frame))
-
- (let ((frame (frame-new nil)))
- (setf (frame-shadow-type frame) :in)
- (setf (widget-width frame) 80)
- (setf (widget-height frame) 60)
- (paned-add2 vpaned frame))
-
- ;; Now create toggle buttons to control sizing
-
- (box-pack-start
- vbox (create-pane-options hpaned "Horizontal" "Left" "Right") nil nil 0)
-
- (box-pack-start
- vbox (create-pane-options vpaned "Vertical" "Top" "Bottom") nil nil 0)))
+ (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
+ (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
+ (let ((check-button (make-instance 'check-button :label "Resize")))
+ (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-resize :object (paned-child1 paned)))
+ (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
+ (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-shrink :object (paned-child1 paned)))
+
+ (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
+ (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
+ (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-resize :object (paned-child2 paned)))
+ (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
+ (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-shrink :object (paned-child2 paned)))
+ (make-instance 'frame :label frame-label :border-width 4 :child table)))
+
+(define-toplevel create-panes (window "Panes")
+ (let* ((hpaned (make-instance 'h-paned
+ :child1 (make-instance 'frame
+ :width-request 60 :height-request 60
+ :shadow-type :in
+ :child (make-instance 'button :label "Hi there"))
+ :child2 (make-instance 'frame
+ :width-request 80 :height-request 60
+ :shadow-type :in)))
+ (vpaned (make-instance 'v-paned
+ :border-width 5
+ :child1 hpaned
+ :child2 (make-instance 'frame
+ :width-request 80 :height-request 60
+ :shadow-type :in))))
+
+ (make-instance 'v-box
+ :parent window
+ :child-args '(:expand nil)
+ :child (list vpaned :expand t)
+ :child (create-pane-options hpaned "Horizontal" "Left" "Right")
+ :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
-
-;;; Pixmap
-
-(define-standard-dialog create-pixmap "Pixmap"
- (setf (container-border-width main-box) 10)
- (let* ((button (button-new))
- (hbox (hbox-new nil 0)))
- (box-pack-start main-box button nil nil 0)
- (container-add button hbox)
- (setf (container-border-width hbox) 2)
- (container-add hbox (pixmap-new "cl-gtk:src;test.xpm"))
- (container-add hbox (label-new "Pixmap test"))))
-
-
-
;;; Progress bar
-(define-standard-dialog create-progress-bar "Progress bar"
- (setf (window-allow-grow-p window) nil)
- (setf (window-allow-shrink-p window) nil)
- (setf (window-auto-shrink-p window) t)
-
- (setf (container-border-width main-box) 10)
+(define-simple-dialog create-progress-bar (dialog "Progress Bar")
+ (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
+ (activity-mode-button (make-instance 'check-button
+ :label "Activity mode"))
+ (timer (timeout-add 100
+ #'(lambda ()
+ (if (toggle-button-active-p activity-mode-button)
+ (progress-bar-pulse progress)
+ (let ((fract (+ (progress-bar-fraction progress) 0.01)))
+ (setf
+ (progress-bar-fraction progress)
+ (if (> fract 1.0)
+ 0.0
+ fract))))
+ t))))
- (let* ((pbar-adj (adjustment-new 0 1 300 0 0 0))
- (pbar (progress-bar-new pbar-adj))
- (user-label (label-new "")))
-
- (let ((frame (frame-new "Progress"))
- (vbox (vbox-new nil 5)))
- (box-pack-start main-box frame nil t 0)
- (container-add frame vbox)
-
- (let ((timer (timeout-add
- 100
- #'(lambda ()
- (let* ((value (adjustment-value pbar-adj))
- (new-value
- (if (= value (adjustment-upper pbar-adj))
- (adjustment-lower pbar-adj)
- (1+ value))))
- (setf (progress-value pbar) new-value))
- t))))
- (signal-connect window 'destroy #'(lambda () (timeout-remove timer))))
-
- (signal-connect
- pbar-adj 'value-changed
- #'(lambda ()
- (setf
- (label-text user-label)
- (if (progress-activity-mode-p pbar)
- "???"
- (format nil "~D" (round (* 100 (progress-percentage pbar))))))))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10
+ :child progress
+ :child activity-mode-button)
- (setf (progress-format-string pbar) "%v from [%l,%u] (=%p%%)")
-
- (let ((align (alignment-new 0.5 0.5 0.0 0.0)))
- (box-pack-start vbox align nil nil 0)
- (container-add align pbar))
-
- (let ((hbox (hbox-new nil 5)))
- (box-pack-start hbox (label-new "Label updated by user :") nil t 0)
- (box-pack-start hbox user-label nil t 0)
-
- (let ((align (alignment-new 0.5 0.5 0.0 0.0)))
- (box-pack-start vbox align nil nil 5)
- (container-add align hbox))))
-
- (let ((frame (frame-new "Options"))
- (vbox (vbox-new nil 5)))
- (box-pack-start main-box frame nil t 0)
- (container-add frame vbox)
-
- (let ((table (table-new 7 2 nil)))
- (box-pack-start vbox table nil t 0)
-
- (let ((label (label-new "Orientation :")))
- (setf (misc-xalign label) 0.0)
- (setf (misc-yalign label) 0.5)
- (table-attach table label 0 1 0 1 :x-padding 5 :y-padding 5))
-
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start
- hbox
- (build-option-menu
- `(("Left-Right"
- ,#'(lambda ()
- (setf (progress-bar-orientation pbar) :left-to-right)))
- ("Right-Left"
- ,#'(lambda ()
- (setf (progress-bar-orientation pbar) :right-to-left)))
- ("Bottom-Top"
- ,#'(lambda ()
- (setf (progress-bar-orientation pbar) :bottom-to-top)))
- ("Top-Bottom"
- ,#'(lambda ()
- (setf (progress-bar-orientation pbar) :top-to-bottom))))
- 0)
- t t 0)
- (table-attach table hbox 1 2 0 1 :x-padding 5 :y-padding 5))
-
- (let* ((button (check-button-new "Show text"))
- (entry (entry-new))
- (x-align-adj (adjustment-new 0.5 0.0 1.0 0.1 0.1 0.0))
- (x-align-spin (spin-button-new x-align-adj 0 1))
- (y-align-adj (adjustment-new 0.5 0.0 1.0 0.1 0.1 0.0))
- (y-align-spin (spin-button-new y-align-adj 0 1)))
-
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((state (toggle-button-active-p button)))
- (setf (progress-show-text-p pbar) state)
- (setf (widget-sensitive-p entry) state)
- (setf (widget-sensitive-p x-align-spin) state)
- (setf (widget-sensitive-p y-align-spin) state))))
- (table-attach table button 0 1 1 2 :x-padding 5 :y-padding 5)
-
- (signal-connect
- entry 'changed
- #'(lambda ()
- (setf
- (progress-format-string pbar)
- (entry-text entry))))
- (setf (entry-text entry) "%v from [%l,%u] (=%p%%)")
- (setf (widget-width entry) 100)
- (setf (widget-sensitive-p entry) nil)
-
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start hbox (label-new "Format : ") nil t 0)
- (box-pack-start hbox entry t t 0)
- (table-attach table hbox 1 2 1 2 :x-padding 5 :y-padding 5))
-
- (let ((label (label-new "Text align :")))
- (setf (misc-xalign label) 0.0)
- (setf (misc-yalign label) 0.5)
- (table-attach table label 0 1 2 3 :x-padding 5 :y-padding 5))
-
- (flet ((adjust-align ()
- (setf
- (progress-text-xalign pbar)
- (spin-button-value x-align-spin))
- (setf
- (progress-text-yalign pbar)
- (spin-button-value y-align-spin))))
- (signal-connect x-align-adj 'value-changed #'adjust-align)
- (signal-connect y-align-adj 'value-changed #'adjust-align))
- (setf (widget-sensitive-p x-align-spin) nil)
- (setf (widget-sensitive-p y-align-spin) nil)
-
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start hbox (label-new "x :") nil t 5)
- (box-pack-start hbox x-align-spin nil t 0)
- (box-pack-start hbox (label-new "y :") nil t 5)
- (box-pack-start hbox y-align-spin nil t 0)
- (table-attach table hbox 1 2 2 3 :x-padding 5 :y-padding 5)))
-
- (let ((label (label-new "Bar Style :")))
- (setf (misc-xalign label) 0.0)
- (setf (misc-yalign label) 0.5)
- (table-attach table label 0 1 3 4 :x-padding 5 :y-padding 5))
-
- (let* ((block-adj (adjustment-new 10 2 20 1 5 0))
- (block-spin (spin-button-new block-adj 0 0)))
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start
- hbox
- (build-option-menu
- `(("Continuous"
- ,#'(lambda ()
- (setf (progress-bar-style pbar) :continuous)
- (setf (widget-sensitive-p block-spin) nil)))
- ("Discrete"
- ,#'(lambda ()
- (setf (progress-bar-style pbar) :discrete)
- (setf (widget-sensitive-p block-spin) t))))
- 0)
- t t 0)
- (table-attach table hbox 1 2 3 4 :x-padding 5 :y-padding 5))
-
- (let ((label (label-new "Block count :")))
- (setf (misc-xalign label) 0.0)
- (setf (misc-yalign label) 0.5)
- (table-attach table label 0 1 4 5 :x-padding 5 :y-padding 5))
-
- (signal-connect
- block-adj 'value-changed
- #'(lambda ()
- (setf (progress-percentage pbar) 0)
- (setf
- (progress-bar-discrete-blocks pbar)
- (spin-button-value-as-int block-spin))))
- (setf (widget-sensitive-p block-spin) nil)
-
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start hbox block-spin nil t 0)
- (table-attach table hbox 1 2 4 5 :x-padding 5 :y-padding 5)))
-
- (let* ((step-size-adj (adjustment-new 3 1 20 1 5 0))
- (step-size-spin (spin-button-new step-size-adj 0 0))
- (block-adj (adjustment-new 5 2 10 1 5 00))
- (block-spin (spin-button-new block-adj 0 0)))
-
- (let ((button (check-button-new "Activity mode")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((state (toggle-button-active-p button)))
- (setf (progress-activity-mode-p pbar) state)
- (setf (widget-sensitive-p step-size-spin) state)
- (setf (widget-sensitive-p block-spin) state))))
- (table-attach table button 0 1 5 6 :x-padding 5 :y-padding 5))
-
- (signal-connect
- step-size-adj 'value-changed
- #'(lambda ()
- (setf
- (progress-bar-activity-step pbar)
- (spin-button-value-as-int step-size-spin))))
- (setf (widget-sensitive-p step-size-spin) nil)
-
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start hbox (label-new "Step size : ") nil t 0)
- (box-pack-start hbox step-size-spin nil t 0)
- (table-attach table hbox 1 2 5 6 :x-padding 5 :y-padding 5))
-
- (signal-connect
- block-adj 'value-changed
- #'(lambda ()
- (setf
- (progress-bar-activity-blocks pbar)
- (spin-button-value-as-int block-spin))))
- (setf (widget-sensitive-p block-spin) nil)
-
- (let ((hbox (hbox-new nil 0)))
- (box-pack-start hbox (label-new "Blocks : ") nil t 0)
- (box-pack-start hbox block-spin nil t 0)
- (table-attach table hbox 1 2 6 7 :x-padding 5 :y-padding 5)))))))
-
+ (signal-connect dialog 'destroy
+ #'(lambda () (when timer (timeout-remove timer))))))
;;; Radio buttons
-(define-standard-dialog create-radio-buttons "Radio buttons"
- (setf (container-border-width main-box) 10)
- (setf (box-spacing main-box) 10)
- (let* ((button1 (radio-button-new nil :label "button1"))
- (button2 (radio-button-new
- (radio-button-group button1) :label "button2"))
- (button3 (radio-button-new
- (radio-button-group button2) :label "button3")))
- (box-pack-start main-box button1 t t 0)
- (box-pack-start main-box button2 t t 0)
- (setf (toggle-button-active-p button2) t)
- (box-pack-start main-box button3 t t 0)))
-
+(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10
+ :children (make-radio-group 'radio-button
+ '((:label "button1") (:label "button2") (:label "button3"))
+ nil)))
;;; Rangle controls
-(define-standard-dialog create-range-controls "Range controls"
- (setf (container-border-width main-box) 10)
- (setf (box-spacing main-box) 10)
+(define-simple-dialog create-range-controls (dialog "Range controls")
(let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
-
- (let ((scale (hscale-new adjustment)))
- (setf (widget-width scale) 150)
- (setf (widget-height scale) 30)
- (setf (range-update-policy scale) :delayed)
- (setf (scale-digits scale) 1)
- (setf (scale-draw-value-p scale) t)
- (box-pack-start main-box scale t t 0))
-
- (let ((scrollbar (hscrollbar-new adjustment)))
- (setf (range-update-policy scrollbar) :continuous)
- (box-pack-start main-box scrollbar t t 0))))
-
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10
+ :child (make-instance 'h-scale
+ :width-request 150 :adjustment adjustment :inverted t
+ :update-policy :delayed :digits 1 :draw-value t)
+ :child (make-instance 'h-scrollbar
+ :adjustment adjustment :update-policy :continuous))))
;;; Reparent test
-(define-standard-dialog create-reparent "reparent"
- (let ((box2 (hbox-new nil 5))
- (label (label-new "Hellow World")))
- (setf (container-border-width box2) 10)
- (box-pack-start main-box box2 t t 0)
+(define-simple-dialog create-reparent (dialog "Reparent")
+ (let ((main (make-instance 'h-box
+ :homogeneous t :spacing 10 :border-width 10 :parent dialog))
+ (label (make-instance 'label :label "Hello World")))
- (let ((frame (frame-new "Frame 1"))
- (box3 (vbox-new nil 5))
- (button (button-new "switch")))
- (box-pack-start box2 frame t t 0)
-
- (setf (container-border-width box3) 5)
- (container-add frame box3)
-
- (signal-connect
- button 'clicked
- #'(lambda ()
- (widget-reparent label box3)))
- (box-pack-start box3 button nil t 0)
-
- (box-pack-start box3 label nil t 0)
- (signal-connect
- label 'parent-set
- #'(lambda (old-parent)
- (declare (ignore old-parent)))))
-
- (let ((frame (frame-new "Frame 2"))
- (box3 (vbox-new nil 5))
- (button (button-new "switch")))
- (box-pack-start box2 frame t t 0)
-
- (setf (container-border-width box3) 5)
- (container-add frame box3)
-
- (signal-connect
- button 'clicked
- #'(lambda ()
- (widget-reparent label box3)))
- (box-pack-start box3 button nil t 0))))
+ (flet ((create-frame (title)
+ (let* ((frame (make-instance 'frame :label title :parent main))
+ (box (make-instance 'v-box
+ :spacing 5 :border-width 5 :parent frame))
+ (button (make-instance 'button
+ :label "switch" :parent (list box :expand nil))))
+ (signal-connect button 'clicked
+ #'(lambda ()
+ (widget-reparent label box)))
+ box)))
+ (box-pack-start (create-frame "Frame 1") label nil t 0)
+ (create-frame "Frame 2"))
+ (widget-show-all main)))
;;; Rulers
-(define-test-window create-rulers "rulers"
- (setf (widget-width window) 300)
- (setf (widget-height window) 300)
- (setf (widget-events window) '(:pointer-motion :pointer-motion-hint))
-
- (let ((table (table-new 2 2 nil)))
- (container-add window table)
- (widget-show table)
-
- (let ((ruler (hruler-new)))
- (setf (ruler-metric ruler) :centimeters)
- (ruler-set-range ruler 100 0 0 20)
- (signal-connect
- window 'motion-notify-event
- #'(lambda (event) (widget-event ruler event)))
- (table-attach table ruler 1 2 0 1 :y-options '(:fill))
- (widget-show ruler))
-
- (let ((ruler (vruler-new)))
- (ruler-set-range ruler 5 15 0 20)
- (signal-connect
- window 'motion-notify-event
- #'(lambda (event) (widget-event ruler event)))
- (table-attach table ruler 0 1 1 2 :x-options '(:fill))
- (widget-show ruler))))
-
+(define-toplevel create-rulers (window "Rulers"
+ :default-width 300 :default-height 300
+ :events '(:pointer-motion :pointer-motion-hint))
+ (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
+ (h-ruler (make-instance 'h-ruler
+ :metric :centimeters :lower 100.0d0 :upper 0.0d0
+ :position 0.0d0 :max-size 20.0d0))
+ (v-ruler (make-instance 'v-ruler
+ :lower 5.0d0 :upper 15.0d0
+ :position 0.0d0 :max-size 20.0d0)))
+ (signal-connect window 'motion-notify-event
+ #'(lambda (event)
+ (widget-event h-ruler event)
+ (widget-event v-ruler event)))
+ (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
+ (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
;;; Scrolled window
-(define-standard-dialog create-scrolled-windows "Scrolled windows"
- (let ((scrolled-window (scrolled-window-new nil nil)))
- (setf (container-border-width scrolled-window) 10)
- (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
- (box-pack-start main-box scrolled-window t t 0)
+(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
+ :default-width 300
+ :default-height 300)
+ (let* ((scrolled-window
+ (make-instance 'scrolled-window
+ :parent dialog :border-width 10
+ :vscrollbar-policy :automatic
+ :hscrollbar-policy :automatic))
+ (table
+ (make-instance 'table
+ :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
+ :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
+ :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
- (let ((table (table-new 20 20 nil)))
- (setf (table-row-spacings table) 10)
- (setf (table-column-spacings table) 10)
(scrolled-window-add-with-viewport scrolled-window table)
- (setf
- (container-focus-vadjustment table)
- (scrolled-window-vadjustment scrolled-window))
- (setf
- (container-focus-hadjustment table)
- (scrolled-window-hadjustment scrolled-window))
-
(dotimes (i 20)
(dotimes (j 20)
(let ((button
- (toggle-button-new (format nil "button (~D,~D)~%" i j))))
- (table-attach table button i (1+ i) j (1+ j)))))))
-
- (let ((button (button-new "remove")))
- (signal-connect button 'clicked #'(lambda ()))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-grab-default button))
-
- (setf (window-default-height window) 300)
- (setf (window-default-width window) 300))
-
+ (make-instance 'toggle-button
+ :label (format nil "button (~D,~D)~%" i j))))
+ (table-attach table button i (1+ i) j (1+ j)))))
+ (widget-show-all scrolled-window)))
+
+
+;;; Size group
+
+(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
+ (let ((size-group (make-instance 'size-group)))
+ (flet ((create-frame (label rows)
+ (let ((table (make-instance 'table
+ :n-rows (length rows) :n-columns 2 :homogeneous nil
+ :row-spacing 5 :column-spacing 10 :border-width 5)))
+ (loop
+ for row in rows
+ for i from 0
+ do (table-attach table
+ (create-label (first row) :xalign 0 :yalign 1)
+ 0 1 i (1+ i) :x-options '(:expand :fill))
+ (let ((combo (make-instance 'combo-box
+ :content (rest row) :active 0)))
+ (size-group-add-widget size-group combo)
+ (table-attach table combo 1 2 i (1+ i))))
+ (make-instance 'frame :label label :child table))))
+
+ (make-instance 'v-box
+ :parent dialog :border-width 5 :spacing 5
+ :child (create-frame "Color Options"
+ '(("Foreground" "Red" "Green" "Blue")
+ ("Background" "Red" "Green" "Blue")))
+ :child (create-frame "Line Options"
+ '(("Dashing" "Solid" "Dashed" "Dotted")
+ ("Line ends" "Square" "Round" "Arrow")))
+ :child (create-check-button "Enable grouping"
+ #'(lambda (active)
+ (setf
+ (size-group-mode size-group)
+ (if active :horizontal :none)))
+ t)))))
;;; Shapes
-(defun shape-create-icon (xpm-file x y px py window-type root-window)
- (let ((window (window-new window-type))
- (fixed (fixed-new)))
- (setf (widget-width fixed) 100)
- (setf (widget-height fixed) 100)
- (container-add window fixed)
- (widget-show fixed)
-
- (setf
- (widget-events window)
- (append
- (widget-events window)
- '(:button-motion :pointer-motion-hint :button-press)))
+(defun create-shape-icon (xpm-file x y px py type root-window destroy)
+ (let ((window
+ (make-instance 'window
+ :type type :default-width 100 :default-height 100
+ :events '(:button-motion :pointer-motion-hint :button-press)
+ :signal (list 'destroy destroy))))
+
(widget-realize window)
-
- (multiple-value-bind (gdk-pixmap gdk-pixmap-mask)
- (gdk:pixmap-create xpm-file)
- (let ((pixmap (pixmap-new (list gdk-pixmap gdk-pixmap-mask)))
- (x-offset 0)
- (y-offset 0))
- (declare (fixnum x-offset y-offset))
- (fixed-put fixed pixmap px py)
- (widget-show pixmap)
- (widget-shape-combine-mask window gdk-pixmap-mask px py)
- (signal-connect
- window 'button-press-event
- #'(lambda (event)
- (when (eq (gdk:event-type event) :button-press)
- (setq x-offset (truncate (gdk:event-x event)))
- (setq y-offset (truncate (gdk:event-y event)))
- (grab-add window)
- (gdk:pointer-grab
- (widget-window window) t
- '(:button-release :button-motion :pointer-motion-hint)
- nil nil 0))
- t))
-
- (signal-connect
- window 'button-release-event
- #'(lambda (event)
- (declare (ignore event))
- (grab-remove window)
- (gdk:pointer-ungrab 0)
- t))
+ (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
+ (let ((fixed (make-instance 'fixed :parent window)))
+ (fixed-put fixed (create-image-widget source mask) px py))
+ (widget-shape-combine-mask window mask px py))
- (signal-connect
- window 'motion-notify-event
- #'(lambda (event)
- (declare (ignore event))
- (multiple-value-bind (win xp yp mask)
- (gdk:window-get-pointer root-window)
- (declare (ignore mask win) (fixnum xp yp))
- (widget-set-uposition
- window :x (- xp x-offset) :y (- yp y-offset)))
- t))))
+ (let ((x-offset 0)
+ (y-offset 0))
+ (declare (fixnum x-offset y-offset))
+ (signal-connect window 'button-press-event
+ #'(lambda (event)
+ (when (typep event 'gdk:button-press-event)
+ (setq x-offset (truncate (gdk:event-x event)))
+ (setq y-offset (truncate (gdk:event-y event)))
+ (grab-add window)
+ (gdk:pointer-grab (widget-window window)
+ :events '(:button-release :button-motion :pointer-motion-hint)
+ :owner-events t))))
+
+ (signal-connect window 'button-release-event
+ #'(lambda (event)
+ (declare (ignore event))
+ (grab-remove window)
+ (gdk:pointer-ungrab)))
+
+ (signal-connect window 'motion-notify-event
+ #'(lambda (event)
+ (declare (ignore event))
+ (multiple-value-bind (win xp yp mask)
+ (gdk:window-get-pointer root-window)
+ (declare (ignore mask win) (fixnum xp yp))
+ (window-move window (- xp x-offset) (- yp y-offset))))))
- (widget-set-uposition window :x x :y y)
- (widget-show window)
+ (window-move window x y)
+ (widget-show-all window)
window))
(defun create-shapes ()
(let ((root-window (gdk:get-root-window)))
(if (not modeller)
- (progn
- (setq
- modeller
- (shape-create-icon
- "cl-gtk:src;Modeller.xpm"
- 440 140 0 0 :popup root-window))
- (signal-connect
- modeller 'destroy
- #'(lambda () (widget-destroyed modeller))))
+ (setq
+ modeller
+ (create-shape-icon
+ "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
+ #'(lambda () (setq modeller nil))))
(widget-destroy modeller))
(if (not sheets)
- (progn
- (setq
- sheets
- (shape-create-icon
- "cl-gtk:src;FilesQueue.xpm"
- 580 170 0 0 :popup root-window))
- (signal-connect
- sheets 'destroy
- #'(lambda () (widget-destroyed sheets))))
+ (setq
+ sheets
+ (create-shape-icon
+ "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
+ #'(lambda () (setq sheets nil))))
(widget-destroy sheets))
(if (not rings)
- (progn
- (setq
- rings
- (shape-create-icon
- "cl-gtk:src;3DRings.xpm"
- 460 270 25 25 :toplevel root-window))
- (signal-connect
- rings 'destroy
- #'(lambda () (widget-destroyed rings))))
+ (setq
+ rings
+ (create-shape-icon
+ "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
+ #'(lambda () (setq rings nil))))
(widget-destroy rings)))))
;;; Spin buttons
-(define-test-window create-spins "Spin buttons"
- (let ((main-vbox (vbox-new nil 5)))
- (setf (container-border-width main-vbox) 10)
- (container-add window main-vbox)
-
- (let ((frame (frame-new "Not accelerated"))
- (vbox (vbox-new nil 0))
- (hbox (hbox-new nil 0)))
- (box-pack-start main-vbox frame t t 0)
- (setf (container-border-width vbox) 5)
- (container-add frame vbox)
- (box-pack-start vbox hbox t t 5)
-
- (let* ((vbox2 (vbox-new nil 0))
- (label (label-new "Day :"))
- (spinner (spin-button-new
- (adjustment-new 1 1 31 1 5 0) 0 0)))
- (box-pack-start hbox vbox2 t t 5)
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack-start vbox2 label nil t 0)
- (setf (spin-button-wrap-p spinner) t)
- (setf (spin-button-shadow-type spinner) :out)
- (box-pack-start vbox2 spinner nil t 0))
-
- (let* ((vbox2 (vbox-new nil 0))
- (label (label-new "Month :"))
- (spinner (spin-button-new
- (adjustment-new 1 1 12 1 5 0) 0 0)))
- (box-pack-start hbox vbox2 t t 5)
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack-start vbox2 label nil t 0)
- (setf (spin-button-wrap-p spinner) t)
- (setf (spin-button-shadow-type spinner) :etched-in)
- (box-pack-start vbox2 spinner nil t 0))
-
- (let* ((vbox2 (vbox-new nil 0))
- (label (label-new "Year :"))
- (spinner (spin-button-new
- (adjustment-new 1998 0 2100 1 100 0) 0 0)))
- (box-pack-start hbox vbox2 t t 5)
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack-start vbox2 label nil t 0)
- (setf (spin-button-wrap-p spinner) t)
- (setf (spin-button-shadow-type spinner) :in)
- (box-pack-start vbox2 spinner nil t 0)))
-
- (let* ((frame (frame-new "Accelerated"))
- (vbox (vbox-new nil 0))
- (hbox (hbox-new nil 0))
- (spinner1 (spin-button-new
- (adjustment-new 0 -10000 10000 0.5 100 0) 1.0 2))
- (adj (adjustment-new 2 1 5 1 1 0))
- (spinner2 (spin-button-new adj 1.0 0)))
-
- (box-pack-start main-vbox frame t t 0)
- (setf (container-border-width vbox) 5)
- (container-add frame vbox)
- (box-pack-start vbox hbox nil t 5)
-
- (let* ((vbox2 (vbox-new nil 0))
- (label (label-new "Value :")))
- (box-pack-start hbox vbox2 t t 5)
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack-start vbox2 label nil t 0)
- (setf (spin-button-wrap-p spinner1) t)
- (setf (widget-width spinner1) 100)
- (setf (widget-height spinner1) 0)
- (box-pack-start vbox2 spinner1 nil t 0))
-
- (let* ((vbox2 (vbox-new nil 0))
- (label (label-new "Digits :")))
- (box-pack-start hbox vbox2 t t 5)
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack-start vbox2 label nil t 0)
- (setf (spin-button-wrap-p spinner2) t)
- (signal-connect adj 'value-changed
- #'(lambda ()
- (setf
- (spin-button-digits spinner1)
- (floor (spin-button-value spinner2)))))
- (box-pack-start vbox2 spinner2 nil t 0))
-
- (let ((button (check-button-new "Snap to 0.5-ticks")))
- (signal-connect button 'clicked
- #'(lambda ()
- (setf
- (spin-button-snap-to-ticks-p spinner1)
- (toggle-button-active-p button))))
- (box-pack-start vbox button t t 0)
- (setf (toggle-button-active-p button) t))
-
- (let ((button (check-button-new "Numeric only input mode")))
- (signal-connect button 'clicked
- #'(lambda ()
- (setf
- (spin-button-numeric-p spinner1)
- (toggle-button-active-p button))))
- (box-pack-start vbox button t t 0)
- (setf (toggle-button-active-p button) t))
-
- (let ((val-label (label-new "0"))
- (hbox (hbox-new nil 0)))
- (box-pack-start vbox hbox nil t 5)
- (let ((button (button-new "Value as Int")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (setf
- (label-text val-label)
- (format nil "~D" (spin-button-value-as-int spinner1)))))
- (box-pack-start hbox button t t 5))
-
- (let ((button (button-new "Value as Float")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (setf
- (label-text val-label)
- (format nil
- (format nil "~~,~DF" (spin-button-digits spinner1))
- (spin-button-value spinner1)))))
- (box-pack-start hbox button t t 5))
-
- (box-pack-start vbox val-label t t 0)))
-
- (let ((hbox (hbox-new nil 0))
- (button (button-new "Close")))
- (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
- (box-pack-start main-vbox hbox nil t 0)
- (box-pack-start hbox button t t 5))))
-
+(define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
+ (let ((main (make-instance 'v-box
+ :spacing 5 :border-width 10 :parent dialog)))
+
+ (flet ((create-date-spinner (label adjustment shadow-type)
+ (declare (ignore shadow-type))
+ (make-instance 'v-box
+ :child-args '(:expand nil)
+ :child (make-instance 'label
+ :label label :xalign 0.0 :yalign 0.5)
+ :child (make-instance 'spin-button
+ :adjustment adjustment :wrap t))))
+ (multiple-value-bind (sec min hour date month year day daylight-p zone)
+ (get-decoded-time)
+ (declare (ignore sec min hour day daylight-p zone))
+ (make-instance 'frame
+ :label "Not accelerated" :parent main
+ :child (make-instance 'h-box
+ :border-width 10
+ :child-args '(:padding 5)
+ :child (create-date-spinner "Day : "
+ (adjustment-new date 1 31 1 5 0) :out)
+ :child (create-date-spinner "Month : "
+ (adjustment-new month 1 12 1 5 0) :etched-in)
+ :child (create-date-spinner "Year : "
+ (adjustment-new year 0 2100 1 100 0) :in)))))
+
+ (let ((spinner1 (make-instance 'spin-button
+ :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
+ :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
+ (spinner2 (make-instance 'spin-button
+ :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
+ :climb-rate 1.0 :wrap t))
+ (value-label (make-instance 'label :label "0")))
+ (signal-connect (spin-button-adjustment spinner2) 'value-changed
+ #'(lambda ()
+ (setf
+ (spin-button-digits spinner1)
+ (floor (spin-button-value spinner2)))))
+
+ (make-instance 'frame
+ :label "Accelerated" :parent main
+ :child (make-instance 'v-box
+ :border-width 5
+ :child (list
+ (make-instance 'h-box
+ :child-args '(:padding 5)
+ :child (make-instance 'v-box
+ :child (make-instance 'label
+ :label "Value :"
+ :xalign 0.0 :yalign 0.5)
+ :child spinner1)
+ :child (make-instance 'v-box
+ :child (make-instance 'label
+ :label "Digits :"
+ :xalign 0.0 :yalign 0.5)
+ :child spinner2))
+ :expand nil :padding 5)
+ :child (make-instance 'check-button
+ :label "Snap to 0.5-ticks" :active t
+ :signal (list 'clicked
+ #'(lambda (button)
+ (setf
+ (spin-button-snap-to-ticks-p spinner1)
+ (toggle-button-active-p button)))
+ :object t))
+ :child (make-instance 'check-button
+ :label "Numeric only input mode" :active t
+ :signal (list 'clicked
+ #'(lambda (button)
+ (setf
+ (spin-button-numeric-p spinner1)
+ (toggle-button-active-p button)))
+ :object t))
+ :child value-label
+ :child (list
+ (make-instance 'h-box
+ :child-args '(:padding 5)
+ :child (make-instance 'button
+ :label "Value as Int"
+ :signal (list 'clicked
+ #'(lambda ()
+ (setf
+ (label-label value-label)
+ (format nil "~D"
+ (spin-button-value-as-int
+ spinner1))))))
+ :child (make-instance 'button
+ :label "Value as Float"
+ :signal (list 'clicked
+ #'(lambda ()
+ (setf
+ (label-label value-label)
+ (format nil
+ (format nil "~~,~DF"
+ (spin-button-digits spinner1))
+ (spin-button-value spinner1)))))))
+ :padding 5 :expand nil))))
+ (widget-show-all main)))
;;; Statusbar
-(define-test-window create-statusbar "Statusbar"
- (let ((box1 (vbox-new nil 0)))
- (container-add window box1)
-
- (let ((box2 (vbox-new nil 10))
- (statusbar (statusbar-new))
- (statusbar-counter 0))
- (setf (container-border-width box2) 10)
- (box-pack-start box1 box2 t t 0)
- (box-pack-end box1 statusbar t t 0)
- (signal-connect
- statusbar 'text-popped
- #'(lambda (context-id text)
- (declare (ignore context-id))
- (format nil "Popped: ~A~%" text)))
-
- (make-button
- :label "push something"
- :visible t
- :parent box2
- :signal (list
- 'clicked
- #'(lambda ()
- (statusbar-push
- statusbar
- 1
- (format nil "something ~D" (incf statusbar-counter))))))
-
- (make-button
- :label "pop"
- :visible t
- :parent box2
- :signal (list
- 'clicked
- #'(lambda ()
- (statusbar-pop statusbar 1))
- :after t))
-
- (make-button
- :label "steal #4"
- :visible t
- :parent box2
- :signal (list
- 'clicked
- #'(lambda ()
- (statusbar-remove statusbar 1 4))
- :after t))
-
- (make-button :label "test contexts"
- :visible t
- :parent box2
- :signal (list 'clicked #'(lambda ()))))
-
- (box-pack-start box1 (hseparator-new) nil t 0)
-
- (let ((box2 (vbox-new nil 10)))
- (setf (container-border-width box2) 10)
- (box-pack-start box1 box2 nil t 0)
-
- (let ((button (button-new "close")))
- (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
- (box-pack-start box2 button t t 0)
- (setf (widget-can-default-p button) t)
- (widget-grab-default button)))))
-
+(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
-(define-standard-dialog create-idle-test "Idle Test"
- (let ((label (label-new "count: 0"))
+(define-simple-dialog create-idle-test (dialog "Idle Test")
+ (let ((label (make-instance 'label
+ :label "count: 0" :xpad 10 :ypad 10))
(idle nil)
(count 0))
- (declare (fixnum count))
- (signal-connect
- window 'destroy #'(lambda () (when idle (idle-remove idle))))
+ (signal-connect dialog 'destroy
+ #'(lambda () (when idle (idle-remove idle))))
- (setf (misc-xpad label) 10)
- (setf (misc-ypad label) 10)
- (box-pack-start main-box label t t 0)
-
- (let* ((container (make-hbox :parent main-box :child label :visible t))
- (frame (make-frame
- :border-width 5
- :label "Label Container"
- :visible t
- :parent main-box))
- (box (make-vbox :visible t :parent frame)))
- (make-check-button
- :label "Resize-Parent"
- :visible t
- :parent box
- :signal
- (list
- 'clicked
- #'(lambda ()
- (setf (container-resize-mode container) :parent))))
-
- (make-check-button
- :label "Resize-Queue"
- :visible t
- :parent box
- :signal
- (list
- 'clicked
- #'(lambda ()
- (setf (container-resize-mode container) :queue))))
-
- (make-check-button
- :label "Resize-Immediate"
- :visible t
- :parent box
- :signal
- (list
- 'clicked
- #'(lambda ()
- (setf (container-resize-mode container) :immediate)))))
-
- (let ((button (button-new "start")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (unless idle
- (setq
- idle
- (idle-add
- #'(lambda ()
- (incf count)
- (setf (label-text label) (format nil "count: ~D" count))
- t))))))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-show button))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10
+ :child label
+ :child (make-instance 'frame
+ :label "Label Container" :border-width 5
+ :child(make-instance 'v-box
+ :children (make-radio-group 'radio-button
+ '((:label "Resize-Parent" :value :parent :active t)
+ (:label "Resize-Queue" :value :queue)
+ (:label "Resize-Immediate" :value :immediate))
+ #'(lambda (mode)
+ (setf
+ (container-resize-mode (dialog-action-area dialog)) mode))))))
+
+ (dialog-add-button dialog "Start"
+ #'(lambda ()
+ (unless idle
+ (setq idle
+ (idle-add
+ #'(lambda ()
+ (incf count)
+ (setf (label-label label) (format nil "count: ~D" count))
+ t))))))
- (let ((button (button-new "stop")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (when idle
- (idle-remove idle)
- (setq idle nil))))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-show button))))
+ (dialog-add-button dialog "Stop"
+ #'(lambda ()
+ (when idle
+ (idle-remove idle)
+ (setq idle nil))))))
;;; Timeout test
-(define-standard-dialog create-timeout-test "Timeout Test"
- (let ((label (label-new "count: 0"))
+(define-simple-dialog create-timeout-test (dialog "Timeout Test")
+ (let ((label (make-instance 'label
+ :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
(timer nil)
(count 0))
- (declare (fixnum count))
- (signal-connect
- window 'destroy #'(lambda () (when timer (timeout-remove timer))))
-
- (setf (misc-xpad label) 10)
- (setf (misc-ypad label) 10)
- (box-pack-start main-box label t t 0)
- (widget-show label)
-
- (let ((button (button-new "start")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (unless timer
- (setq
- timer
- (timeout-add
- 100
- #'(lambda ()
- (incf count)
- (setf (label-text label) (format nil "count: ~D" count))
- t))))))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-show button))
-
- (let ((button (button-new "stop")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (when timer
- (timeout-remove timer)
- (setq timer nil))))
- (setf (widget-can-default-p button) t)
- (box-pack-start action-area button t t 0)
- (widget-show button))))
-
+ (signal-connect dialog 'destroy
+ #'(lambda () (when timer (timeout-remove timer))))
+
+ (dialog-add-button dialog "Start"
+ #'(lambda ()
+ (unless timer
+ (setq timer
+ (timeout-add 100
+ #'(lambda ()
+ (incf count)
+ (setf (label-label label) (format nil "count: ~D" count))
+ t))))))
+
+ (dialog-add-button dialog "Stop"
+ #'(lambda ()
+ (when timer
+ (timeout-remove timer)
+ (setq timer nil))))))
;;; Text
-(define-test-window create-text "Text"
- (setf (widget-name window) "text window")
- (setf (widget-width window) 500)
- (setf (widget-height window) 500)
- (setf (window-allow-grow-p window) t)
- (setf (window-allow-shrink-p window) t)
- (setf (window-auto-shrink-p window) nil)
- (let ((box1 (vbox-new nil 0)))
- (container-add window box1)
+(define-simple-dialog create-text (dialog "Text" :default-width 400
+ :default-height 400)
+ (let* ((text-view (make-instance 'text-view
+ :border-width 10 :visible t :wrap-mode :word))
+ (buffer (text-view-buffer text-view))
+ (active-tags ()))
+
+ (text-buffer-create-tag buffer "Bold" :weight :bold)
+ (text-buffer-create-tag buffer "Italic" :style :italic)
+ (text-buffer-create-tag buffer "Underline" :underline :single)
- (let ((box2 (vbox-new nil 10)))
- (setf (container-border-width box2) 10)
- (box-pack-start box1 box2 t t 0)
-
- (let ((scrolled-window (scrolled-window-new))
- (text (text-new)))
- (box-pack-start box2 scrolled-window t t 0)
- (setf (scrolled-window-hscrollbar-policy scrolled-window) :never)
- (setf (scrolled-window-vscrollbar-policy scrolled-window) :always)
- (setf (editable-editable-p text) t)
- (container-add scrolled-window text)
- (widget-grab-focus text)
+ (flet ((create-toggle-callback (tag-name)
+ (let ((tag (text-tag-table-lookup
+ (text-buffer-tag-table buffer) tag-name)))
+ #'(lambda (active)
+ (unless (eq (and (find tag active-tags) t) active)
+ ;; user activated
+ (if active
+ (push tag active-tags)
+ (setq active-tags (delete tag active-tags)))
+ (multiple-value-bind (non-zero-p start end)
+ (text-buffer-get-selection-bounds buffer)
+ (declare (ignore non-zero-p))
+ (if active
+ (text-buffer-apply-tag buffer tag start end)
+ (text-buffer-remove-tag buffer tag start end))))))))
+
+ (let* ((actions
+ (make-instance 'action-group
+ :action (make-instance 'toggle-action
+ :name "Bold" :stock-id "gtk-bold" :label "Bold"
+ :accelerator "<control>B" :tooltip "Bold"
+ :callback (create-toggle-callback "Bold"))
+ :action (make-instance 'toggle-action
+ :name "Italic" :stock-id "gtk-italic" :label "Italic"
+ :accelerator "<control>I" :tooltip "Italic"
+ :callback (create-toggle-callback "Italic"))
+ :action (make-instance 'toggle-action
+ :name "Underline" :stock-id "gtk-underline"
+ :label "Underline" :accelerator "<control>U"
+ :tooltip "Underline"
+ :callback (create-toggle-callback "Underline"))))
+ (ui (make-instance 'ui-manager
+ :action-group actions
+ :ui '((:toolbar "ToolBar"
+ (:toolitem "Bold")
+ (:toolitem "Italic")
+ (:toolitem "Underline"))))))
+
+ ;; Callback to activate/deactivate toolbar buttons when cursor
+ ;; is moved
+ (signal-connect buffer 'mark-set
+ #'(lambda (location mark)
+ (declare (ignore mark))
+ (text-tag-table-foreach (text-buffer-tag-table buffer)
+ #'(lambda (tag)
+ (let ((active
+ (or
+ (and
+ (text-iter-has-tag-p location tag)
+ (not (text-iter-begins-tag-p location tag)))
+ (text-iter-ends-tag-p location tag))))
+ (unless (eq active (and (find tag active-tags) t))
+ (if active
+ (push tag active-tags)
+ (setq active-tags (delete tag active-tags)))
+ (setf
+ (toggle-action-active-p
+ (action-group-get-action actions (text-tag-name tag)))
+ active)))))))
+
+ ;; Callback to apply active tags when a character is inserted
+ (signal-connect buffer 'insert-text
+ #'(lambda (iter &rest args)
+ (declare (ignore args))
+ (let ((before (text-buffer-get-iter-at-offset buffer
+ (1- (text-iter-offset iter)))))
+ (loop
+ for tag in active-tags
+ do (text-buffer-apply-tag buffer tag before iter))))
+ :after t)
- (text-freeze text)
- (let ((font
- (gdk:font-load
- "-adobe-courier-medium-r-normal--*-120-*-*-*-*-*-*"))
- (colors
- (map 'list
- #'(lambda (definition)
- (cons
- (gdk:color-new-from-vector (first definition))
- (second definition)))
- '((#(#x0000 #x0000 #x0000) "black")
- (#(#xFFFF #xFFFF #xFFFF) "white")
- (#(#xFFFF #x0000 #x0000) "red")
- (#(#x0000 #xFFFF #x0000) "green")
- (#(#x0000 #x0000 #xFFFF) "blue")
- (#(#x0000 #xFFFF #xFFFF) "cyan")
- (#(#xFFFF #x0000 #xFFFF) "magneta")
- (#(#xFFFF #xFFFF #x0000) "yellow")))))
- (dolist (color1 colors)
- (text-insert text (format nil "~A~,7T" (cdr color1)) :font font)
- (dolist (color2 colors)
- (text-insert
- text "XYZ" :font font
- :foreground (car color2) :background (car color1)))
- (text-insert text (format nil "~%")))
- (dolist (color colors)
- (gdk:color-destroy (car color)))
- (gdk:font-unref font))
-
- (with-open-file (file "cl-gtk:src;testgtk.lisp")
- (labels ((read-file ()
- (let ((line (read-line file nil nil)))
- (when line
- (text-insert text (format nil "~A~%" line))
- (read-file)))))
- (read-file)))
-
- (text-thaw text)
-
- (let ((hbox (hbutton-box-new)))
- (box-pack-start box2 hbox nil nil 0)
- (let ((check-button (check-button-new "Editable")))
- (box-pack-start hbox check-button nil nil 0)
- (signal-connect
- check-button 'toggled
- #'(lambda ()
- (setf
- (editable-editable-p text)
- (toggle-button-active-p check-button))))
- (setf (toggle-button-active-p check-button) t))
-
- (let ((check-button (check-button-new "Wrap Words")))
- (box-pack-start hbox check-button nil t 0)
- (signal-connect
- check-button 'toggled
+ (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
+ (container-add dialog text-view)
+
+ (let ((position (make-instance 'label :visible t)))
+ (flet ((update-position (line column)
+ (setf
+ (label-label position)
+ (format nil "Cursor Position: ~d,~d" (1+ line) column))))
+ (update-position 0 0)
+
+ ;; Callback to display current position when cursor is moved
+ (signal-connect buffer 'mark-set
+ #'(lambda (iter mark)
+ (when (and
+ (slot-boundp mark 'name)
+ (string= (text-mark-name mark) "insert"))
+ (update-position
+ (text-iter-line iter) (text-iter-line-offset iter)))))
+
+ ;; Callback to display current position after the
+ ;; buffer has been modified
+ (signal-connect buffer 'changed
#'(lambda ()
- (setf
- (text-word-wrap-p text)
- (toggle-button-active-p check-button))))
- (setf (toggle-button-active-p check-button) nil)))))
+ (let ((iter (text-buffer-get-iter-at-insert buffer)))
+ (update-position
+ (text-iter-line iter) (text-iter-line-offset iter))))
+ :after t))
- (box-pack-start box1 (hseparator-new) nil t 0)
-
- (let ((box2 (vbox-new nil 10)))
- (setf (container-border-width box2) 10)
- (box-pack-start box1 box2 nil t 0)
-
- (let ((button (button-new "insert random")))
- (signal-connect button 'clicked #'(lambda () nil))
- (box-pack-start box2 button t t 0))
-
- (let ((button (button-new "close")))
- (signal-connect
- button 'clicked
- #'(lambda ()
- (widget-destroy window)
- (setq window nil)))
- (box-pack-start box2 button t t 0)
- (setf (widget-can-default-p button) t)
- (widget-grab-default button)))))
-
+ (container-add dialog position :expand nil))))))
;;; Toggle buttons
-(define-standard-dialog create-toggle-buttons "Toggle Button"
- (setf (container-border-width main-box) 10)
- (setf (box-spacing main-box) 10)
- (box-pack main-box (toggle-button-new "button1"))
- (box-pack main-box (toggle-button-new "button2"))
- (box-pack main-box (toggle-button-new "button3")))
+(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
+ (make-instance 'v-box
+ :border-width 10 :spacing 10 :parent dialog
+ :children (loop
+ for n from 1 to 3
+ collect (make-instance 'toggle-button
+ :label (format nil "Button~D" (1+ n))))))
;;; Toolbar test
-(define-test-window create-toolbar "Toolbar test"
- (setf (window-allow-grow-p window) nil)
- (setf (window-allow-shrink-p window) t)
- (setf (window-auto-shrink-p window) t)
- (widget-realize window)
-
-
- (let ((toolbar (toolbar-new :horizontal :both)))
- (setf (toolbar-relief toolbar) :none)
-
- (toolbar-append-item
- toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Horizontal toolbar layout"
- :tooltip-private-text "Toolbar/Horizontal"
- :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
-
- (toolbar-append-item
- toolbar "Vertical" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Vertical toolbar layout"
- :tooltip-private-text "Toolbar/Vertical"
- :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Icons" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Only show toolbar icons"
- :tooltip-private-text "Toolbar/IconsOnly"
- :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
-
- (toolbar-append-item
- toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Only show toolbar text"
- :tooltip-private-text "Toolbar/TextOnly"
- :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
-
- (toolbar-append-item
- toolbar "Both" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Show toolbar icons and text"
- :tooltip-private-text "Toolbar/Both"
- :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-widget
- toolbar (entry-new)
- :tooltip-text "This is an unusable GtkEntry ;)"
- :tooltip-private-text "Hey don't click me!")
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Small" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Use small spaces"
- :tooltip-private-text "Toolbar/Small"
- :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
-
- (toolbar-append-item
- toolbar "Big" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Use big spaces"
- :tooltip-private-text "Toolbar/Big"
- :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
-
- (toolbar-append-space toolbar)
+(defun create-toolbar (window)
+ (make-instance 'toolbar
+ :show-tooltips t :show-arrow nil
+
+ ;; Insert a stock item
+ :child (make-instance 'tool-button
+ :stock "gtk-quit"
+ :tip-text "Destroy toolbar"
+ :tip-private "Toolbar/Quit"
+ :signal (list 'clicked #'(lambda () (widget-destroy window))))
+
+ :child (make-instance 'separator-tool-item)
+
+ :child (make-instance 'tool-button
+ :label "Horizontal" :stock "gtk-go-forward"
+ :tip-text "Horizontal toolbar layout"
+ :tip-private "Toolbar/Horizontal"
+ :signal (list 'clicked
+ #'(lambda (toolbar)
+ (setf (toolbar-orientation toolbar) :horizontal))
+ :object :parent))
+
+ :child (make-instance 'tool-button
+ :label "Vertical" :stock "gtk-go-down"
+ :tip-text "Vertical toolbar layout"
+ :tip-private "Toolbar/Vertical"
+ :signal (list 'clicked
+ #'(lambda (toolbar)
+ (setf (toolbar-orientation toolbar) :vertical))
+ :object :parent))
+
+ :child (make-instance 'separator-tool-item)
+
+ :children (make-radio-group 'radio-tool-button
+ '((:label "Icons" :stock "gtk-justify-left"
+ :tip-text "Only show toolbar icons"
+ :tip-private "Toolbar/IconsOnly"
+ :value :icons)
+ (:label "Both" :stock "gtk-justify-center"
+ :tip-text "Show toolbar icons and text"
+ :tip-private "Toolbar/Both"
+ :value :both :active t)
+ (:label "Text" :stock "gtk-justify-right"
+ :tip-text "Show toolbar text"
+ :tip-private "Toolbar/TextOnly"
+ :value :text))
+ (list
+ #'(lambda (toolbar style)
+ (setf (toolbar-style toolbar) style))
+ :object :parent))
+
+ :child (make-instance 'separator-tool-item)
+
+ :child (make-instance 'tool-item
+ :child (make-instance 'entry)
+ :tip-text "This is an unusable GtkEntry"
+ :tip-private "Hey don't click me!")
+
+ :child (make-instance 'separator-tool-item)
+
+ :child (make-instance 'tool-button
+ :label "Enable" :stock "gtk-add"
+ :tip-text "Enable tooltips"
+ :tip-private "Toolbar/EnableTooltips"
+ :signal (list 'clicked
+ #'(lambda (toolbar)
+ (setf (toolbar-show-tooltips-p toolbar) t))
+ :object :parent))
+
+ :child (make-instance 'tool-button
+ :label "Disable" :stock "gtk-remove"
+ :tip-text "Disable tooltips"
+ :tip-private "Toolbar/DisableTooltips"
+ :signal (list 'clicked
+ #'(lambda (toolbar)
+ (setf (toolbar-show-tooltips-p toolbar) nil))
+ :object :parent))
+
+;; :child (make-instance 'separator-tool-item)
+
+;; :child (make-instance 'tool-button
+;; :label "GTK" :icon #p"clg:examples;gtk.png"
+;; :tip-text "GTK+ Logo"
+;; :tip-private "Toolbar/GTK+")
+ ))
+
+(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
+ (container-add window (create-toolbar window)))
- (toolbar-append-item
- toolbar "Enable" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Enable tooltips"
- :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
- (toolbar-append-item
- toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Disable tooltips"
- :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
-
- (toolbar-append-space toolbar)
+;;; Handle box
- (toolbar-append-item
- toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Show borders"
- :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
-
- (toolbar-append-item
- toolbar
- "Borderless" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Hide borders"
- :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
-
- (toolbar-append-space toolbar)
-
- (toolbar-append-item
- toolbar "Empty" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Empty spaces"
- :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
-
- (toolbar-append-item
- toolbar "Lines" (pixmap-new "cl-gtk:src;test.xpm")
- :tooltip-text "Lines in spaces"
- :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
-
- (container-add window toolbar)))
-
-
-
-;;; Tooltips test
-
-(define-standard-dialog create-tooltips "Tooltips"
- (setf (window-allow-grow-p window) t)
- (setf (window-allow-shrink-p window) nil)
- (setf (window-auto-shrink-p window) t)
- (setf (widget-width window) 200)
- (setf (container-border-width main-box) 10)
- (setf (box-spacing main-box) 10)
-
- (let ((tooltips (tooltips-new)))
-
- (let ((button (toggle-button-new "button1")))
- (box-pack-start main-box button t t 0)
- (tooltips-set-tip
- tooltips button "This is button 1" "ContextHelp/button/1"))
-
- (let ((button (toggle-button-new "button2")))
- (box-pack-start main-box button t t 0)
- (tooltips-set-tip
- tooltips button "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly."
- "ContextHelp/button/2"))
-
- (let ((toggle (toggle-button-new "Override TipSQuery Label")))
- (box-pack-start main-box toggle t t 0)
- (tooltips-set-tip
- tooltips toggle "Toggle TipsQuery view" "Hi msw! ;)")
-
- (let* ((box3 (make-vbox
- :homogeneous nil
- :spacing 5
- :border-width 5
- :visible t))
- (tips-query (make-tips-query
- :visible t
- :parent box3))
- (button (make-button
- :label "[?]"
- :visible t
- :parent box3
- :signal (list
- 'clicked #'tips-query-start-query
- :object tips-query))))
-
- (box-set-child-packing box3 button nil nil 0 :start)
- (tooltips-set-tip
- tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
- (setf (tips-query-caller tips-query) button)
-
- (signal-connect
- tips-query 'widget-entered
- #'(lambda (widget tip-text tip-private)
- (declare (ignore widget tip-private))
- (when (toggle-button-active-p toggle)
- (setf
- (label-text tips-query)
- (if tip-text
- "There is a Tip!"
- "There is no Tip!"))
- (signal-emit-stop tips-query 'widget-entered))))
-
- (signal-connect
- tips-query 'widget-selected
- #'(lambda (widget tip-text tip-private event)
- (declare (ignore tip-text event))
- (when widget
- (format
- t "Help ~S requested for ~S~%"
- (or tip-private "None") (type-of widget)))
- t))
-
- (let ((frame (make-frame
- :label "ToolTips Inspector"
- :label-xalign 0.5
- :border-width 0
- :visible t
- :parent main-box
- :child box3)))
- (box-set-child-packing main-box frame t t 0 :start))
-
- (tooltips-set-tip
- tooltips close-button "Push this button to close window"
- "ContextHelp/buttons/Close")))))
+(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
+ (make-instance 'v-box
+ :parent window
+ :child (create-label "Above")
+ :child (make-instance 'h-separator)
+ :child (make-instance 'h-box
+ :spacing 10
+ :child (list
+ (make-instance 'handle-box
+ :child (create-toolbar window)
+ :signal (list 'child-attached
+ #'(lambda (child)
+ (format t "~A attached~%" child)))
+ :signal (list 'child-detached
+ #'(lambda (child)
+ (format t "~A detached~%" child))))
+ :expand nil :fill :nil))
+ :child (make-instance 'h-separator)
+ :child (create-label "Below")))
+
+
+;;; Tooltips test. Note that GtkTooltips has been deprecated in GTK+ 2.12
+
+(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
+ (let ((tooltips (make-instance 'tooltips)))
+ (flet ((create-button (label tip-text tip-private)
+ (let ((button (make-instance 'toggle-button :label label)))
+ (tooltips-set-tip tooltips button tip-text tip-private)
+ button)))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 10
+ :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
+ :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
+
+
+;;; UI Manager
+
+(defvar *ui-description*
+ '((:menubar "MenuBar"
+ (:menu "FileMenu"
+ (:menuitem "New")
+ (:menuitem "Open")
+ (:menuitem "Save")
+ (:menuitem "SaveAs")
+ :separator
+ (:menuitem "Quit"))
+ (:menu "PreferencesMenu"
+ (:menu "ColorMenu"
+ (:menuitem "Red")
+ (:menuitem "Green")
+ (:menuitem "Blue"))
+ (:menu "ShapeMenu"
+ (:menuitem "Square")
+ (:menuitem "Rectangle")
+ (:menuitem "Oval"))
+ (:menuitem "Bold"))
+ (:menu "HelpMenu"
+ (:menuitem "About")))
+ (:toolbar "ToolBar"
+ (:toolitem "Open")
+ (:toolitem "Quit")
+ :separator
+ (:toolitem "Logo"))))
+
+(define-toplevel create-ui-manager (window "UI Manager")
+ (let ((ui (make-instance 'ui-manager)))
+ (window-add-accel-group window (ui-manager-accel-group ui))
+ (ui-manager-insert-action-group ui
+ (make-instance 'action-group :name "Actions"
+ :action (make-instance 'action :name "FileMenu" :label "_File")
+ :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
+ :action (make-instance 'action :name "ColorMenu" :label "_Color")
+ :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
+ :action (make-instance 'action :name "HelpMenu" :label "_Help")
+ :action (make-instance 'action
+ :name "New" :stock-id "gtk-new" :label "_New"
+ :accelerator "<control>N" :tooltip "Create a new file")
+ :action (make-instance 'action
+ :name "Open" :stock-id "gtk-open" :label "_Open"
+ :accelerator "<control>O" :tooltip "Open a file"
+ :callback #'create-file-chooser)
+ :action (make-instance 'action
+ :name "Save" :stock-id "gtk-save" :label "_Save"
+ :accelerator "<control>S" :tooltip "Save current file")
+ :action (make-instance 'action
+ :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
+ :tooltip "Save to a file")
+ :action (make-instance 'action
+ :name "Quit" :stock-id "gtk-quit" :label "_Quit"
+ :accelerator "<control>Q" :tooltip "Quit"
+ :callback (list #'widget-destroy :object window))
+ :action (make-instance 'action
+ :name "About" :label "_About"
+ :accelerator "<control>A" :tooltip "About")
+ :action (make-instance 'action
+ :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
+ :action (make-instance 'toggle-action
+ :name "Bold" :stock-id "gtk-bold" :label "_Bold"
+ :accelerator "<control>B" :tooltip "Bold" :active t)
+ :actions (make-radio-group 'radio-action
+ '((:name "Red" :value :red :label "_Red"
+ :accelerator "<control>R" :tooltip "Blood")
+ (:name "Green" :value :green :label "_Green"
+ :accelerator "<control>G" :tooltip "Grass" :active t)
+ (:name "Blue" :value :blue :label "_Blue"
+ :accelerator "<control>B" :tooltip "Sky"))
+ #'(lambda (active) (print active)))
+ :actions (make-radio-group 'radio-action
+ '((:name "Square" :value :square :label "_Square"
+ :accelerator "<control>S" :tooltip "Square")
+ (:name "Rectangle" :value :rectangle :label "_Rectangle"
+ :accelerator "<control>R" :tooltip "Rectangle")
+ (:name "Oval" :value :oval :label "_Oval"
+ :accelerator "<control>O" :tooltip "Egg"))
+ #'(lambda (active) (print active)))))
+
+ (ui-manager-add-ui ui *ui-description*)
+
+ (make-instance 'v-box
+ :parent window
+ :child (list
+ (ui-manager-get-widget ui "/MenuBar")
+ :expand nil :fill nil)
+ :child (list
+ (ui-manager-get-widget ui "/ToolBar")
+ :expand nil :fill nil)
+ :child (make-instance 'label
+ :label "Type Ctrl+Q to quit"
+ :xalign 0.5 :yalign 0.5
+ :width-request 200 :height-request 200))))
-;;; Tree
-
-(defconstant +default-number-of-items+ 3)
-(defconstant +default-recursion-level+ 3)
-
-(defun create-subtree (item level nb-item-max recursion-level-max)
- (unless (and level (= level recursion-level-max))
- (multiple-value-bind (level item-subtree no-root-item)
- (if (not level)
- (values 0 item t)
- (values level (tree-new) nil))
-
- (dotimes (nb-item nb-item-max)
- (let ((new-item
- (tree-item-new (format nil "item ~D-~D" level nb-item))))
- (tree-append item-subtree new-item)
- (create-subtree
- new-item (1+ level) nb-item-max recursion-level-max)
- (widget-show new-item)))
-
- (unless no-root-item
- (setf (tree-item-subtree item) item-subtree)))))
-
-
-(defun create-tree-sample (selection-mode draw-line view-line no-root-item
- nb-item-max recursion-level-max)
- (let ((window (window-new :toplevel)))
- (setf (window-title window) "Tree Sample")
- (signal-connect window 'destroy #'(lambda ()))
-
- (let ((box1 (vbox-new nil 0))
- (root-tree (tree-new))
- (add-button (button-new "Add Item"))
- (remove-button (button-new "Remove Item(s)"))
- (subtree-button (button-new "Remove Subtree")))
- (container-add window box1)
- (widget-show box1)
-
- (let ((box2 (vbox-new nil 0))
- (scrolled-win (scrolled-window-new nil nil)))
- (box-pack box1 box2)
- (setf (container-border-width box2) 5)
- (widget-show box2)
- (setf (scrolled-window-scrollbar-policy scrolled-win) :automatic)
- (box-pack box2 scrolled-win)
- (setf (widget-width scrolled-win) 200)
- (setf (widget-height scrolled-win) 200)
- (widget-show scrolled-win)
- (signal-connect
- root-tree 'selection-changed
- #'(lambda ()
- (format t "Selection: ~A~%" (tree-selection root-tree))
- (let ((nb-selected (length (tree-selection root-tree))))
- (if (zerop nb-selected)
- (progn
- (if (container-children root-tree)
- (setf (widget-sensitive-p add-button) t)
- (setf (widget-sensitive-p add-button) nil))
- (setf (widget-sensitive-p remove-button) nil)
- (setf (widget-sensitive-p subtree-button) nil))
- (progn
- (setf (widget-sensitive-p remove-button) t)
- (setf (widget-sensitive-p add-button) (= 1 nb-selected))
- (setf
- (widget-sensitive-p subtree-button) (= 1 nb-selected)))))))
- (scrolled-window-add-with-viewport scrolled-win root-tree)
- (setf (tree-selection-mode root-tree) selection-mode)
- (setf (tree-view-lines-p root-tree) draw-line)
- (setf (tree-view-mode root-tree) (if view-line :line :item))
- (widget-show root-tree)
-
- (let ((root-item
- (if no-root-item
- root-tree
- (let ((root-item (tree-item-new "root item")))
- (tree-append root-tree root-item)
- (widget-show root-item)
- root-item))))
- (create-subtree
- root-item (if no-root-item nil 0) nb-item-max recursion-level-max)))
-
- (let ((box2 (vbox-new nil 0)))
- (box-pack-start box1 box2 nil nil 0)
- (setf (container-border-width box2) 5)
- (widget-show box2)
-
- (setf (widget-sensitive-p add-button) nil)
- (let ((nb-item-add 0))
- (signal-connect
- add-button 'clicked
- #'(lambda ()
- (let* ((selected-list (tree-selection root-tree))
- (subtree (if (not selected-list)
- root-tree
- (let ((selected-item (first selected-list)))
- (or
- (tree-item-subtree selected-item)
- (let ((subtree (tree-new)))
- (setf
- (tree-item-subtree selected-item)
- subtree)
- subtree)))))
- (new-item
- (tree-item-new (format nil "item add ~D" nb-item-add))))
- (tree-append subtree new-item)
- (widget-show new-item)
- (incf nb-item-add)))))
- (box-pack-start box2 add-button t t 0)
- (widget-show add-button)
-
- (setf (widget-sensitive-p remove-button) nil)
- (signal-connect
- remove-button 'clicked
- #'(lambda ()
- (format t "Remove: ~A~%" (tree-selection root-tree))
- (tree-remove-items root-tree (tree-selection root-tree))))
- (box-pack-start box2 remove-button t t 0)
- (widget-show remove-button)
-
- (setf (widget-sensitive-p subtree-button) nil)
- (signal-connect
- subtree-button 'clicked
- #'(lambda ()
- (let ((selected-list (tree-selection root-tree)))
- (when selected-list
- (let ((item (first selected-list)))
- (when item
- (setf (tree-item-subtree item) nil)))))))
- (box-pack-start box2 subtree-button t t 0)
- (widget-show subtree-button))
-
- (let ((separator (hseparator-new)))
- (box-pack-start box1 separator nil nil 0)
- (widget-show separator))
-
- (let ((box2 (vbox-new nil 0))
- (button (button-new "Close")))
- (box-pack-start box1 box2 nil nil 0)
- (setf (container-border-width box2) 5)
- (widget-show box2)
- (box-pack-start box2 button t t 0)
- (signal-connect button 'clicked
- #'(lambda ()
- (widget-destroy window)))
- (widget-show button)))
-
- (widget-show window)))
-
-
-(define-test-window create-tree "Set Tree Parameters"
- (let ((box1 (vbox-new nil 0)))
- (container-add window box1)
-
- (let ((box2 (vbox-new nil 5)))
- (box-pack box1 box2)
- (setf (container-border-width box2) 5)
-
- (let ((box3 (hbox-new nil 5)))
- (box-pack box2 box3)
-
- (let* ((single-button (radio-button-new nil :label "SIGNLE"))
- (browse-button
- (radio-button-new
- (radio-button-group single-button) :label "BROWSE"))
- (multiple-button
- (radio-button-new
- (radio-button-group single-button) :label "MULTIPLE"))
- (draw-line-button (check-button-new "Draw line"))
- (view-line-button (check-button-new "View Line mode"))
- (no-root-item-button (check-button-new "Without Root item"))
- (num-of-items-spinner
- (spin-button-new
- (adjustment-new
- +default-number-of-items+ 1 255 1 5 0)
- 0 0))
- (depth-spinner
- (spin-button-new
- (adjustment-new
- +default-recursion-level+ 0 255 1 5 0)
- 5 0)))
-
- (let ((frame (frame-new "Selection Mode"))
- (box4 (vbox-new nil 0)))
- (box-pack box3 frame)
- (container-add frame box4)
- (setf (container-border-width box4) 5)
- (box-pack box4 single-button)
- (box-pack box4 browse-button)
- (box-pack box4 multiple-button))
-
- (let ((frame (frame-new "Options"))
- (box4 (vbox-new nil 0)))
- (box-pack box3 frame)
- (container-add frame box4)
- (setf (container-border-width box4) 5)
- (box-pack box4 draw-line-button)
- (box-pack box4 view-line-button)
- (box-pack box4 no-root-item-button)
- (setf (toggle-button-active-p draw-line-button) t)
- (setf (toggle-button-active-p view-line-button) t)
- (setf (toggle-button-active-p no-root-item-button) nil))
-
- (let ((frame (frame-new "Size Parameters"))
- (box4 (vbox-new nil 5)))
- (box-pack box2 frame)
- (container-add frame box4)
- (setf (container-border-width box4) 5)
-
- (let ((box5 (hbox-new nil 5)))
- (box-pack box4 box5 :expand nil :fill nil)
- (let ((label (label-new "Number of items : ")))
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack box5 label :expand nil)
- (box-pack box5 num-of-items-spinner :expand nil))
- (let ((label (label-new "Depth : ")))
- (setf (misc-xalign label) 0)
- (setf (misc-yalign label) 0.5)
- (box-pack box5 label :expand nil)
- (box-pack box5 depth-spinner :expand nil))))
-
- (box-pack box1 (hseparator-new) :expand nil :fill nil)
-
- (let ((box2 (hbox-new t 10)))
- (box-pack box1 box2)
- (setf (container-border-width box2) 5)
- (let ((button (button-new "Create Tree")))
- (box-pack box2 button)
- (signal-connect
- button 'clicked
- #'(lambda ()
- (let ((selection-mode
- (cond
- ((toggle-button-active-p single-button) :single)
- ((toggle-button-active-p browse-button) :browse)
- (t :multiple)))
- (draw-line
- (toggle-button-active-p draw-line-button))
- (view-line
- (toggle-button-active-p view-line-button))
- (no-root-item
- (toggle-button-active-p no-root-item-button))
- (num-of-items
- (spin-button-value-as-int num-of-items-spinner))
- (depth
- (spin-button-value-as-int depth-spinner)))
-
- (if (> (expt num-of-items depth) 10000)
- (format t "~D total items? That will take a very long time. Try less~%" (expt num-of-items depth))
- (create-tree-sample
- selection-mode draw-line view-line no-root-item
- num-of-items depth))))))
- (let ((button (button-new "Close")))
- (box-pack box2 button)
- (signal-connect
- button 'clicked #'widget-destroy :object window))))))))
-
-
-
;;; Main window
-(defun create-main-window ()
- (let* ((buttons
+(defun create-main-window (&optional display)
+ (let* ((button-specs
'(("button box" create-button-box)
- ("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")
- ("entry" create-entry)
- ("event watcher")
- ("file selection" create-file-selection)
- ("font selection")
- ("gamma curve")
- ("handle box" create-handle-box)
- ("item factory")
- ("labels" create-labels)
- ("layout" create-layout)
- ("list" create-list)
+ ("buttons" create-buttons)
+ ("calendar" create-calendar)
+ ("check buttons" create-check-buttons)
+ ("color selection" create-color-selection)
+ ("cursors" create-cursors)
+ ("dialog" create-dialog)
+ ("entry" create-entry)
+ ("enxpander" create-expander)
+ ("file chooser" create-file-chooser)
+ ("font selection" create-font-selection)
+ ("handle box" create-handle-box)
+ #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
+ ("icon view" create-icon-view)
+ ("image" create-image)
+ ("labels" create-labels)
+ ("layout" create-layout)
+ ("list" create-list)
("menus" create-menus)
- ("modal window")
- ("notebook" create-notebook)
- ("panes" create-panes)
- ("pixmap" create-pixmap)
- ("preview color")
- ("preview gray")
- ("progress bar" create-progress-bar)
- ("radio buttons" create-radio-buttons)
- ("range controls" create-range-controls)
- ("rc file")
- ("reparent" create-reparent)
- ("rulers" create-rulers)
- ("saved position")
- ("scrolled windows" create-scrolled-windows)
- ("shapes" create-shapes)
- ("spinbutton" create-spins)
- ("statusbar" create-statusbar)
- ("test idle" create-idle-test)
- ("test mainloop")
- ("test scrolling")
- ("test selection")
- ("test timeout" create-timeout-test)
- ("text" create-text)
- ("toggle buttons" create-toggle-buttons)
- ("toolbar" create-toolbar)
- ("tooltips" create-tooltips)
- ("tree" create-tree)
- ("WM hints")))
+;; ("modal window")
+ ("notebook" create-notebook)
+ ("panes" create-panes)
+ ("progress bar" create-progress-bar)
+ ("radio buttons" create-radio-buttons)
+ ("range controls" create-range-controls)
+;; ("rc file")
+ ("reparent" create-reparent)
+ ("rulers" create-rulers)
+;; ("saved position")
+ ("scrolled windows" create-scrolled-windows)
+ ("size group" create-size-group)
+ ("shapes" create-shapes)
+ ("spinbutton" create-spins)
+ ("statusbar" create-statusbar)
+ ("test idle" create-idle-test)
+ ("test timeout" create-timeout-test)
+ ("text" create-text)
+ ("toggle buttons" create-toggle-buttons)
+ ("toolbar" create-toolbar-window)
+ ("tooltips" create-tooltips)
+ ("UI manager" create-ui-manager)))
+
(main-window (make-instance 'window
- :type :toplevel :title "testgtk.lisp"
- :name "main window" :x 20 :y 20 :width 200 :height 400
- :allow-grow nil :allow-shrink nil :auto-shrink nil))
+ :display display
+ :title "testgtk.lisp" :name "main_window"
+ :default-width 200 :default-height 400
+ :allow-grow t :allow-shrink nil))
(scrolled-window (make-instance 'scrolled-window
- :hscrollbar-policy :automatic
+ :hscrollbar-policy :automatic
:vscrollbar-policy :automatic
:border-width 10))
- (close-button (make-instance 'button
- :label "close"
- :can-default t ;:has-default t
- :signals
- (list
- (list
- 'clicked #'widget-destroy :object main-window)))))
+ (close-button (make-instance 'button
+ :stock "gtk-close" :can-default t
+ :signal (list 'clicked #'widget-destroy :object main-window))))
+
+ (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
+ (setf
+ (window-icon main-window)
+ (gdk:pixbuf-add-alpha icon t 254 254 252)))
;; Main box
- (make-instance 'vbox
+ (make-instance 'v-box
:parent main-window
- :children
- (list
- (list
- (make-instance 'label :label (gtk-version))
- :expand nil :fill nil)
- (list
- (make-instance 'label :label (format nil "clg CVS version"))
- :expand nil :fill nil)
- scrolled-window
- (list (make-instance 'hseparator) :expand nil)
- (list
- (make-instance 'vbox
- :homogeneous nil :spacing 10 :border-width 10
- :children (list (list close-button :expand t :fill t)))
- :expand nil)))
-
- (let ((button-box
- (make-instance 'vbox
- :border-width 10
+ :child-args '(:expand nil)
+ :child (list (make-instance 'label :label (gtk-version)) :fill nil)
+ :child (list (make-instance 'label :label (clg-version)) :fill nil)
+ :child (list (make-instance 'label
+ :label #-cmu
+ (format nil "~A (~A)"
+ (lisp-implementation-type)
+ #-clisp
+ (lisp-implementation-version)
+ #+clisp
+ (let ((version (lisp-implementation-version)))
+ (subseq version 0 (position #\sp version))))
+ ;; The version string in CMUCL is far too long
+ #+cmu(lisp-implementation-type))
+ :fill nil)
+ :child (list scrolled-window :expand t)
+ :child (make-instance 'h-separator)
+ :child (make-instance 'v-box
+ :homogeneous nil :spacing 10 :border-width 10
+ :child close-button))
+
+ (let ((content-box
+ (make-instance 'v-box
:focus-vadjustment (scrolled-window-vadjustment scrolled-window)
- :children
- (map
- 'list
- #'(lambda (button)
- (let ((widget (make-instance 'button :label (first button))))
- (if (second button)
- (signal-connect widget 'clicked (second button))
- (setf (widget-sensitive-p widget) nil))
- widget))
- buttons))))
+ :children (mapcar #'(lambda (spec)
+ (apply #'create-button spec))
+ button-specs))))
+ (scrolled-window-add-with-viewport scrolled-window content-box))
- (scrolled-window-add-with-viewport scrolled-window button-box))
-
- (widget-grab-default close-button)
+ (widget-grab-focus close-button)
(widget-show-all main-window)
main-window))
-;(gdk:rgb-init)
-(rc-parse "cl-gtk:src;testgtkrc2")
-(rc-parse "cl-gtk:src;testgtkrc")
-
-
-;(create-main-window)
-
+(clg-init)
+(within-main-loop (create-main-window))
~mdw / clg / blobdiff